{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.Types.Basic ( Boxity(..), neverInlinePragma )
import GHC.Types.SourceText ( SourceText(..) )
import GHC.Iface.Env( newGlobalBinder )
import GHC.Core.TyCo.Rep( Type(..), TyLit(..) )
import GHC.Tc.Utils.Env
import GHC.Tc.Types.Evidence ( mkWpTyApps )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import GHC.Types.TyThing ( lookupId )
import GHC.Builtin.Names
import GHC.Builtin.Types.Prim ( primTyCons )
import GHC.Builtin.Types
( tupleTyCon, sumTyCon, runtimeRepTyCon
, vecCountTyCon, vecElemTyCon
, nilDataCon, consDataCon )
import GHC.Types.Name
import GHC.Types.Id
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Unit.Module
import GHC.Hs
import GHC.Driver.Session
import GHC.Data.Bag
import GHC.Types.Var ( VarBndr(..) )
import GHC.Core.Map
import GHC.Settings.Constants
import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString ( FastString, mkFastString, fsLit )
import Control.Monad.Trans.State
import Control.Monad.Trans.Class (lift)
import Data.Maybe ( isJust )
import Data.Word( Word64 )
mkTypeableBinds :: TcM TcGblEnv
mkTypeableBinds :: TcM TcGblEnv
mkTypeableBinds
= do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoTypeableBinds DynFlags
dflags then TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv else do
{
; TcGblEnv
tcg_env <- TcM TcGblEnv
mkModIdBindings
; (TcGblEnv
tcg_env, [TypeRepTodo]
prim_todos) <- TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos
; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
do { Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; let tycons :: [TyCon]
tycons = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
needs_typeable_binds (TcGblEnv -> [TyCon]
tcg_tcs TcGblEnv
tcg_env)
mod_id :: Id
mod_id = case TcGblEnv -> Maybe Id
tcg_tr_module TcGblEnv
tcg_env of
Just Id
mod_id -> Id
mod_id
Maybe Id
Nothing -> String -> SDoc -> Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcMkTypeableBinds" ([TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
tycons)
; String -> SDoc -> TcRn ()
traceTc String
"mkTypeableBinds" ([TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
tycons)
; TypeRepTodo
this_mod_todos <- Module -> Id -> [TyCon] -> TcM TypeRepTodo
todoForTyCons Module
mod Id
mod_id [TyCon]
tycons
; [TypeRepTodo] -> TcM TcGblEnv
mkTypeRepTodoBinds (TypeRepTodo
this_mod_todos TypeRepTodo -> [TypeRepTodo] -> [TypeRepTodo]
forall a. a -> [a] -> [a]
: [TypeRepTodo]
prim_todos)
} } }
where
needs_typeable_binds :: TyCon -> Bool
needs_typeable_binds TyCon
tc
| TyCon
tc TyCon -> [TyCon] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyCon
runtimeRepTyCon, TyCon
vecCountTyCon, TyCon
vecElemTyCon]
= Bool
False
| Bool
otherwise =
TyCon -> Bool
isAlgTyCon TyCon
tc
Bool -> Bool -> Bool
|| TyCon -> Bool
isDataFamilyTyCon TyCon
tc
Bool -> Bool -> Bool
|| TyCon -> Bool
isClassTyCon TyCon
tc
mkModIdBindings :: TcM TcGblEnv
mkModIdBindings :: TcM TcGblEnv
mkModIdBindings
= do { Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; Name
mod_nm <- Module -> OccName -> SrcSpan -> TcRnIf TcGblEnv TcLclEnv Name
forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod (String -> OccName
mkVarOcc String
"$trModule") SrcSpan
loc
; TyCon
trModuleTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
trModuleTyConName
; let mod_id :: Id
mod_id = Name -> Type -> Id
mkExportedVanillaId Name
mod_nm (TyCon -> [Type] -> Type
mkTyConApp TyCon
trModuleTyCon [])
; Located (HsBindLR GhcTc GhcTc)
mod_bind <- IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Id
IdP GhcTc
mod_id (Located (HsExpr GhcTc) -> Located (HsBindLR GhcTc GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (HsExpr GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (HsBindLR GhcTc GhcTc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> TcM (LHsExpr GhcTc)
mkModIdRHS Module
mod
; TcGblEnv
tcg_env <- [Id] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id
mod_id] TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env { tcg_tr_module :: Maybe Id
tcg_tr_module = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
mod_id }
TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
`addTypecheckedBinds` [Located (HsBindLR GhcTc GhcTc)
-> Bag (Located (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag Located (HsBindLR GhcTc GhcTc)
mod_bind]) }
mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)
mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)
mkModIdRHS Module
mod
= do { DataCon
trModuleDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trModuleDataConName
; FastString -> Located (HsExpr GhcTc)
trNameLit <- IOEnv
(Env TcGblEnv TcLclEnv) (FastString -> Located (HsExpr GhcTc))
TcM (FastString -> LHsExpr GhcTc)
mkTrNameLit
; Located (HsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (HsExpr GhcTc)))
-> Located (HsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
trModuleDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString -> Located (HsExpr GhcTc)
trNameLit (Unit -> FastString
forall u. IsUnitId u => u -> FastString
unitFS (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod))
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString -> Located (HsExpr GhcTc)
trNameLit (ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod))
}
data TypeableTyCon
= TypeableTyCon
{ TypeableTyCon -> TyCon
tycon :: !TyCon
, TypeableTyCon -> Id
tycon_rep_id :: !Id
}
data TypeRepTodo
= TypeRepTodo
{ TypeRepTodo -> LHsExpr GhcTc
mod_rep_expr :: LHsExpr GhcTc
, TypeRepTodo -> Fingerprint
pkg_fingerprint :: !Fingerprint
, TypeRepTodo -> Fingerprint
mod_fingerprint :: !Fingerprint
, TypeRepTodo -> [TypeableTyCon]
todo_tycons :: [TypeableTyCon]
}
| ExportedKindRepsTodo [(Kind, Id)]
todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo
todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo
todoForTyCons Module
mod Id
mod_id [TyCon]
tycons = do
Type
trTyConTy <- TyCon -> Type
mkTyConTy (TyCon -> Type) -> TcM TyCon -> IOEnv (Env TcGblEnv TcLclEnv) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM TyCon
tcLookupTyCon Name
trTyConTyConName
let mk_rep_id :: TyConRepName -> Id
mk_rep_id :: Name -> Id
mk_rep_id Name
rep_name = Name -> Type -> Id
mkExportedVanillaId Name
rep_name Type
trTyConTy
let typeable_tycons :: [TypeableTyCon]
typeable_tycons :: [TypeableTyCon]
typeable_tycons =
[ TypeableTyCon :: TyCon -> Id -> TypeableTyCon
TypeableTyCon { tycon :: TyCon
tycon = TyCon
tc''
, tycon_rep_id :: Id
tycon_rep_id = Name -> Id
mk_rep_id Name
rep_name
}
| TyCon
tc <- [TyCon]
tycons
, TyCon
tc' <- TyCon
tc TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: TyCon -> [TyCon]
tyConATs TyCon
tc
, let promoted :: [TyCon]
promoted = (DataCon -> TyCon) -> [DataCon] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> TyCon
promoteDataCon (TyCon -> [DataCon]
tyConDataCons TyCon
tc')
, TyCon
tc'' <- TyCon
tc' TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: [TyCon]
promoted
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TyCon -> Bool
isFamInstTyCon TyCon
tc''
, Just Name
rep_name <- Maybe Name -> [Maybe Name]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Name -> [Maybe Name]) -> Maybe Name -> [Maybe Name]
forall a b. (a -> b) -> a -> b
$ TyCon -> Maybe Name
tyConRepName_maybe TyCon
tc''
, TyCon -> Bool
tyConIsTypeable TyCon
tc''
]
TypeRepTodo -> TcM TypeRepTodo
forall (m :: * -> *) a. Monad m => a -> m a
return TypeRepTodo :: LHsExpr GhcTc
-> Fingerprint -> Fingerprint -> [TypeableTyCon] -> TypeRepTodo
TypeRepTodo { mod_rep_expr :: LHsExpr GhcTc
mod_rep_expr = IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
mod_id
, pkg_fingerprint :: Fingerprint
pkg_fingerprint = Fingerprint
pkg_fpr
, mod_fingerprint :: Fingerprint
mod_fingerprint = Fingerprint
mod_fpr
, todo_tycons :: [TypeableTyCon]
todo_tycons = [TypeableTyCon]
typeable_tycons
}
where
mod_fpr :: Fingerprint
mod_fpr = String -> Fingerprint
fingerprintString (String -> Fingerprint) -> String -> Fingerprint
forall a b. (a -> b) -> a -> b
$ ModuleName -> String
moduleNameString (ModuleName -> String) -> ModuleName -> String
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod
pkg_fpr :: Fingerprint
pkg_fpr = String -> Fingerprint
fingerprintString (String -> Fingerprint) -> String -> Fingerprint
forall a b. (a -> b) -> a -> b
$ Unit -> String
forall u. IsUnitId u => u -> String
unitString (Unit -> String) -> Unit -> String
forall a b. (a -> b) -> a -> b
$ Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod
todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo
todoForExportedKindReps :: [(Type, Name)] -> TcM TypeRepTodo
todoForExportedKindReps [(Type, Name)]
kinds = do
Type
trKindRepTy <- TyCon -> Type
mkTyConTy (TyCon -> Type) -> TcM TyCon -> IOEnv (Env TcGblEnv TcLclEnv) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM TyCon
tcLookupTyCon Name
kindRepTyConName
let mkId :: (Type, Name) -> (Type, Id)
mkId (Type
k, Name
name) = (Type
k, Name -> Type -> Id
mkExportedVanillaId Name
name Type
trKindRepTy)
TypeRepTodo -> TcM TypeRepTodo
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeRepTodo -> TcM TypeRepTodo) -> TypeRepTodo -> TcM TypeRepTodo
forall a b. (a -> b) -> a -> b
$ [(Type, Id)] -> TypeRepTodo
ExportedKindRepsTodo ([(Type, Id)] -> TypeRepTodo) -> [(Type, Id)] -> TypeRepTodo
forall a b. (a -> b) -> a -> b
$ ((Type, Name) -> (Type, Id)) -> [(Type, Name)] -> [(Type, Id)]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Name) -> (Type, Id)
mkId [(Type, Name)]
kinds
mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
mkTypeRepTodoBinds [] = TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
mkTypeRepTodoBinds [TypeRepTodo]
todos
= do { TypeableStuff
stuff <- TcM TypeableStuff
collect_stuff
; let produced_bndrs :: [Id]
produced_bndrs :: [Id]
produced_bndrs = [ Id
tycon_rep_id
| todo :: TypeRepTodo
todo@(TypeRepTodo{}) <- [TypeRepTodo]
todos
, TypeableTyCon {Id
TyCon
tycon :: TyCon
tycon_rep_id :: Id
tycon_rep_id :: TypeableTyCon -> Id
tycon :: TypeableTyCon -> TyCon
..} <- TypeRepTodo -> [TypeableTyCon]
todo_tycons TypeRepTodo
todo
] [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++
[ Id
rep_id
| ExportedKindRepsTodo [(Type, Id)]
kinds <- [TypeRepTodo]
todos
, (Type
_, Id
rep_id) <- [(Type, Id)]
kinds
]
; TcGblEnv
gbl_env <- [Id] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id]
produced_bndrs TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc]
mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc]
mk_binds todo :: TypeRepTodo
todo@(TypeRepTodo {}) =
(TypeableTyCon -> KindRepM (Bag (Located (HsBindLR GhcTc GhcTc))))
-> [TypeableTyCon]
-> KindRepM [Bag (Located (HsBindLR GhcTc GhcTc))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypeableStuff
-> TypeRepTodo -> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
mkTyConRepBinds TypeableStuff
stuff TypeRepTodo
todo) (TypeRepTodo -> [TypeableTyCon]
todo_tycons TypeRepTodo
todo)
mk_binds (ExportedKindRepsTodo [(Type, Id)]
kinds) =
TypeableStuff -> [(Type, Id)] -> KindRepM ()
mkExportedKindReps TypeableStuff
stuff [(Type, Id)]
kinds KindRepM ()
-> KindRepM [Bag (Located (HsBindLR GhcTc GhcTc))]
-> KindRepM [Bag (Located (HsBindLR GhcTc GhcTc))]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Bag (Located (HsBindLR GhcTc GhcTc))]
-> KindRepM [Bag (Located (HsBindLR GhcTc GhcTc))]
forall (m :: * -> *) a. Monad m => a -> m a
return []
; (TcGblEnv
gbl_env, [[Bag (Located (HsBindLR GhcTc GhcTc))]]
binds) <- TcGblEnv
-> TcRnIf
TcGblEnv
TcLclEnv
(TcGblEnv, [[Bag (Located (HsBindLR GhcTc GhcTc))]])
-> TcRnIf
TcGblEnv
TcLclEnv
(TcGblEnv, [[Bag (Located (HsBindLR GhcTc GhcTc))]])
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
gbl_env
(TcRnIf
TcGblEnv
TcLclEnv
(TcGblEnv, [[Bag (Located (HsBindLR GhcTc GhcTc))]])
-> TcRnIf
TcGblEnv
TcLclEnv
(TcGblEnv, [[Bag (Located (HsBindLR GhcTc GhcTc))]]))
-> TcRnIf
TcGblEnv
TcLclEnv
(TcGblEnv, [[Bag (Located (HsBindLR GhcTc GhcTc))]])
-> TcRnIf
TcGblEnv
TcLclEnv
(TcGblEnv, [[Bag (Located (HsBindLR GhcTc GhcTc))]])
forall a b. (a -> b) -> a -> b
$ KindRepM [[Bag (Located (HsBindLR GhcTc GhcTc))]]
-> TcRnIf
TcGblEnv
TcLclEnv
(TcGblEnv, [[Bag (Located (HsBindLR GhcTc GhcTc))]])
forall a. KindRepM a -> TcRn (TcGblEnv, a)
runKindRepM ((TypeRepTodo -> KindRepM [Bag (Located (HsBindLR GhcTc GhcTc))])
-> [TypeRepTodo]
-> KindRepM [[Bag (Located (HsBindLR GhcTc GhcTc))]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeRepTodo -> KindRepM [Bag (Located (HsBindLR GhcTc GhcTc))]
TypeRepTodo -> KindRepM [LHsBinds GhcTc]
mk_binds [TypeRepTodo]
todos)
; TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> TcM TcGblEnv) -> TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ TcGblEnv
gbl_env TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
`addTypecheckedBinds` [[Bag (Located (HsBindLR GhcTc GhcTc))]]
-> [Bag (Located (HsBindLR GhcTc GhcTc))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Bag (Located (HsBindLR GhcTc GhcTc))]]
binds }
mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos :: TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos
= do { Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; if Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
gHC_TYPES
then do {
TyCon
trModuleTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
trModuleTyConName
; let ghc_prim_module_id :: Id
ghc_prim_module_id =
Name -> Type -> Id
mkExportedVanillaId Name
trGhcPrimModuleName
(TyCon -> Type
mkTyConTy TyCon
trModuleTyCon)
; Located (HsBindLR GhcTc GhcTc)
ghc_prim_module_bind <- IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Id
IdP GhcTc
ghc_prim_module_id
(Located (HsExpr GhcTc) -> Located (HsBindLR GhcTc GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (HsExpr GhcTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (HsBindLR GhcTc GhcTc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> TcM (LHsExpr GhcTc)
mkModIdRHS Module
gHC_PRIM
; TcGblEnv
gbl_env <- [Id] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id
ghc_prim_module_id]
TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let gbl_env' :: TcGblEnv
gbl_env' = TcGblEnv
gbl_env TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
`addTypecheckedBinds`
[Located (HsBindLR GhcTc GhcTc)
-> Bag (Located (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag Located (HsBindLR GhcTc GhcTc)
ghc_prim_module_bind]
; TypeRepTodo
todo1 <- [(Type, Name)] -> TcM TypeRepTodo
todoForExportedKindReps [(Type, Name)]
builtInKindReps
; TypeRepTodo
todo2 <- Module -> Id -> [TyCon] -> TcM TypeRepTodo
todoForTyCons Module
gHC_PRIM Id
ghc_prim_module_id
[TyCon]
ghcPrimTypeableTyCons
; (TcGblEnv, [TypeRepTodo])
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
forall (m :: * -> *) a. Monad m => a -> m a
return ( TcGblEnv
gbl_env' , [TypeRepTodo
todo1, TypeRepTodo
todo2])
}
else do TcGblEnv
gbl_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
(TcGblEnv, [TypeRepTodo])
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gbl_env, [])
}
ghcPrimTypeableTyCons :: [TyCon]
ghcPrimTypeableTyCons :: [TyCon]
ghcPrimTypeableTyCons = [[TyCon]] -> [TyCon]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ TyCon
runtimeRepTyCon, TyCon
vecCountTyCon, TyCon
vecElemTyCon ]
, (Arity -> TyCon) -> [Arity] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map (Boxity -> Arity -> TyCon
tupleTyCon Boxity
Unboxed) [Arity
0..Arity
mAX_TUPLE_SIZE]
, (Arity -> TyCon) -> [Arity] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map Arity -> TyCon
sumTyCon [Arity
2..Arity
mAX_SUM_SIZE]
, [TyCon]
primTyCons
]
data TypeableStuff
= Stuff { TypeableStuff -> Platform
platform :: Platform
, TypeableStuff -> DataCon
trTyConDataCon :: DataCon
, TypeableStuff -> FastString -> LHsExpr GhcTc
trNameLit :: FastString -> LHsExpr GhcTc
, TypeableStuff -> TyCon
kindRepTyCon :: TyCon
, TypeableStuff -> DataCon
kindRepTyConAppDataCon :: DataCon
, TypeableStuff -> DataCon
kindRepVarDataCon :: DataCon
, TypeableStuff -> DataCon
kindRepAppDataCon :: DataCon
, TypeableStuff -> DataCon
kindRepFunDataCon :: DataCon
, TypeableStuff -> DataCon
kindRepTYPEDataCon :: DataCon
, TypeableStuff -> DataCon
kindRepTypeLitSDataCon :: DataCon
, TypeableStuff -> DataCon
typeLitSymbolDataCon :: DataCon
, TypeableStuff -> DataCon
typeLitNatDataCon :: DataCon
}
collect_stuff :: TcM TypeableStuff
collect_stuff :: TcM TypeableStuff
collect_stuff = do
Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
DataCon
trTyConDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trTyConDataConName
TyCon
kindRepTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
kindRepTyConName
DataCon
kindRepTyConAppDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepTyConAppDataConName
DataCon
kindRepVarDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepVarDataConName
DataCon
kindRepAppDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepAppDataConName
DataCon
kindRepFunDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepFunDataConName
DataCon
kindRepTYPEDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepTYPEDataConName
DataCon
kindRepTypeLitSDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepTypeLitSDataConName
DataCon
typeLitSymbolDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
typeLitSymbolDataConName
DataCon
typeLitNatDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
typeLitNatDataConName
FastString -> Located (HsExpr GhcTc)
trNameLit <- IOEnv
(Env TcGblEnv TcLclEnv) (FastString -> Located (HsExpr GhcTc))
TcM (FastString -> LHsExpr GhcTc)
mkTrNameLit
TypeableStuff -> TcM TypeableStuff
forall (m :: * -> *) a. Monad m => a -> m a
return Stuff :: Platform
-> DataCon
-> (FastString -> LHsExpr GhcTc)
-> TyCon
-> DataCon
-> DataCon
-> DataCon
-> DataCon
-> DataCon
-> DataCon
-> DataCon
-> DataCon
-> TypeableStuff
Stuff {Platform
TyCon
DataCon
FastString -> Located (HsExpr GhcTc)
FastString -> LHsExpr GhcTc
trNameLit :: FastString -> Located (HsExpr GhcTc)
typeLitNatDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trTyConDataCon :: DataCon
platform :: Platform
typeLitNatDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trNameLit :: FastString -> LHsExpr GhcTc
trTyConDataCon :: DataCon
platform :: Platform
..}
mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)
mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)
mkTrNameLit = do
DataCon
trNameSDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trNameSDataConName
let trNameLit :: FastString -> LHsExpr GhcTc
trNameLit :: FastString -> LHsExpr GhcTc
trNameLit FastString
fs = LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
trNameSDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcTc -> LHsExpr GhcTc
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (FastString -> HsLit GhcTc
forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit FastString
fs)
(FastString -> Located (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (FastString -> Located (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return FastString -> Located (HsExpr GhcTc)
FastString -> LHsExpr GhcTc
trNameLit
mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
-> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
mkTyConRepBinds :: TypeableStuff
-> TypeRepTodo -> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
mkTyConRepBinds TypeableStuff
stuff TypeRepTodo
todo (TypeableTyCon {Id
TyCon
tycon_rep_id :: Id
tycon :: TyCon
tycon_rep_id :: TypeableTyCon -> Id
tycon :: TypeableTyCon -> TyCon
..})
= do
let ([TyCoVarBinder]
bndrs, Type
kind) = Type -> ([TyCoVarBinder], Type)
splitForAllTyCoVarBinders (TyCon -> Type
tyConKind TyCon
tycon)
TcRn () -> KindRepM ()
forall a. TcRn a -> KindRepM a
liftTc (TcRn () -> KindRepM ()) -> TcRn () -> KindRepM ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc -> TcRn ()
traceTc String
"mkTyConKindRepBinds"
(TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind TyCon
tycon) SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
kind)
let ctx :: CmEnv
ctx = [Id] -> CmEnv
mkDeBruijnContext ((TyCoVarBinder -> Id) -> [TyCoVarBinder] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map TyCoVarBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar [TyCoVarBinder]
bndrs)
Located (HsExpr GhcTc)
kind_rep <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep TypeableStuff
stuff CmEnv
ctx Type
kind
let tycon_rep_rhs :: LHsExpr GhcTc
tycon_rep_rhs = TypeableStuff
-> TypeRepTodo -> TyCon -> LHsExpr GhcTc -> LHsExpr GhcTc
mkTyConRepTyConRHS TypeableStuff
stuff TypeRepTodo
todo TyCon
tycon Located (HsExpr GhcTc)
LHsExpr GhcTc
kind_rep
tycon_rep_bind :: LHsBind GhcTc
tycon_rep_bind = IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Id
IdP GhcTc
tycon_rep_id LHsExpr GhcTc
tycon_rep_rhs
Bag (Located (HsBindLR GhcTc GhcTc))
-> KindRepM (Bag (Located (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (Located (HsBindLR GhcTc GhcTc))
-> KindRepM (Bag (Located (HsBindLR GhcTc GhcTc))))
-> Bag (Located (HsBindLR GhcTc GhcTc))
-> KindRepM (Bag (Located (HsBindLR GhcTc GhcTc)))
forall a b. (a -> b) -> a -> b
$ Located (HsBindLR GhcTc GhcTc)
-> Bag (Located (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag Located (HsBindLR GhcTc GhcTc)
LHsBind GhcTc
tycon_rep_bind
tyConIsTypeable :: TyCon -> Bool
tyConIsTypeable :: TyCon -> Bool
tyConIsTypeable TyCon
tc =
Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust (TyCon -> Maybe Name
tyConRepName_maybe TyCon
tc)
Bool -> Bool -> Bool
&& Type -> Bool
kindIsTypeable (Type -> Type
dropForAlls (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ TyCon -> Type
tyConKind TyCon
tc)
kindIsTypeable :: Kind -> Bool
kindIsTypeable :: Type -> Bool
kindIsTypeable Type
ty
| Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Bool
kindIsTypeable Type
ty'
kindIsTypeable Type
ty
| Type -> Bool
isLiftedTypeKind Type
ty = Bool
True
kindIsTypeable (TyVarTy Id
_) = Bool
True
kindIsTypeable (AppTy Type
a Type
b) = Type -> Bool
kindIsTypeable Type
a Bool -> Bool -> Bool
&& Type -> Bool
kindIsTypeable Type
b
kindIsTypeable (FunTy AnonArgFlag
_ Type
w Type
a Type
b) = Type -> Bool
kindIsTypeable Type
w Bool -> Bool -> Bool
&&
Type -> Bool
kindIsTypeable Type
a Bool -> Bool -> Bool
&&
Type -> Bool
kindIsTypeable Type
b
kindIsTypeable (TyConApp TyCon
tc [Type]
args) = TyCon -> Bool
tyConIsTypeable TyCon
tc
Bool -> Bool -> Bool
&& (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
kindIsTypeable [Type]
args
kindIsTypeable (ForAllTy{}) = Bool
False
kindIsTypeable (LitTy TyLit
_) = Bool
True
kindIsTypeable (CastTy{}) = Bool
False
kindIsTypeable (CoercionTy{}) = Bool
False
type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc))
newtype KindRepM a = KindRepM { KindRepM a -> StateT KindRepEnv TcRn a
unKindRepM :: StateT KindRepEnv TcRn a }
deriving (a -> KindRepM b -> KindRepM a
(a -> b) -> KindRepM a -> KindRepM b
(forall a b. (a -> b) -> KindRepM a -> KindRepM b)
-> (forall a b. a -> KindRepM b -> KindRepM a) -> Functor KindRepM
forall a b. a -> KindRepM b -> KindRepM a
forall a b. (a -> b) -> KindRepM a -> KindRepM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> KindRepM b -> KindRepM a
$c<$ :: forall a b. a -> KindRepM b -> KindRepM a
fmap :: (a -> b) -> KindRepM a -> KindRepM b
$cfmap :: forall a b. (a -> b) -> KindRepM a -> KindRepM b
Functor, Functor KindRepM
a -> KindRepM a
Functor KindRepM
-> (forall a. a -> KindRepM a)
-> (forall a b. KindRepM (a -> b) -> KindRepM a -> KindRepM b)
-> (forall a b c.
(a -> b -> c) -> KindRepM a -> KindRepM b -> KindRepM c)
-> (forall a b. KindRepM a -> KindRepM b -> KindRepM b)
-> (forall a b. KindRepM a -> KindRepM b -> KindRepM a)
-> Applicative KindRepM
KindRepM a -> KindRepM b -> KindRepM b
KindRepM a -> KindRepM b -> KindRepM a
KindRepM (a -> b) -> KindRepM a -> KindRepM b
(a -> b -> c) -> KindRepM a -> KindRepM b -> KindRepM c
forall a. a -> KindRepM a
forall a b. KindRepM a -> KindRepM b -> KindRepM a
forall a b. KindRepM a -> KindRepM b -> KindRepM b
forall a b. KindRepM (a -> b) -> KindRepM a -> KindRepM b
forall a b c.
(a -> b -> c) -> KindRepM a -> KindRepM b -> KindRepM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: KindRepM a -> KindRepM b -> KindRepM a
$c<* :: forall a b. KindRepM a -> KindRepM b -> KindRepM a
*> :: KindRepM a -> KindRepM b -> KindRepM b
$c*> :: forall a b. KindRepM a -> KindRepM b -> KindRepM b
liftA2 :: (a -> b -> c) -> KindRepM a -> KindRepM b -> KindRepM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> KindRepM a -> KindRepM b -> KindRepM c
<*> :: KindRepM (a -> b) -> KindRepM a -> KindRepM b
$c<*> :: forall a b. KindRepM (a -> b) -> KindRepM a -> KindRepM b
pure :: a -> KindRepM a
$cpure :: forall a. a -> KindRepM a
$cp1Applicative :: Functor KindRepM
Applicative, Applicative KindRepM
a -> KindRepM a
Applicative KindRepM
-> (forall a b. KindRepM a -> (a -> KindRepM b) -> KindRepM b)
-> (forall a b. KindRepM a -> KindRepM b -> KindRepM b)
-> (forall a. a -> KindRepM a)
-> Monad KindRepM
KindRepM a -> (a -> KindRepM b) -> KindRepM b
KindRepM a -> KindRepM b -> KindRepM b
forall a. a -> KindRepM a
forall a b. KindRepM a -> KindRepM b -> KindRepM b
forall a b. KindRepM a -> (a -> KindRepM b) -> KindRepM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> KindRepM a
$creturn :: forall a. a -> KindRepM a
>> :: KindRepM a -> KindRepM b -> KindRepM b
$c>> :: forall a b. KindRepM a -> KindRepM b -> KindRepM b
>>= :: KindRepM a -> (a -> KindRepM b) -> KindRepM b
$c>>= :: forall a b. KindRepM a -> (a -> KindRepM b) -> KindRepM b
$cp1Monad :: Applicative KindRepM
Monad)
liftTc :: TcRn a -> KindRepM a
liftTc :: TcRn a -> KindRepM a
liftTc = StateT (TypeMap (Id, Maybe (Located (HsExpr GhcTc)))) TcRn a
-> KindRepM a
forall a. StateT KindRepEnv TcRn a -> KindRepM a
KindRepM (StateT (TypeMap (Id, Maybe (Located (HsExpr GhcTc)))) TcRn a
-> KindRepM a)
-> (TcRn a
-> StateT (TypeMap (Id, Maybe (Located (HsExpr GhcTc)))) TcRn a)
-> TcRn a
-> KindRepM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcRn a
-> StateT (TypeMap (Id, Maybe (Located (HsExpr GhcTc)))) TcRn a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
builtInKindReps :: [(Kind, Name)]
builtInKindReps :: [(Type, Name)]
builtInKindReps =
[ (Type
star, Name
starKindRepName)
, (Type -> Type -> Type
mkVisFunTyMany Type
star Type
star, Name
starArrStarKindRepName)
, ([Type] -> Type -> Type
mkVisFunTysMany [Type
star, Type
star] Type
star, Name
starArrStarArrStarKindRepName)
]
where
star :: Type
star = Type
liftedTypeKind
initialKindRepEnv :: TcRn KindRepEnv
initialKindRepEnv :: TcRn KindRepEnv
initialKindRepEnv = (TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> (Type, Name)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TypeMap (Id, Maybe (Located (HsExpr GhcTc)))))
-> TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> [(Type, Name)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> (Type, Name)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
forall a.
TypeMap (Id, Maybe a)
-> (Type, Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Id, Maybe a))
add_kind_rep TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
forall a. TypeMap a
emptyTypeMap [(Type, Name)]
builtInKindReps
where
add_kind_rep :: TypeMap (Id, Maybe a)
-> (Type, Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Id, Maybe a))
add_kind_rep TypeMap (Id, Maybe a)
acc (Type
k,Name
n) = do
Id
id <- Name -> TcM Id
tcLookupId Name
n
TypeMap (Id, Maybe a)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Id, Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMap (Id, Maybe a)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Id, Maybe a)))
-> TypeMap (Id, Maybe a)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Id, Maybe a))
forall a b. (a -> b) -> a -> b
$! TypeMap (Id, Maybe a)
-> Type -> (Id, Maybe a) -> TypeMap (Id, Maybe a)
forall a. TypeMap a -> Type -> a -> TypeMap a
extendTypeMap TypeMap (Id, Maybe a)
acc Type
k (Id
id, Maybe a
forall a. Maybe a
Nothing)
mkExportedKindReps :: TypeableStuff
-> [(Kind, Id)]
-> KindRepM ()
mkExportedKindReps :: TypeableStuff -> [(Type, Id)] -> KindRepM ()
mkExportedKindReps TypeableStuff
stuff = ((Type, Id) -> KindRepM ()) -> [(Type, Id)] -> KindRepM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Type, Id) -> KindRepM ()
kindrep_binding
where
empty_scope :: CmEnv
empty_scope = [Id] -> CmEnv
mkDeBruijnContext []
kindrep_binding :: (Kind, Id) -> KindRepM ()
kindrep_binding :: (Type, Id) -> KindRepM ()
kindrep_binding (Type
kind, Id
rep_bndr) = do
Located (HsExpr GhcTc)
rhs <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
mkKindRepRhs TypeableStuff
stuff CmEnv
empty_scope Type
kind
CmEnv -> Type -> Id -> LHsExpr GhcTc -> KindRepM ()
addKindRepBind CmEnv
empty_scope Type
kind Id
rep_bndr Located (HsExpr GhcTc)
LHsExpr GhcTc
rhs
addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM ()
addKindRepBind :: CmEnv -> Type -> Id -> LHsExpr GhcTc -> KindRepM ()
addKindRepBind CmEnv
in_scope Type
k Id
bndr LHsExpr GhcTc
rhs =
StateT KindRepEnv TcRn () -> KindRepM ()
forall a. StateT KindRepEnv TcRn a -> KindRepM a
KindRepM (StateT KindRepEnv TcRn () -> KindRepM ())
-> StateT KindRepEnv TcRn () -> KindRepM ()
forall a b. (a -> b) -> a -> b
$ (TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
-> StateT (TypeMap (Id, Maybe (Located (HsExpr GhcTc)))) TcRn ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
-> StateT (TypeMap (Id, Maybe (Located (HsExpr GhcTc)))) TcRn ())
-> (TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
-> StateT (TypeMap (Id, Maybe (Located (HsExpr GhcTc)))) TcRn ()
forall a b. (a -> b) -> a -> b
$
\TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
env -> TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> CmEnv
-> Type
-> (Id, Maybe (Located (HsExpr GhcTc)))
-> TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
forall a. TypeMap a -> CmEnv -> Type -> a -> TypeMap a
extendTypeMapWithScope TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
env CmEnv
in_scope Type
k (Id
bndr, Located (HsExpr GhcTc) -> Maybe (Located (HsExpr GhcTc))
forall a. a -> Maybe a
Just Located (HsExpr GhcTc)
LHsExpr GhcTc
rhs)
runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)
runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)
runKindRepM (KindRepM StateT KindRepEnv TcRn a
action) = do
TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
kindRepEnv <- IOEnv
(Env TcGblEnv TcLclEnv)
(TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
TcRn KindRepEnv
initialKindRepEnv
(a
res, TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
reps_env) <- StateT (TypeMap (Id, Maybe (Located (HsExpr GhcTc)))) TcRn a
-> TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> TcRn (a, TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (TypeMap (Id, Maybe (Located (HsExpr GhcTc)))) TcRn a
StateT KindRepEnv TcRn a
action TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
kindRepEnv
let rep_binds :: [(Id, Located (HsExpr GhcTc))]
rep_binds = ((Id, Maybe (Located (HsExpr GhcTc)))
-> [(Id, Located (HsExpr GhcTc))]
-> [(Id, Located (HsExpr GhcTc))])
-> [(Id, Located (HsExpr GhcTc))]
-> TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> [(Id, Located (HsExpr GhcTc))]
forall a b. (a -> b -> b) -> b -> TypeMap a -> b
foldTypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> [(Id, Located (HsExpr GhcTc))] -> [(Id, Located (HsExpr GhcTc))]
forall a b. (a, Maybe b) -> [(a, b)] -> [(a, b)]
to_bind_pair [] TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
reps_env
to_bind_pair :: (a, Maybe b) -> [(a, b)] -> [(a, b)]
to_bind_pair (a
bndr, Just b
rhs) [(a, b)]
rest = (a
bndr, b
rhs) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
rest
to_bind_pair (a
_, Maybe b
Nothing) [(a, b)]
rest = [(a, b)]
rest
TcGblEnv
tcg_env <- [Id] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv (((Id, Located (HsExpr GhcTc)) -> Id)
-> [(Id, Located (HsExpr GhcTc))] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Located (HsExpr GhcTc)) -> Id
forall a b. (a, b) -> a
fst [(Id, Located (HsExpr GhcTc))]
rep_binds) TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
let binds :: [Located (HsBindLR GhcTc GhcTc)]
binds = ((Id, Located (HsExpr GhcTc)) -> Located (HsBindLR GhcTc GhcTc))
-> [(Id, Located (HsExpr GhcTc))]
-> [Located (HsBindLR GhcTc GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map ((Id -> Located (HsExpr GhcTc) -> Located (HsBindLR GhcTc GhcTc))
-> (Id, Located (HsExpr GhcTc)) -> Located (HsBindLR GhcTc GhcTc)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Id -> Located (HsExpr GhcTc) -> Located (HsBindLR GhcTc GhcTc)
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind) [(Id, Located (HsExpr GhcTc))]
rep_binds
tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
`addTypecheckedBinds` [[Located (HsBindLR GhcTc GhcTc)]
-> Bag (Located (HsBindLR GhcTc GhcTc))
forall a. [a] -> Bag a
listToBag [Located (HsBindLR GhcTc GhcTc)]
binds]
(TcGblEnv, a) -> TcRn (TcGblEnv, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env', a
res)
getKindRep :: TypeableStuff -> CmEnv
-> Kind
-> KindRepM (LHsExpr GhcTc)
getKindRep :: TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep stuff :: TypeableStuff
stuff@(Stuff {Platform
TyCon
DataCon
FastString -> LHsExpr GhcTc
typeLitNatDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trNameLit :: FastString -> LHsExpr GhcTc
trTyConDataCon :: DataCon
platform :: Platform
typeLitNatDataCon :: TypeableStuff -> DataCon
typeLitSymbolDataCon :: TypeableStuff -> DataCon
kindRepTypeLitSDataCon :: TypeableStuff -> DataCon
kindRepTYPEDataCon :: TypeableStuff -> DataCon
kindRepFunDataCon :: TypeableStuff -> DataCon
kindRepAppDataCon :: TypeableStuff -> DataCon
kindRepVarDataCon :: TypeableStuff -> DataCon
kindRepTyConAppDataCon :: TypeableStuff -> DataCon
kindRepTyCon :: TypeableStuff -> TyCon
trNameLit :: TypeableStuff -> FastString -> LHsExpr GhcTc
trTyConDataCon :: TypeableStuff -> DataCon
platform :: TypeableStuff -> Platform
..}) CmEnv
in_scope = Type -> KindRepM (LHsExpr GhcTc)
go
where
go :: Kind -> KindRepM (LHsExpr GhcTc)
go :: Type -> KindRepM (LHsExpr GhcTc)
go = StateT
(TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
TcRn
(Located (HsExpr GhcTc))
-> KindRepM (Located (HsExpr GhcTc))
forall a. StateT KindRepEnv TcRn a -> KindRepM a
KindRepM (StateT
(TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
TcRn
(Located (HsExpr GhcTc))
-> KindRepM (Located (HsExpr GhcTc)))
-> (Type
-> StateT
(TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
TcRn
(Located (HsExpr GhcTc)))
-> Type
-> KindRepM (Located (HsExpr GhcTc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located (HsExpr GhcTc),
TypeMap (Id, Maybe (Located (HsExpr GhcTc)))))
-> StateT
(TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
TcRn
(Located (HsExpr GhcTc))
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located (HsExpr GhcTc),
TypeMap (Id, Maybe (Located (HsExpr GhcTc)))))
-> StateT
(TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
TcRn
(Located (HsExpr GhcTc)))
-> (Type
-> TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located (HsExpr GhcTc),
TypeMap (Id, Maybe (Located (HsExpr GhcTc)))))
-> Type
-> StateT
(TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
TcRn
(Located (HsExpr GhcTc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type
-> TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located (HsExpr GhcTc),
TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
Type -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
go'
go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
go' :: Type -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
go' Type
k KindRepEnv
env
| Just Type
k' <- Type -> Maybe Type
tcView Type
k = Type -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
go' Type
k' KindRepEnv
env
| Just (Id
id, Maybe (Located (HsExpr GhcTc))
_) <- TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> CmEnv -> Type -> Maybe (Id, Maybe (Located (HsExpr GhcTc)))
forall a. TypeMap a -> CmEnv -> Type -> Maybe a
lookupTypeMapWithScope TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
KindRepEnv
env CmEnv
in_scope Type
k
= (Located (HsExpr GhcTc),
TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located (HsExpr GhcTc),
TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
forall (m :: * -> *) a. Monad m => a -> m a
return (IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
id, TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
KindRepEnv
env)
| Bool
otherwise
= do
Id
rep_bndr <- (Id -> InlinePragma -> Id
`setInlinePragma` InlinePragma
neverInlinePragma)
(Id -> Id) -> TcM Id -> TcM Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> Type -> Type -> TcM Id
forall gbl lcl. FastString -> Type -> Type -> TcRnIf gbl lcl Id
newSysLocalId (String -> FastString
fsLit String
"$krep") Type
Many (TyCon -> Type
mkTyConTy TyCon
kindRepTyCon)
(StateT
(TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
TcRn
(Located (HsExpr GhcTc))
-> TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located (HsExpr GhcTc),
TypeMap (Id, Maybe (Located (HsExpr GhcTc)))))
-> TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> StateT
(TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
TcRn
(Located (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located (HsExpr GhcTc),
TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
(TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
TcRn
(Located (HsExpr GhcTc))
-> TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located (HsExpr GhcTc),
TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT TypeMap (Id, Maybe (Located (HsExpr GhcTc)))
KindRepEnv
env (StateT
(TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
TcRn
(Located (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located (HsExpr GhcTc),
TypeMap (Id, Maybe (Located (HsExpr GhcTc)))))
-> StateT
(TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
TcRn
(Located (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located (HsExpr GhcTc),
TypeMap (Id, Maybe (Located (HsExpr GhcTc))))
forall a b. (a -> b) -> a -> b
$ KindRepM (Located (HsExpr GhcTc))
-> StateT KindRepEnv TcRn (Located (HsExpr GhcTc))
forall a. KindRepM a -> StateT KindRepEnv TcRn a
unKindRepM (KindRepM (Located (HsExpr GhcTc))
-> StateT KindRepEnv TcRn (Located (HsExpr GhcTc)))
-> KindRepM (Located (HsExpr GhcTc))
-> StateT KindRepEnv TcRn (Located (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ do
Located (HsExpr GhcTc)
rhs <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
mkKindRepRhs TypeableStuff
stuff CmEnv
in_scope Type
k
CmEnv -> Type -> Id -> LHsExpr GhcTc -> KindRepM ()
addKindRepBind CmEnv
in_scope Type
k Id
rep_bndr Located (HsExpr GhcTc)
LHsExpr GhcTc
rhs
Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc)))
-> Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
rep_bndr
mkKindRepRhs :: TypeableStuff
-> CmEnv
-> Kind
-> KindRepM (LHsExpr GhcTc)
mkKindRepRhs :: TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
mkKindRepRhs stuff :: TypeableStuff
stuff@(Stuff {Platform
TyCon
DataCon
FastString -> LHsExpr GhcTc
typeLitNatDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trNameLit :: FastString -> LHsExpr GhcTc
trTyConDataCon :: DataCon
platform :: Platform
typeLitNatDataCon :: TypeableStuff -> DataCon
typeLitSymbolDataCon :: TypeableStuff -> DataCon
kindRepTypeLitSDataCon :: TypeableStuff -> DataCon
kindRepTYPEDataCon :: TypeableStuff -> DataCon
kindRepFunDataCon :: TypeableStuff -> DataCon
kindRepAppDataCon :: TypeableStuff -> DataCon
kindRepVarDataCon :: TypeableStuff -> DataCon
kindRepTyConAppDataCon :: TypeableStuff -> DataCon
kindRepTyCon :: TypeableStuff -> TyCon
trNameLit :: TypeableStuff -> FastString -> LHsExpr GhcTc
trTyConDataCon :: TypeableStuff -> DataCon
platform :: TypeableStuff -> Platform
..}) CmEnv
in_scope = Type -> KindRepM (Located (HsExpr GhcTc))
Type -> KindRepM (LHsExpr GhcTc)
new_kind_rep
where
new_kind_rep :: Type -> KindRepM (Located (HsExpr GhcTc))
new_kind_rep Type
k
| Bool -> Bool
not (Type -> Bool
tcIsConstraintKind Type
k)
, Just Type
arg <- HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
kindRep_maybe Type
k
, Just (TyCon
tc, []) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
arg
, Just DataCon
dc <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
tc
= Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc)))
-> Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepTYPEDataCon LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
dc
new_kind_rep (TyVarTy Id
v)
| Just Arity
idx <- CmEnv -> Id -> Maybe Arity
lookupCME CmEnv
in_scope Id
v
= Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc)))
-> Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepVarDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` Integer -> LHsExpr GhcTc
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit (Arity -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Arity
idx)
| Bool
otherwise
= String -> SDoc -> KindRepM (Located (HsExpr GhcTc))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds.go(tyvar)" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v)
new_kind_rep (AppTy Type
t1 Type
t2)
= do Located (HsExpr GhcTc)
rep1 <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t1
Located (HsExpr GhcTc)
rep2 <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t2
Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc)))
-> Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepAppDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` Located (HsExpr GhcTc)
LHsExpr GhcTc
rep1 LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` Located (HsExpr GhcTc)
LHsExpr GhcTc
rep2
new_kind_rep k :: Type
k@(TyConApp TyCon
tc [Type]
tys)
| Just Name
rep_name <- TyCon -> Maybe Name
tyConRepName_maybe TyCon
tc
= do Id
rep_id <- TcM Id -> KindRepM Id
forall a. TcRn a -> KindRepM a
liftTc (TcM Id -> KindRepM Id) -> TcM Id -> KindRepM Id
forall a b. (a -> b) -> a -> b
$ Name -> TcM Id
forall (m :: * -> *). MonadThings m => Name -> m Id
lookupId Name
rep_name
[Located (HsExpr GhcTc)]
tys' <- (Type -> KindRepM (Located (HsExpr GhcTc)))
-> [Type] -> KindRepM [Located (HsExpr GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep TypeableStuff
stuff CmEnv
in_scope) [Type]
tys
Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc)))
-> Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepTyConAppDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
rep_id
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
mkList (TyCon -> Type
mkTyConTy TyCon
kindRepTyCon) [Located (HsExpr GhcTc)]
[LHsExpr GhcTc]
tys'
| Bool
otherwise
= String -> SDoc -> KindRepM (Located (HsExpr GhcTc))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds(TyConApp)" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
k)
new_kind_rep (ForAllTy (Bndr Id
var ArgFlag
_) Type
ty)
= String -> SDoc -> KindRepM (Located (HsExpr GhcTc))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds(ForAllTy)" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
var SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
new_kind_rep (FunTy AnonArgFlag
_ Type
_ Type
t1 Type
t2)
= do Located (HsExpr GhcTc)
rep1 <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t1
Located (HsExpr GhcTc)
rep2 <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t2
Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc)))
-> Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepFunDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` Located (HsExpr GhcTc)
LHsExpr GhcTc
rep1 LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` Located (HsExpr GhcTc)
LHsExpr GhcTc
rep2
new_kind_rep (LitTy (NumTyLit Integer
n))
= Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc)))
-> Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepTypeLitSDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
typeLitNatDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcTc -> LHsExpr GhcTc
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (FastString -> HsLit GhcTc
forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit (FastString -> HsLit GhcTc) -> FastString -> HsLit GhcTc
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
n)
new_kind_rep (LitTy (StrTyLit FastString
s))
= Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc)))
-> Located (HsExpr GhcTc) -> KindRepM (Located (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepTypeLitSDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
typeLitSymbolDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcTc -> LHsExpr GhcTc
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (FastString -> HsLit GhcTc
forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit (FastString -> HsLit GhcTc) -> FastString -> HsLit GhcTc
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ FastString -> String
forall a. Show a => a -> String
show FastString
s)
new_kind_rep (CastTy Type
ty KindCoercion
co)
= String -> SDoc -> KindRepM (Located (HsExpr GhcTc))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds.go(cast)" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ KindCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr KindCoercion
co)
new_kind_rep (CoercionTy KindCoercion
co)
= String -> SDoc -> KindRepM (Located (HsExpr GhcTc))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds.go(coercion)" (KindCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr KindCoercion
co)
mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo
-> TyCon
-> LHsExpr GhcTc
-> LHsExpr GhcTc
mkTyConRepTyConRHS :: TypeableStuff
-> TypeRepTodo -> TyCon -> LHsExpr GhcTc -> LHsExpr GhcTc
mkTyConRepTyConRHS (Stuff {Platform
TyCon
DataCon
FastString -> LHsExpr GhcTc
typeLitNatDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trNameLit :: FastString -> LHsExpr GhcTc
trTyConDataCon :: DataCon
platform :: Platform
typeLitNatDataCon :: TypeableStuff -> DataCon
typeLitSymbolDataCon :: TypeableStuff -> DataCon
kindRepTypeLitSDataCon :: TypeableStuff -> DataCon
kindRepTYPEDataCon :: TypeableStuff -> DataCon
kindRepFunDataCon :: TypeableStuff -> DataCon
kindRepAppDataCon :: TypeableStuff -> DataCon
kindRepVarDataCon :: TypeableStuff -> DataCon
kindRepTyConAppDataCon :: TypeableStuff -> DataCon
kindRepTyCon :: TypeableStuff -> TyCon
trNameLit :: TypeableStuff -> FastString -> LHsExpr GhcTc
trTyConDataCon :: TypeableStuff -> DataCon
platform :: TypeableStuff -> Platform
..}) TypeRepTodo
todo TyCon
tycon LHsExpr GhcTc
kind_rep
= DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
trTyConDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcTc -> LHsExpr GhcTc
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (Platform -> Word64 -> HsLit GhcTc
word64 Platform
platform Word64
high)
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcTc -> LHsExpr GhcTc
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (Platform -> Word64 -> HsLit GhcTc
word64 Platform
platform Word64
low)
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` TypeRepTodo -> LHsExpr GhcTc
mod_rep_expr TypeRepTodo
todo
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString -> LHsExpr GhcTc
trNameLit (String -> FastString
mkFastString String
tycon_str)
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcTc -> LHsExpr GhcTc
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (Arity -> HsLit GhcTc
int Arity
n_kind_vars)
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcTc
kind_rep
where
n_kind_vars :: Arity
n_kind_vars = [TyConBinder] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length ([TyConBinder] -> Arity) -> [TyConBinder] -> Arity
forall a b. (a -> b) -> a -> b
$ (TyConBinder -> Bool) -> [TyConBinder] -> [TyConBinder]
forall a. (a -> Bool) -> [a] -> [a]
filter TyConBinder -> Bool
isNamedTyConBinder (TyCon -> [TyConBinder]
tyConBinders TyCon
tycon)
tycon_str :: String
tycon_str = String -> String
add_tick (OccName -> String
occNameString (TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
tycon))
add_tick :: String -> String
add_tick String
s | TyCon -> Bool
isPromotedDataCon TyCon
tycon = Char
'\'' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s
| Bool
otherwise = String
s
Fingerprint Word64
high Word64
low = [Fingerprint] -> Fingerprint
fingerprintFingerprints [ TypeRepTodo -> Fingerprint
pkg_fingerprint TypeRepTodo
todo
, TypeRepTodo -> Fingerprint
mod_fingerprint TypeRepTodo
todo
, String -> Fingerprint
fingerprintString String
tycon_str
]
int :: Int -> HsLit GhcTc
int :: Arity -> HsLit GhcTc
int Arity
n = XHsIntPrim GhcTc -> Integer -> HsLit GhcTc
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim (String -> SourceText
SourceText (String -> SourceText) -> String -> SourceText
forall a b. (a -> b) -> a -> b
$ Arity -> String
forall a. Show a => a -> String
show Arity
n) (Arity -> Integer
forall a. Integral a => a -> Integer
toInteger Arity
n)
word64 :: Platform -> Word64 -> HsLit GhcTc
word64 :: Platform -> Word64 -> HsLit GhcTc
word64 Platform
platform Word64
n = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
PlatformWordSize
PW4 -> XHsWord64Prim GhcTc -> Integer -> HsLit GhcTc
forall x. XHsWord64Prim x -> Integer -> HsLit x
HsWord64Prim SourceText
XHsWord64Prim GhcTc
NoSourceText (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
n)
PlatformWordSize
PW8 -> XHsWordPrim GhcTc -> Integer -> HsLit GhcTc
forall x. XHsWordPrim x -> Integer -> HsLit x
HsWordPrim SourceText
XHsWordPrim GhcTc
NoSourceText (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
n)
mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
mkList Type
ty = (Located (HsExpr GhcTc)
-> Located (HsExpr GhcTc) -> Located (HsExpr GhcTc))
-> Located (HsExpr GhcTc)
-> [Located (HsExpr GhcTc)]
-> Located (HsExpr GhcTc)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Located (HsExpr GhcTc)
-> Located (HsExpr GhcTc) -> Located (HsExpr GhcTc)
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
consApp (Type -> LHsExpr GhcTc
nilExpr Type
ty)
where
cons :: LHsExpr GhcTc
cons = Type -> LHsExpr GhcTc
consExpr Type
ty
consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
consApp LHsExpr GhcTc
x LHsExpr GhcTc
xs = LHsExpr GhcTc
cons LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcTc
x LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcTc
xs
nilExpr :: Type -> LHsExpr GhcTc
nilExpr :: Type -> LHsExpr GhcTc
nilExpr Type
ty = HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap ([Type] -> HsWrapper
mkWpTyApps [Type
ty]) (DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
nilDataCon)
consExpr :: Type -> LHsExpr GhcTc
consExpr :: Type -> LHsExpr GhcTc
consExpr Type
ty = HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap ([Type] -> HsWrapper
mkWpTyApps [Type
ty]) (DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
consDataCon)