{-# LANGUAGE BangPatterns, CPP, 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

#include "HsVersions.h"

import GHC.Prelude
import GHC.Platform

import GHC.Runtime.Interpreter as GHCi
import GHCi.RemoteTypes
import GHC.Driver.Types
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.Utils.Outputable as Ppr
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
import System.IO.Unsafe

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

data Term = Term { Term -> TcType
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 -> TcType
termType Term
t = Term -> TcType
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 (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 (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 (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 -> TcType -> [Word] -> a
fPrim        :: RttiType -> [Word] -> a
                           , forall a.
TermFold a
-> ClosureType -> TcType -> ForeignHValue -> Maybe Name -> a
fSuspension  :: ClosureType -> RttiType -> ForeignHValue
                                            -> Maybe Name -> a
                           , forall a. TermFold a -> TcType -> Either String DataCon -> a -> a
fNewtypeWrap :: RttiType -> Either String DataCon
                                            -> a -> a
                           , forall a. TermFold a -> TcType -> 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 -> TcType -> [Word] -> m a
fPrimM        :: RttiType -> [Word] -> m a
                            , forall (m :: * -> *) a.
TermFoldM m a
-> ClosureType -> TcType -> ForeignHValue -> Maybe Name -> m a
fSuspensionM  :: ClosureType -> RttiType -> ForeignHValue
                                             -> Maybe Name -> m a
                            , forall (m :: * -> *) a.
TermFoldM m a -> TcType -> Either String DataCon -> a -> m a
fNewtypeWrapM :: RttiType -> Either String DataCon
                                            -> a -> m a
                            , forall (m :: * -> *) a. TermFoldM m a -> TcType -> 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 TcType
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 TcType
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 TcType
ty    [Word]
v   ) = TermFold a -> TcType -> [Word] -> a
forall a. TermFold a -> TcType -> [Word] -> a
fPrim TermFold a
tf TcType
ty [Word]
v
foldTerm TermFold a
tf (Suspension ClosureType
ct TcType
ty ForeignHValue
v Maybe Name
b) = TermFold a
-> ClosureType -> TcType -> ForeignHValue -> Maybe Name -> a
forall a.
TermFold a
-> ClosureType -> TcType -> ForeignHValue -> Maybe Name -> a
fSuspension TermFold a
tf ClosureType
ct TcType
ty ForeignHValue
v Maybe Name
b
foldTerm TermFold a
tf (NewtypeWrap TcType
ty Either String DataCon
dc Term
t)  = TermFold a -> TcType -> Either String DataCon -> a -> a
forall a. TermFold a -> TcType -> Either String DataCon -> a -> a
fNewtypeWrap TermFold a
tf TcType
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 TcType
ty Term
t)         = TermFold a -> TcType -> a -> a
forall a. TermFold a -> TcType -> a -> a
fRefWrap TermFold a
tf TcType
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 TcType
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)
mapM (TermFoldM m a -> Term -> m a
forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
foldTermM TermFoldM m a
tf) [Term]
tt m [a] -> ([a] -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermFoldM m a -> TermProcessor a (m a)
forall (m :: * -> *) a. TermFoldM m a -> TermProcessor a (m a)
fTermM TermFoldM m a
tf TcType
ty Either String DataCon
dc ForeignHValue
v
foldTermM TermFoldM m a
tf (Prim TcType
ty    [Word]
v   ) = TermFoldM m a -> TcType -> [Word] -> m a
forall (m :: * -> *) a. TermFoldM m a -> TcType -> [Word] -> m a
fPrimM TermFoldM m a
tf TcType
ty [Word]
v
foldTermM TermFoldM m a
tf (Suspension ClosureType
ct TcType
ty ForeignHValue
v Maybe Name
b) = TermFoldM m a
-> ClosureType -> TcType -> ForeignHValue -> Maybe Name -> m a
forall (m :: * -> *) a.
TermFoldM m a
-> ClosureType -> TcType -> ForeignHValue -> Maybe Name -> m a
fSuspensionM TermFoldM m a
tf ClosureType
ct TcType
ty ForeignHValue
v Maybe Name
b
foldTermM TermFoldM m a
tf (NewtypeWrap TcType
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=  TermFoldM m a -> TcType -> Either String DataCon -> a -> m a
forall (m :: * -> *) a.
TermFoldM m a -> TcType -> Either String DataCon -> a -> m a
fNewtypeWrapM TermFoldM m a
tf TcType
ty Either String DataCon
dc
foldTermM TermFoldM m a
tf (RefWrap TcType
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermFoldM m a -> TcType -> a -> m a
forall (m :: * -> *) a. TermFoldM m a -> TcType -> a -> m a
fRefWrapM TermFoldM m a
tf TcType
ty

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

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

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

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

----------------------------------
-- 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)
mapM (TermPrinterM m
y Int
app_prec) [Term]
tt
  SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Bool -> Bool
not ([Term] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Term]
tt) Bool -> Bool -> Bool
&& Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
app_prec)
                  (String -> SDoc
text String
dc_tag SDoc -> SDoc -> SDoc
<+> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList [SDoc] -> SDoc
fsep [SDoc]
tt_docs)

ppr_termM 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)
mapM (TermPrinterM m
y Int
app_prec) [Term]
tt
       ; SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc -> SDoc
ifPprDebug ([SDoc] -> SDoc
show_tm [SDoc]
tt_docs')
                             ([SDoc] -> SDoc
show_tm ([TcType] -> [SDoc] -> [SDoc]
forall b a. [b] -> [a] -> [a]
dropList (DataCon -> [TcType]
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 (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 (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 -> TcType
ty=TcType
ty} =
    SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ TyCon -> [Word] -> SDoc
repPrim (TcType -> TyCon
tyConAppTyCon TcType
ty) [Word]
words
ppr_termM1 Suspension{ty :: Term -> TcType
ty=TcType
ty, bound_to :: Term -> Maybe Name
bound_to=Maybe Name
Nothing} =
    SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> SDoc
char Char
'_' SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
whenPprDebug (String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty))
ppr_termM1 Suspension{ty :: Term -> TcType
ty=TcType
ty, bound_to :: Term -> Maybe Name
bound_to=Just Name
n}
--  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
  | Bool
otherwise = SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return(SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
parens(SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
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 -> TcType
ty=TcType
ty, wrapped_term :: Term -> Term
wrapped_term=Term
t}
  | Just (TyCon
tc,[TcType]
_) <- HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty
  , ASSERT(isNewTyCon tc) True
  , Just DataCon
new_dc <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc = do
             SDoc
real_term <- TermPrinterM m
y Int
max_prec Term
t
             SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
app_prec) (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
new_dc SDoc -> SDoc -> SDoc
<+> SDoc
real_term)
pprNewtypeWrap 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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Maybe a) -> (a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([m (Maybe a)] -> m (Maybe a)
firstJustM [m (Maybe a)]
mbs) (Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)
  firstJustM [] = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

-- 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 (TcType -> Bool
isTupleTy(TcType -> Bool) -> (Term -> TcType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Term -> TcType
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)
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 -> TcType -> Bool
isTyCon TyCon
listTyCon (Term -> TcType
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 -> TcType -> Bool
isTyCon TyCon
intTyCon     (TcType -> Bool) -> (Term -> TcType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> TcType
ty) Int -> Term -> m (Maybe SDoc)
ppr_int
  , (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> TcType -> Bool
isTyCon TyCon
charTyCon    (TcType -> Bool) -> (Term -> TcType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> TcType
ty) Int -> Term -> m (Maybe SDoc)
ppr_char
  , (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> TcType -> Bool
isTyCon TyCon
floatTyCon   (TcType -> Bool) -> (Term -> TcType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> TcType
ty) Int -> Term -> m (Maybe SDoc)
ppr_float
  , (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> TcType -> Bool
isTyCon TyCon
doubleTyCon  (TcType -> Bool) -> (Term -> TcType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> TcType
ty) Int -> Term -> m (Maybe SDoc)
ppr_double
  , (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> TcType -> Bool
isTyCon TyCon
integerTyCon (TcType -> Bool) -> (Term -> TcType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> TcType
ty) Int -> Term -> m (Maybe SDoc)
ppr_integer
  , (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> TcType -> Bool
isTyCon TyCon
naturalTyCon (TcType -> Bool) -> (Term -> TcType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> TcType
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 (m :: * -> *) a. Monad m => a -> m a
return Maybe SDoc
forall a. Maybe a
Nothing

   isTupleTy :: TcType -> Bool
isTupleTy TcType
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,[TcType]
_) <- HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty
     Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Bool
isBoxedTupleTyCon TyCon
tc)

   isTyCon :: TyCon -> TcType -> Bool
isTyCon TyCon
a_tc TcType
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,[TcType]
_) <- HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty
     Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
a_tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc)

   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 (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 (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 (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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Float -> IO Float
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word -> Ptr Float
forall a b. Ptr a -> Ptr b
castPtr Ptr Word
p)
      Maybe SDoc -> m (Maybe SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Float -> SDoc
Ppr.float Float
f))
   ppr_float Int
_ Term
_ = Maybe SDoc -> m (Maybe SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SDoc
forall a. Maybe a
Nothing

   ppr_double :: Int -> Term -> m (Maybe SDoc)
ppr_double  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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Double -> IO Double
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word -> Ptr Double
forall a b. Ptr a -> Ptr b
castPtr Ptr Word
p)
      Maybe SDoc -> m (Maybe SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Double -> SDoc
Ppr.double Double
f))
   -- 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 (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 (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 (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 (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 (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 (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 (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 -> TcType
termType ([Term] -> Term
forall a. [a] -> a
last [Term]
elems) TcType -> TcType -> Bool
`eqType` Term -> TcType
termType Term
h)
           is_string :: Bool
is_string  = (Term -> Bool) -> [Term] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TcType -> Bool
isCharTy (TcType -> Bool) -> (Term -> TcType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> TcType
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)
mapM (TermPrinterM m
y Int
cons_prec) [Term]
elems
       if Bool
is_string
        then SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> SDoc
Ppr.doubleQuotes (String -> SDoc
Ppr.text String
chars))
        else if Bool
isConsLast
        then SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
cons_prec)
                    (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList [SDoc] -> SDoc
fsep
                    ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate (SDoc
spaceSDoc -> SDoc -> SDoc
<>SDoc
colon) [SDoc]
print_elems
        else SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
brackets
                    (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList [SDoc] -> SDoc
fcat
                    ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [SDoc]
print_elems

        where getListTerms :: Term -> [Term]
getListTerms Term{subTerms :: Term -> [Term]
subTerms=[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
forall {a}. Storable a => [a] -> SDoc
rep where
   rep :: [a] -> SDoc
rep [a]
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 ([a] -> Int
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [a]
x :: Int))
    | TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
intPrimTyCon              = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [a]
x :: Int)
    | TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
wordPrimTyCon             = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Word -> String
forall a. Show a => a -> String
show ([a] -> Word
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [a]
x :: Word)
    | TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
floatPrimTyCon            = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Float -> String
forall a. Show a => a -> String
show ([a] -> Float
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [a]
x :: Float)
    | TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
doublePrimTyCon           = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Double -> String
forall a. Show a => a -> String
show ([a] -> Double
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [a]
x :: Double)
    | TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int32PrimTyCon            = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Int32 -> String
forall a. Show a => a -> String
show ([a] -> Int32
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [a]
x :: Int32)
    | TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word32PrimTyCon           = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Word32 -> String
forall a. Show a => a -> String
show ([a] -> Word32
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [a]
x :: Word32)
    | TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int64PrimTyCon            = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show ([a] -> Int64
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [a]
x :: Int64)
    | TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word64PrimTyCon           = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Word64 -> String
forall a. Show a => a -> String
show ([a] -> Word64
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [a]
x :: Word64)
    | TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
addrPrimTyCon             = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Ptr Any -> String
forall a. Show a => a -> String
show (Ptr Any
forall a. Ptr a
nullPtr Ptr Any -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` [a] -> Int
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [a]
x)
    | TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
stablePtrPrimTyCon        = String -> SDoc
text 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)
-}


-- A (non-mutable) tau type containing
-- existentially quantified tyvars.
--    (since GHC type language currently does not support
--     existentials, we leave these variables unquantified)
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 (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
_errs, Maybe a
res) <- HscEnv -> TR a -> IO (Messages, Maybe a)
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
initTcInteractive HscEnv
hsc_env TR a
thing_inside
       ; Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
res }

-- | 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

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

newVar :: Kind -> TR TcType
newVar :: TcType -> TR TcType
newVar = TR TcType -> TR TcType
forall a. TcM a -> TcM a
liftTcM (TR TcType -> TR TcType)
-> (TcType -> TR TcType) -> TcType -> TR TcType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcType -> TR TcType
newFlexiTyVarTy

newOpenVar :: TR TcType
newOpenVar :: TR TcType
newOpenVar = TR TcType -> TR TcType
forall a. TcM a -> TcM a
liftTcM TR TcType
newOpenFlexiTyVarTy

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

-- | 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 (TcType, RttiInstantiation)
instScheme ([TyVar]
tvs, TcType
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]
       ; (TcType, RttiInstantiation) -> TR (TcType, RttiInstantiation)
forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => TCvSubst -> TcType -> TcType
TCvSubst -> TcType -> TcType
substTy TCvSubst
subst TcType
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 { TcType
tc_ty <- TyVar -> TR TcType
zonkTcTyVar TyVar
tc_tv
           ; case TcType -> Maybe TyVar
tcGetTyVar_maybe TcType
tc_ty of
               Just TyVar
tv | TyVar -> Bool
isMetaTyVar TyVar
tv -> TyVar -> TcType -> TR ()
writeMetaTyVar TyVar
tv (TyVar -> TcType
mkTyVarTy TyVar
rtti_tv)
               Maybe TyVar
_                        -> () -> TR ()
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 :: TcType -> TcType -> TR ()
addConstraint TcType
actual TcType
expected = do
    SDoc -> TR ()
traceTR (String -> SDoc
text String
"add constraint:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
fsep [TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
actual, SDoc
equals, TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
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", TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
actual,
                                    String -> SDoc
text String
"with", TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
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 { (TcType
ty1, TcType
ty2) <- TcType -> TcType -> TR (TcType, TcType)
congruenceNewtypes TcType
actual TcType
expected
         ; Maybe (HsExpr GhcRn) -> TcType -> TcType -> TcM TcCoercionN
unifyType Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing TcType
ty1 TcType
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 -> TcType -> ForeignHValue -> IO Term
cvObtainTerm HscEnv
hsc_env Int
max_depth Bool
force TcType
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, TcType
old_tau) = TcType -> QuantifiedType
quantifyType TcType
old_ty
       sigma_old_ty :: TcType
sigma_old_ty = [TyVar] -> TcType -> TcType
mkInfForAllTys [TyVar]
old_tvs TcType
old_tau
   SDoc -> TR ()
traceTR (String -> SDoc
text String
"Term reconstruction started with initial type " SDoc -> SDoc -> SDoc
<> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
old_ty)
   Term
term <-
     if [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
old_tvs
      then do
        Term
term  <- Int -> TcType -> TcType -> ForeignHValue -> TR Term
go Int
max_depth TcType
sigma_old_ty TcType
sigma_old_ty ForeignHValue
hval
        Term
term' <- Term -> TR Term
zonkTerm Term
term
        Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> TR Term) -> Term -> TR Term
forall a b. (a -> b) -> a -> b
$ Term -> Term
fixFunDictionaries (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ Term -> Term
expandNewtypes Term
term'
      else do
              (TcType
old_ty', RttiInstantiation
rev_subst) <- QuantifiedType -> TR (TcType, RttiInstantiation)
instScheme QuantifiedType
quant_old_ty
              TcType
my_ty <- TR TcType
newOpenVar
              Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (QuantifiedType -> Bool
check1 QuantifiedType
quant_old_ty) (SDoc -> TR ()
traceTR (String -> SDoc
text String
"check1 passed") TR () -> TR () -> TR ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                          TcType -> TcType -> TR ()
addConstraint TcType
my_ty TcType
old_ty')
              Term
term  <- Int -> TcType -> TcType -> ForeignHValue -> TR Term
go Int
max_depth TcType
my_ty TcType
sigma_old_ty ForeignHValue
hval
              TcType
new_ty <- TcType -> TR TcType
zonkTcType (Term -> TcType
termType Term
term)
              if TcType -> Bool
isMonomorphic TcType
new_ty Bool -> Bool -> Bool
|| QuantifiedType -> QuantifiedType -> Bool
check2 (TcType -> QuantifiedType
quantifyType TcType
new_ty) QuantifiedType
quant_old_ty
                 then do
                      SDoc -> TR ()
traceTR (String -> SDoc
text String
"check2 passed")
                      TcType -> TcType -> TR ()
addConstraint TcType
new_ty TcType
old_ty'
                      RttiInstantiation -> TR ()
applyRevSubst RttiInstantiation
rev_subst
                      Term
zterm' <- Term -> TR Term
zonkTerm Term
term
                      Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> Term
fixFunDictionaries (Term -> Term) -> (Term -> Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Term
expandNewtypes) Term
zterm')
                 else do
                      SDoc -> TR ()
traceTR (String -> SDoc
text 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
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
new_ty))
                      -- we have unsound types. Replace constructor types in
                      -- subterms with tyvars
                      Term
zterm' <- (TcType -> TR TcType) -> Term -> TR Term
forall (m :: * -> *).
Monad m =>
(TcType -> m TcType) -> Term -> m Term
mapTermTypeM
                                 (\TcType
ty -> case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
                                           Just (TyCon
tc, TcType
_:[TcType]
_) | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
/= TyCon
funTyCon
                                               -> TR TcType
newOpenVar
                                           Maybe (TyCon, [TcType])
_   -> TcType -> TR TcType
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
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
<> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Term -> TcType
termType Term
term))
   Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return Term
term
    where
  go :: Int -> Type -> Type -> ForeignHValue -> TcM Term
   -- I believe that my_ty should not have any enclosing
   -- foralls, nor any free RuntimeUnk skolems;
   -- that is partly what the quantifyType stuff achieved
   --
   -- [SPJ May 11] I don't understand the difference between my_ty and old_ty

  go :: Int -> TcType -> TcType -> ForeignHValue -> TR Term
go Int
0 TcType
my_ty TcType
_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
$ HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
GHCi.getClosure HscEnv
hsc_env ForeignHValue
a
    Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> TcType -> ForeignHValue -> Maybe Name -> Term
Suspension (StgInfoTable -> ClosureType
tipe (GenClosure ForeignHValue -> StgInfoTable
forall b. GenClosure b -> StgInfoTable
info GenClosure ForeignHValue
clos)) TcType
my_ty ForeignHValue
a Maybe Name
forall a. Maybe a
Nothing)
  go !Int
max_depth TcType
my_ty TcType
old_ty ForeignHValue
a = do
    let monomorphic :: Bool
monomorphic = Bool -> Bool
not(TcType -> Bool
isTyVarTy TcType
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
$ HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
GHCi.getClosure HscEnv
hsc_env 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 (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 (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
$ HscEnv -> ForeignHValue -> IO (EvalResult ())
GHCi.seqHValue HscEnv
hsc_env ForeignHValue
a
         case EvalResult ()
evalRslt of                                            -- #2950
           EvalSuccess ()
_ -> Int -> TcType -> TcType -> ForeignHValue -> TR Term
go (Int -> Int
forall a. Enum a => a -> a
pred Int
max_depth) TcType
my_ty TcType
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 (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 (HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
GHCi.getClosure HscEnv
hsc_env ForeignHValue
ind)
         let return_bh_value :: TR Term
return_bh_value = Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> TcType -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
BLACKHOLE TcType
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 -> TcType -> TcType -> ForeignHValue -> TR Term
go Int
max_depth TcType
my_ty TcType
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 -> TcType -> TcType -> ForeignHValue -> TR Term
go Int
max_depth TcType
my_ty TcType
old_ty ForeignHValue
ind
-- We also follow references
      MutVarClosure{var :: forall b. GenClosure b -> b
var=ForeignHValue
contents}
         | Just (TyCon
tycon,[TcType
world,TcType
contents_ty]) <- HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
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
         SDoc -> TR ()
traceTR (String -> SDoc
text String
"Following a MutVar")
         TcType
contents_tv <- TcType -> TR TcType
newVar TcType
liftedTypeKind
         MASSERT(isUnliftedType my_ty)
         (TcType
mutvar_ty,RttiInstantiation
_) <- QuantifiedType -> TR (TcType, RttiInstantiation)
instScheme (QuantifiedType -> TR (TcType, RttiInstantiation))
-> QuantifiedType -> TR (TcType, RttiInstantiation)
forall a b. (a -> b) -> a -> b
$ TcType -> QuantifiedType
quantifyType (TcType -> QuantifiedType) -> TcType -> QuantifiedType
forall a b. (a -> b) -> a -> b
$ TcType -> TcType -> TcType
mkVisFunTyMany
                            TcType
contents_ty (TyCon -> [TcType] -> TcType
mkTyConApp TyCon
tycon [TcType
world,TcType
contents_ty])
         TcType -> TcType -> TR ()
addConstraint (TcType -> TcType -> TcType
mkVisFunTyMany TcType
contents_tv TcType
my_ty) TcType
mutvar_ty
         Term
x <- Int -> TcType -> TcType -> ForeignHValue -> TR Term
go (Int -> Int
forall a. Enum a => a -> a
pred Int
max_depth) TcType
contents_tv TcType
contents_ty ForeignHValue
contents
         Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (TcType -> Term -> Term
RefWrap TcType
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
<> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
my_ty)
                        else SDoc
Ppr.empty)
        Right Name
dcname <- IO (Either String Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String Name)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name))
-> IO (Either String Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name)
forall a b. (a -> b) -> a -> b
$ HscEnv -> GenClosure ForeignHValue -> IO (Either String Name)
forall a. HscEnv -> GenClosure a -> IO (Either String Name)
constrClosToName HscEnv
hsc_env GenClosure ForeignHValue
clos
        (Maybe DataCon
mb_dc, Messages
_)   <- TcRn DataCon -> TcRn (Maybe DataCon, Messages)
forall a. TcRn a -> TcRn (Maybe a, Messages)
tryTc (Name -> TcRn DataCon
tcLookupDataCon Name
dcname)
        case Maybe DataCon
mb_dc of
          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
                       [TcType]
vars     <- Int -> TR TcType -> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([ForeignHValue] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ForeignHValue]
pArgs)
                                              (TcType -> TR TcType
newVar TcType
liftedTypeKind)
                       [Term]
subTerms <- [TR Term] -> IOEnv (Env TcGblEnv TcLclEnv) [Term]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([TR Term] -> IOEnv (Env TcGblEnv TcLclEnv) [Term])
-> [TR Term] -> IOEnv (Env TcGblEnv TcLclEnv) [Term]
forall a b. (a -> b) -> a -> b
$ (ForeignHValue -> TcType -> TR Term)
-> [ForeignHValue] -> [TcType] -> [TR Term]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ForeignHValue
x TcType
tv ->
                           Int -> TcType -> TcType -> ForeignHValue -> TR Term
go (Int -> Int
forall a. Enum a => a -> a
pred Int
max_depth) TcType
tv TcType
tv ForeignHValue
x) [ForeignHValue]
pArgs [TcType]
vars
                       Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term TcType
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
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
my_ty))
            [TcType]
subTtypes <- DataCon -> TcType -> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
getDataConArgTys DataCon
dc TcType
my_ty
            [Term]
subTerms <- (TcType -> ForeignHValue -> TR Term)
-> GenClosure ForeignHValue
-> [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) [Term]
extractSubTerms (\TcType
ty -> Int -> TcType -> TcType -> ForeignHValue -> TR Term
go (Int -> Int
forall a. Enum a => a -> a
pred Int
max_depth) TcType
ty TcType
ty) GenClosure ForeignHValue
clos [TcType]
subTtypes
            Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term TcType
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 (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term TcType
my_ty (String -> Either String DataCon
forall a b. a -> Either a b
Left String
"ByteArray#") ForeignHValue
a [TcType -> [Word] -> Term
Prim TcType
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> ForeignHValue -> ()
forall a b. a -> b -> a
const ()) GenClosure ForeignHValue
clos)))
         Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> TcType -> ForeignHValue -> Maybe Name -> Term
Suspension (StgInfoTable -> ClosureType
tipe (GenClosure ForeignHValue -> StgInfoTable
forall b. GenClosure b -> StgInfoTable
info GenClosure ForeignHValue
clos)) TcType
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 TcType
ty Either String DataCon
dc ForeignHValue
hval [Term]
tt
     | Just (TyCon
tc, [TcType]
args) <- HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty
     , TyCon -> Bool
isNewTyCon TyCon
tc
     , TcType
wrapped_type    <- TyCon -> [TcType] -> TcType
newTyConInstRhs TyCon
tc [TcType]
args
     , Just DataCon
dc'        <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc
     , Term
t'              <- TermProcessor Term Term
worker TcType
wrapped_type Either String DataCon
dc ForeignHValue
hval [Term]
tt
     = TcType -> Either String DataCon -> Term -> Term
NewtypeWrap TcType
ty (DataCon -> Either String DataCon
forall a b. b -> Either a b
Right DataCon
dc') Term
t'
     | Bool
otherwise = TermProcessor Term Term
Term TcType
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 -> TcType -> ForeignHValue -> Maybe Name -> Term
fSuspension = ClosureType -> TcType -> ForeignHValue -> Maybe Name -> Term
worker} where
      worker :: ClosureType -> TcType -> ForeignHValue -> Maybe Name -> Term
worker ClosureType
ct TcType
ty ForeignHValue
hval Maybe Name
n | TcType -> Bool
isFunTy TcType
ty = ClosureType -> TcType -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct (TcType -> TcType
dictsView TcType
ty) ForeignHValue
hval Maybe Name
n
                          | Bool
otherwise  = ClosureType -> TcType -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct TcType
ty ForeignHValue
hval Maybe Name
n

extractSubTerms :: (Type -> ForeignHValue -> TcM Term)
                -> GenClosure ForeignHValue -> [Type] -> TcM [Term]
extractSubTerms :: (TcType -> ForeignHValue -> TR Term)
-> GenClosure ForeignHValue
-> [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) [Term]
extractSubTerms TcType -> 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])
-> ([TcType] -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term]))
-> [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) [Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Int
-> [TcType]
-> 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
-> [TcType]
-> 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 (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, [])
    go Int
ptr_i Int
arr_i (TcType
ty:[TcType]
tys)
      | Just (TyCon
tc, [TcType]
elem_tys) <- HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
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
-> [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go Int
ptr_i Int
arr_i ([TcType] -> [TcType]
dropRuntimeRepArgs [TcType]
elem_tys)
           (Int
ptr_i, Int
arr_i, [Term]
terms1) <- Int
-> Int
-> [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go Int
ptr_i Int
arr_i [TcType]
tys
           (Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, TcType -> [Term] -> Term
unboxedTupleTerm TcType
ty [Term]
terms0 Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
terms1)
      | Bool
otherwise
      = case HasDebugCallStack => TcType -> [PrimRep]
TcType -> [PrimRep]
typePrimRepArgs TcType
ty of
          [PrimRep
rep_ty] ->  do
            (Int
ptr_i, Int
arr_i, Term
term0)  <- Int
-> Int
-> TcType
-> PrimRep
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
go_rep Int
ptr_i Int
arr_i TcType
ty PrimRep
rep_ty
            (Int
ptr_i, Int
arr_i, [Term]
terms1) <- Int
-> Int
-> [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go Int
ptr_i Int
arr_i [TcType]
tys
            (Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, Term
term0 Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
terms1)
          [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
-> [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go Int
ptr_i Int
arr_i [TcType]
tys
           (Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, TcType -> [Term] -> Term
unboxedTupleTerm TcType
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 (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
      TcType
tv <- TcType -> TR TcType
newVar TcType
liftedTypeKind
      (Int
ptr_i, Int
arr_i, Term
term0)  <- Int
-> Int
-> TcType
-> PrimRep
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
go_rep Int
ptr_i Int
arr_i TcType
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 (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
-> TcType
-> PrimRep
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
go_rep Int
ptr_i Int
arr_i TcType
ty PrimRep
rep
      | PrimRep -> Bool
isGcPtrRep PrimRep
rep = do
          Term
t <- TcType -> ForeignHValue -> TR Term
recurse TcType
ty (ForeignHValue -> TR Term) -> ForeignHValue -> TR Term
forall a b. (a -> b) -> a -> b
$ (GenClosure ForeignHValue -> [ForeignHValue]
forall b. GenClosure b -> [b]
ptrArgs GenClosure ForeignHValue
clos)[ForeignHValue] -> Int -> ForeignHValue
forall a. [a] -> Int -> a
!!Int
ptr_i
          (Int, Int, Term) -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 ASSERT( r == 0 )
                        [ [Word]
array[Word] -> Int -> Word
forall a. [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 (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
new_arr_i, TcType -> [Word] -> Term
Prim TcType
ty [Word]
ws)

    unboxedTupleTerm :: TcType -> [Term] -> Term
unboxedTupleTerm TcType
ty [Term]
terms
      = TermProcessor Term Term
Term TcType
ty (DataCon -> Either String DataCon
forall a b. b -> Either a b
Right (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([Term] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term]
terms)))
                (String -> ForeignHValue
forall a. HasCallStack => String -> a
error 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. [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 -> TcType -> ForeignHValue -> IO (Maybe TcType)
cvReconstructType HscEnv
hsc_env Int
max_depth TcType
old_ty ForeignHValue
hval = HscEnv -> TR TcType -> IO (Maybe TcType)
forall a. HscEnv -> TR a -> IO (Maybe a)
runTR_maybe HscEnv
hsc_env (TR TcType -> IO (Maybe TcType)) -> TR TcType -> IO (Maybe TcType)
forall a b. (a -> b) -> a -> b
$ do
   SDoc -> TR ()
traceTR (String -> SDoc
text String
"RTTI started with initial type " SDoc -> SDoc -> SDoc
<> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
old_ty)
   let sigma_old_ty :: QuantifiedType
sigma_old_ty@([TyVar]
old_tvs, TcType
_) = TcType -> QuantifiedType
quantifyType TcType
old_ty
   TcType
new_ty <-
       if [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
old_tvs
        then TcType -> TR TcType
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
old_ty
        else do
          (TcType
old_ty', RttiInstantiation
rev_subst) <- QuantifiedType -> TR (TcType, RttiInstantiation)
instScheme QuantifiedType
sigma_old_ty
          TcType
my_ty <- TR TcType
newOpenVar
          Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (QuantifiedType -> Bool
check1 QuantifiedType
sigma_old_ty) (SDoc -> TR ()
traceTR (String -> SDoc
text String
"check1 passed") TR () -> TR () -> TR ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                      TcType -> TcType -> TR ()
addConstraint TcType
my_ty TcType
old_ty')
          IOEnv (Env TcGblEnv TcLclEnv) Bool
-> ((TcType, ForeignHValue)
    -> IOEnv (Env TcGblEnv TcLclEnv) [(TcType, ForeignHValue)])
-> Seq (TcType, ForeignHValue)
-> Int
-> TR ()
forall {a} {t}.
(Eq a, Num a, Enum a) =>
IOEnv (Env TcGblEnv TcLclEnv) Bool
-> (t -> IOEnv (Env TcGblEnv TcLclEnv) [t]) -> Seq t -> a -> TR ()
search (TcType -> Bool
isMonomorphic (TcType -> Bool) -> TR TcType -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TcType -> TR TcType
zonkTcType TcType
my_ty)
                 (\(TcType
ty,ForeignHValue
a) -> TcType
-> ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) [(TcType, ForeignHValue)]
go TcType
ty ForeignHValue
a)
                 ((TcType, ForeignHValue) -> Seq (TcType, ForeignHValue)
forall a. a -> Seq a
Seq.singleton (TcType
my_ty, ForeignHValue
hval))
                 Int
max_depth
          TcType
new_ty <- TcType -> TR TcType
zonkTcType TcType
my_ty
          if TcType -> Bool
isMonomorphic TcType
new_ty Bool -> Bool -> Bool
|| QuantifiedType -> QuantifiedType -> Bool
check2 (TcType -> QuantifiedType
quantifyType TcType
new_ty) QuantifiedType
sigma_old_ty
            then do
                 SDoc -> TR ()
traceTR (String -> SDoc
text String
"check2 passed" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
old_ty SDoc -> SDoc -> SDoc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
new_ty)
                 TcType -> TcType -> TR ()
addConstraint TcType
my_ty TcType
old_ty'
                 RttiInstantiation -> TR ()
applyRevSubst RttiInstantiation
rev_subst
                 TcType -> TR TcType
zonkRttiType TcType
new_ty
            else SDoc -> TR ()
traceTR (String -> SDoc
text String
"check2 failed" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
new_ty)) TR () -> TR TcType -> TR TcType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                 TcType -> TR TcType
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
old_ty
   SDoc -> TR ()
traceTR (String -> SDoc
text String
"RTTI completed. Type obtained:" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
new_ty)
   TcType -> TR TcType
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
new_ty
    where
--  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
  search :: IOEnv (Env TcGblEnv TcLclEnv) Bool
-> (t -> IOEnv (Env TcGblEnv TcLclEnv) [t]) -> Seq t -> a -> TR ()
search IOEnv (Env TcGblEnv TcLclEnv) Bool
_ t -> IOEnv (Env TcGblEnv TcLclEnv) [t]
_ Seq t
_ a
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 t -> IOEnv (Env TcGblEnv TcLclEnv) [t]
expand Seq t
l a
d =
    case Seq t -> ViewL t
forall a. Seq a -> ViewL a
viewl Seq t
l of
      ViewL t
EmptyL  -> () -> TR ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      t
x :< Seq t
xx -> IOEnv (Env TcGblEnv TcLclEnv) Bool -> TR () -> TR ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM IOEnv (Env TcGblEnv TcLclEnv) Bool
stop (TR () -> TR ()) -> TR () -> TR ()
forall a b. (a -> b) -> a -> b
$ do
                  [t]
new <- t -> IOEnv (Env TcGblEnv TcLclEnv) [t]
expand t
x
                  IOEnv (Env TcGblEnv TcLclEnv) Bool
-> (t -> IOEnv (Env TcGblEnv TcLclEnv) [t]) -> Seq t -> a -> TR ()
search IOEnv (Env TcGblEnv TcLclEnv) Bool
stop t -> IOEnv (Env TcGblEnv TcLclEnv) [t]
expand (Seq t
xx Seq t -> Seq t -> Seq t
forall a. Monoid a => a -> a -> a
`mappend` [t] -> Seq t
forall a. [a] -> Seq a
Seq.fromList [t]
new) (a -> TR ()) -> a -> TR ()
forall a b. (a -> b) -> a -> b
$! (a -> a
forall a. Enum a => a -> a
pred a
d)

   -- returns unification tasks,since we are going to want a breadth-first search
  go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)]
  go :: TcType
-> ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) [(TcType, ForeignHValue)]
go TcType
my_ty ForeignHValue
a = do
    SDoc -> TR ()
traceTR (String -> SDoc
text String
"go" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
my_ty)
    GenClosure ForeignHValue
clos <- IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
forall a. IO a -> TR a
trIO (IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue))
-> IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
forall a b. (a -> b) -> a -> b
$ HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
GHCi.getClosure HscEnv
hsc_env ForeignHValue
a
    case GenClosure ForeignHValue
clos of
      BlackholeClosure{indirectee :: forall b. GenClosure b -> b
indirectee=ForeignHValue
ind} -> TcType
-> ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) [(TcType, ForeignHValue)]
go TcType
my_ty ForeignHValue
ind
      IndClosure{indirectee :: forall b. GenClosure b -> b
indirectee=ForeignHValue
ind} -> TcType
-> ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) [(TcType, ForeignHValue)]
go TcType
my_ty ForeignHValue
ind
      MutVarClosure{var :: forall b. GenClosure b -> b
var=ForeignHValue
contents} -> do
         TcType
tv'   <- TcType -> TR TcType
newVar TcType
liftedTypeKind
         TcType
world <- TcType -> TR TcType
newVar TcType
liftedTypeKind
         TcType -> TcType -> TR ()
addConstraint TcType
my_ty (TyCon -> [TcType] -> TcType
mkTyConApp TyCon
mutVarPrimTyCon [TcType
world,TcType
tv'])
         [(TcType, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(TcType, ForeignHValue)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(TcType
tv', ForeignHValue
contents)]
      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 (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
_) <- TcRn DataCon -> TcRn (Maybe DataCon, Messages)
forall a. TcRn a -> TcRn (Maybe a, Messages)
tryTc (Name -> TcRn DataCon
tcLookupDataCon Name
dcname)
        case Maybe DataCon
mb_dc of
          Maybe DataCon
Nothing-> do
            [ForeignHValue]
-> (ForeignHValue
    -> IOEnv (Env TcGblEnv TcLclEnv) (TcType, ForeignHValue))
-> IOEnv (Env TcGblEnv TcLclEnv) [(TcType, 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) (TcType, ForeignHValue))
 -> IOEnv (Env TcGblEnv TcLclEnv) [(TcType, ForeignHValue)])
-> (ForeignHValue
    -> IOEnv (Env TcGblEnv TcLclEnv) (TcType, ForeignHValue))
-> IOEnv (Env TcGblEnv TcLclEnv) [(TcType, ForeignHValue)]
forall a b. (a -> b) -> a -> b
$ \ForeignHValue
x -> do
              TcType
tv <- TcType -> TR TcType
newVar TcType
liftedTypeKind
              (TcType, ForeignHValue)
-> IOEnv (Env TcGblEnv TcLclEnv) (TcType, ForeignHValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcType
tv, ForeignHValue
x)

          Just DataCon
dc -> do
            [TcType]
arg_tys <- DataCon -> TcType -> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
getDataConArgTys DataCon
dc TcType
my_ty
            (Int
_, [(Int, TcType)]
itys) <- Int -> [TcType] -> TR (Int, [(Int, TcType)])
findPtrTyss Int
0 [TcType]
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
<+> [TcType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcType]
arg_tys)
            [(TcType, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(TcType, ForeignHValue)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TcType, ForeignHValue)]
 -> IOEnv (Env TcGblEnv TcLclEnv) [(TcType, ForeignHValue)])
-> [(TcType, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(TcType, ForeignHValue)]
forall a b. (a -> b) -> a -> b
$ ((Int, TcType) -> ForeignHValue -> (TcType, ForeignHValue))
-> [(Int, TcType)] -> [ForeignHValue] -> [(TcType, ForeignHValue)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Int
_,TcType
ty) ForeignHValue
x -> (TcType
ty, ForeignHValue
x)) [(Int, TcType)]
itys [ForeignHValue]
pArgs
      GenClosure ForeignHValue
_ -> [(TcType, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(TcType, ForeignHValue)]
forall (m :: * -> *) a. Monad m => a -> m a
return []

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

  | Bool
otherwise
  = case HasDebugCallStack => TcType -> [PrimRep]
TcType -> [PrimRep]
typePrimRep TcType
ty of
      [PrimRep
rep] | PrimRep -> Bool
isGcPtrRep PrimRep
rep -> (Int, [(Int, TcType)]) -> TR (Int, [(Int, TcType)])
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, TcType
ty)])
            | Bool
otherwise      -> (Int, [(Int, TcType)]) -> TR (Int, [(Int, TcType)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i,     [])
      [PrimRep]
prim_reps              ->
        ((Int, [(Int, TcType)]) -> PrimRep -> TR (Int, [(Int, TcType)]))
-> (Int, [(Int, TcType)]) -> [PrimRep] -> TR (Int, [(Int, TcType)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\(Int
i, [(Int, TcType)]
extras) PrimRep
prim_rep ->
                if PrimRep -> Bool
isGcPtrRep PrimRep
prim_rep
                  then TcType -> TR TcType
newVar TcType
liftedTypeKind TR TcType
-> (TcType -> TR (Int, [(Int, TcType)]))
-> TR (Int, [(Int, TcType)])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TcType
tv -> (Int, [(Int, TcType)]) -> TR (Int, [(Int, TcType)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, [(Int, TcType)]
extras [(Int, TcType)] -> [(Int, TcType)] -> [(Int, TcType)]
forall a. [a] -> [a] -> [a]
++ [(Int
i, TcType
tv)])
                  else (Int, [(Int, TcType)]) -> TR (Int, [(Int, TcType)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, [(Int, TcType)]
extras))
              (Int
i, []) [PrimRep]
prim_reps

findPtrTyss :: Int
            -> [Type]
            -> TR (Int, [(Int, Type)])
findPtrTyss :: Int -> [TcType] -> TR (Int, [(Int, TcType)])
findPtrTyss Int
i [TcType]
tys = ((Int, [(Int, TcType)]) -> TcType -> TR (Int, [(Int, TcType)]))
-> (Int, [(Int, TcType)]) -> [TcType] -> TR (Int, [(Int, TcType)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Int, [(Int, TcType)]) -> TcType -> TR (Int, [(Int, TcType)])
step (Int
i, []) [TcType]
tys
  where step :: (Int, [(Int, TcType)]) -> TcType -> TR (Int, [(Int, TcType)])
step (Int
i, [(Int, TcType)]
discovered) TcType
elem_ty = do
          (Int
i, [(Int, TcType)]
extras) <- Int -> TcType -> TR (Int, [(Int, TcType)])
findPtrTys Int
i TcType
elem_ty
          (Int, [(Int, TcType)]) -> TR (Int, [(Int, TcType)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, [(Int, TcType)]
discovered [(Int, TcType)] -> [(Int, TcType)] -> [(Int, TcType)]
forall a. [a] -> [a] -> [a]
++ [(Int, TcType)]
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 -> TcType -> TcType -> Maybe TCvSubst
improveRTTIType HscEnv
_ TcType
base_ty TcType
new_ty = TcType -> TcType -> Maybe TCvSubst
U.tcUnifyTyKi TcType
base_ty TcType
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
--
-- I believe that con_app_ty should not have any enclosing foralls
getDataConArgTys :: DataCon -> TcType -> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
getDataConArgTys DataCon
dc TcType
con_app_ty
  = do { let rep_con_app_ty :: TcType
rep_con_app_ty = TcType -> TcType
unwrapType TcType
con_app_ty
       ; SDoc -> TR ()
traceTR (String -> SDoc
text String
"getDataConArgTys 1" SDoc -> SDoc -> SDoc
<+> (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
con_app_ty SDoc -> SDoc -> SDoc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
rep_con_app_ty
                   SDoc -> SDoc -> SDoc
$$ Maybe (TyCon, [TcType]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
rep_con_app_ty)))
       ; ASSERT( all isTyVar ex_tvs ) 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)
       ; TcType -> TcType -> TR ()
addConstraint TcType
rep_con_app_ty (HasCallStack => TCvSubst -> TcType -> TcType
TCvSubst -> TcType -> TcType
substTy TCvSubst
subst (DataCon -> TcType
dataConOrigResTy DataCon
dc))
              -- See Note [Constructor arg types]
       ; let con_arg_tys :: [TcType]
con_arg_tys = HasCallStack => TCvSubst -> [TcType] -> [TcType]
TCvSubst -> [TcType] -> [TcType]
substTys TCvSubst
subst ((Scaled TcType -> TcType) -> [Scaled TcType] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing ([Scaled TcType] -> [TcType]) -> [Scaled TcType] -> [TcType]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Scaled TcType]
dataConRepArgTys DataCon
dc)
       ; SDoc -> TR ()
traceTR (String -> SDoc
text String
"getDataConArgTys 2" SDoc -> SDoc -> SDoc
<+> (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
rep_con_app_ty SDoc -> SDoc -> SDoc
$$ [TcType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcType]
con_arg_tys SDoc -> SDoc -> SDoc
$$ TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst))
       ; [TcType] -> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
forall (m :: * -> *) a. Monad m => a -> m a
return [TcType]
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 :: QuantifiedType -> Bool
check1 :: QuantifiedType -> Bool
check1 ([TyVar]
tvs, TcType
_) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TcType -> Bool
isHigherKind ((TyVar -> TcType) -> [TyVar] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> TcType
tyVarKind [TyVar]
tvs)
 where
   isHigherKind :: TcType -> Bool
isHigherKind = Bool -> Bool
not (Bool -> Bool) -> (TcType -> Bool) -> TcType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyCoBinder] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyCoBinder] -> Bool)
-> (TcType -> [TyCoBinder]) -> TcType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TyCoBinder], TcType) -> [TyCoBinder]
forall a b. (a, b) -> a
fst (([TyCoBinder], TcType) -> [TyCoBinder])
-> (TcType -> ([TyCoBinder], TcType)) -> TcType -> [TyCoBinder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcType -> ([TyCoBinder], TcType)
splitPiTys

check2 :: QuantifiedType -> QuantifiedType -> Bool
check2 :: QuantifiedType -> QuantifiedType -> Bool
check2 ([TyVar]
_, TcType
rtti_ty) ([TyVar]
_, TcType
old_ty)
  | Just (TyCon
_, [TcType]
rttis) <- HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
rtti_ty
  = case () of
      ()
_ | Just (TyCon
_,[TcType]
olds) <- HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
old_ty
        -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (QuantifiedType -> QuantifiedType -> Bool)
-> [QuantifiedType] -> [QuantifiedType] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith QuantifiedType -> QuantifiedType -> Bool
check2 ((TcType -> QuantifiedType) -> [TcType] -> [QuantifiedType]
forall a b. (a -> b) -> [a] -> [b]
map TcType -> QuantifiedType
quantifyType [TcType]
rttis) ((TcType -> QuantifiedType) -> [TcType] -> [QuantifiedType]
forall a b. (a -> b) -> [a] -> [b]
map TcType -> QuantifiedType
quantifyType [TcType]
olds)
      ()
_ | Just (TcType, TcType)
_ <- TcType -> Maybe (TcType, TcType)
splitAppTy_maybe TcType
old_ty
        -> TcType -> Bool
isMonomorphicOnNonPhantomArgs TcType
rtti_ty
      ()
_ -> Bool
True
  | Bool
otherwise = Bool
True

-- 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 :: TcType -> TcType -> TR (TcType, TcType)
congruenceNewtypes TcType
lhs TcType
rhs = TcType -> TcType -> TR TcType
go TcType
lhs TcType
rhs TR TcType -> (TcType -> TR (TcType, TcType)) -> TR (TcType, TcType)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TcType
rhs' -> (TcType, TcType) -> TR (TcType, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcType
lhs,TcType
rhs')
 where
   go :: TcType -> TcType -> TR TcType
go TcType
l TcType
r
 -- TyVar lhs inductive case
    | Just TyVar
tv <- TcType -> Maybe TyVar
getTyVar_maybe TcType
l
    , TyVar -> Bool
isTcTyVar TyVar
tv
    , TyVar -> Bool
isMetaTyVar TyVar
tv
    = TR TcType -> TR TcType -> TR TcType
forall a. TR a -> TR a -> TR a
recoverTR (TcType -> TR TcType
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
r) (TR TcType -> TR TcType) -> TR TcType -> TR TcType
forall a b. (a -> b) -> a -> b
$ do
         Indirect TcType
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, TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty_v]
         TcType -> TcType -> TR TcType
go TcType
ty_v TcType
r
-- FunTy inductive case
    | Just (TcType
w1,TcType
l1,TcType
l2) <- TcType -> Maybe (TcType, TcType, TcType)
splitFunTy_maybe TcType
l
    , Just (TcType
w2,TcType
r1,TcType
r2) <- TcType -> Maybe (TcType, TcType, TcType)
splitFunTy_maybe TcType
r
    , TcType
w1 TcType -> TcType -> Bool
`eqType` TcType
w2
    = do TcType
r2' <- TcType -> TcType -> TR TcType
go TcType
l2 TcType
r2
         TcType
r1' <- TcType -> TcType -> TR TcType
go TcType
l1 TcType
r1
         TcType -> TR TcType
forall (m :: * -> *) a. Monad m => a -> m a
return (TcType -> TcType -> TcType -> TcType
mkVisFunTy TcType
w1 TcType
r1' TcType
r2')
-- TyconApp Inductive case; this is the interesting bit.
    | Just (TyCon
tycon_l, [TcType]
_) <- HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
lhs
    , Just (TyCon
tycon_r, [TcType]
_) <- HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
rhs
    , TyCon
tycon_l TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
/= TyCon
tycon_r
    = TyCon -> TcType -> TR TcType
upgrade TyCon
tycon_l TcType
r

    | Bool
otherwise = TcType -> TR TcType
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
r

    where upgrade :: TyCon -> Type -> TR Type
          upgrade :: TyCon -> TcType -> TR TcType
upgrade TyCon
new_tycon TcType
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
<> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty)
              TcType -> TR TcType
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
ty
            | Bool
otherwise = do
               SDoc -> TR ()
traceTR (String -> SDoc
text String
"(Upgrade) upgraded " SDoc -> SDoc -> SDoc
<> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
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' :: TcType
ty' = TyCon -> [TcType] -> TcType
mkTyConApp TyCon
new_tycon ([TyVar] -> [TcType]
mkTyVarTys [TyVar]
vars)
                   rep_ty :: TcType
rep_ty = TcType -> TcType
unwrapType TcType
ty'
               TcCoercionN
_ <- TcM TcCoercionN -> TcM TcCoercionN
forall a. TcM a -> TcM a
liftTcM (Maybe (HsExpr GhcRn) -> TcType -> TcType -> TcM TcCoercionN
unifyType Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing TcType
ty TcType
rep_ty)
        -- assumes that reptype doesn't ^^^^ touch tyconApp args
               TcType -> TR TcType
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
ty'


zonkTerm :: Term -> TcM Term
zonkTerm :: Term -> TR Term
zonkTerm = TermFoldM (IOEnv (Env TcGblEnv TcLclEnv)) Term -> Term -> TR Term
forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
foldTermM (TermFoldM :: forall (m :: * -> *) a.
TermProcessor a (m a)
-> (TcType -> [Word] -> m a)
-> (ClosureType -> TcType -> ForeignHValue -> Maybe Name -> m a)
-> (TcType -> Either String DataCon -> a -> m a)
-> (TcType -> a -> m a)
-> TermFoldM m a
TermFoldM
             { fTermM :: TermProcessor Term (TR Term)
fTermM = \TcType
ty Either String DataCon
dc ForeignHValue
v [Term]
tt -> TcType -> TR TcType
zonkRttiType TcType
ty    TR TcType -> (TcType -> TR Term) -> TR Term
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TcType
ty' ->
                                       Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term TcType
ty' Either String DataCon
dc ForeignHValue
v [Term]
tt)
             , fSuspensionM :: ClosureType -> TcType -> ForeignHValue -> Maybe Name -> TR Term
fSuspensionM  = \ClosureType
ct TcType
ty ForeignHValue
v Maybe Name
b -> TcType -> TR TcType
zonkRttiType TcType
ty TR TcType -> (TcType -> TR Term) -> TR Term
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TcType
ty ->
                                             Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> TcType -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct TcType
ty ForeignHValue
v Maybe Name
b)
             , fNewtypeWrapM :: TcType -> Either String DataCon -> Term -> TR Term
fNewtypeWrapM = \TcType
ty Either String DataCon
dc Term
t -> TcType -> TR TcType
zonkRttiType TcType
ty TR TcType -> (TcType -> TR Term) -> TR Term
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TcType
ty' ->
                                           Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return(Term -> TR Term) -> Term -> TR Term
forall a b. (a -> b) -> a -> b
$ TcType -> Either String DataCon -> Term -> Term
NewtypeWrap TcType
ty' Either String DataCon
dc Term
t
             , fRefWrapM :: TcType -> Term -> TR Term
fRefWrapM     = \TcType
ty Term
t -> (TcType -> Term -> Term)
-> IOEnv (Env TcGblEnv TcLclEnv) (TcType -> Term -> Term)
forall (m :: * -> *) a. Monad m => a -> m a
return TcType -> Term -> Term
RefWrap  IOEnv (Env TcGblEnv TcLclEnv) (TcType -> Term -> Term)
-> TR TcType -> IOEnv (Env TcGblEnv TcLclEnv) (Term -> Term)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
                                        TcType -> TR TcType
zonkRttiType TcType
ty IOEnv (Env TcGblEnv TcLclEnv) (Term -> Term) -> TR Term -> TR Term
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return Term
t
             , fPrimM :: TcType -> [Word] -> TR Term
fPrimM        = (Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return(Term -> TR Term) -> ([Word] -> Term) -> [Word] -> TR Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([Word] -> Term) -> [Word] -> TR Term)
-> (TcType -> [Word] -> Term) -> TcType -> [Word] -> TR Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcType -> [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 :: TcType -> TR TcType
zonkRttiType TcType
ty= do { ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
RuntimeUnkFlexi
                    ; ZonkEnv -> TcType -> TR TcType
zonkTcTypeToTypeX ZonkEnv
ze TcType
ty }

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


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

-- Use only for RTTI types
isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
isMonomorphicOnNonPhantomArgs :: TcType -> Bool
isMonomorphicOnNonPhantomArgs TcType
ty
  | Just (TyCon
tc, [TcType]
all_args) <- HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe (TcType -> TcType
unwrapType TcType
ty)
  , [TyVar]
phantom_vars  <- TyCon -> [TyVar]
tyConPhantomTyVars TyCon
tc
  , [TcType]
concrete_args <- [ TcType
arg | (TyVar
tyv,TcType
arg) <- TyCon -> [TyVar]
tyConTyVars TyCon
tc [TyVar] -> [TcType] -> [(TyVar, TcType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcType]
all_args
                           , TyVar
tyv TyVar -> [TyVar] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [TyVar]
phantom_vars]
  = (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TcType -> Bool
isMonomorphicOnNonPhantomArgs [TcType]
concrete_args
  | Just (TcType
_, TcType
ty1, TcType
ty2) <- TcType -> Maybe (TcType, TcType, TcType)
splitFunTy_maybe TcType
ty
  = (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TcType -> Bool
isMonomorphicOnNonPhantomArgs [TcType
ty1,TcType
ty2]
  | Bool
otherwise = TcType -> Bool
isMonomorphic TcType
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
   -- The returned Type should have no top-level foralls (I believe)

quantifyType :: Type -> QuantifiedType
-- Generalize the type: find all free and forall'd tyvars
-- and return them, together with the type inside, which
-- should not be a forall type.
--
-- Thus (quantifyType (forall a. a->[b]))
-- returns ([a,b], a -> [b])

quantifyType :: TcType -> QuantifiedType
quantifyType TcType
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
$
                    TcType -> [TyVar]
tyCoVarsOfTypeWellScoped TcType
rho
                  , TcType
rho)
  where
    ([TyVar]
_tvs, TcType
rho) = TcType -> QuantifiedType
tcSplitForAllTys TcType
ty