{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecursiveDo #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RecordWildCards #-}
module GHC.IfaceToCore (
tcLookupImported_maybe,
importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
typecheckWholeCoreBindings,
typecheckIfacesForMerging,
typecheckIfaceForInstantiate,
tcIfaceDecl, tcIfaceDecls, tcIfaceDefaults,
tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
tcIfaceAnnotations, tcIfaceCompleteMatches,
tcIfaceExpr,
tcIfaceGlobal,
tcIfaceOneShot, tcTopIfaceBindings,
tcIfaceImport,
hydrateCgBreakInfo
) where
import GHC.Prelude
import GHC.ByteCode.Types
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Config.Core.Lint ( initLintConfig )
import GHC.Builtin.Types.Literals(typeNatCoAxiomRules)
import GHC.Builtin.Types
import GHC.Iface.Syntax
import GHC.Iface.Load
import GHC.Iface.Env
import GHC.StgToCmm.Types
import GHC.Runtime.Heap.Layout
import GHC.Tc.Errors.Types
import GHC.Tc.TyCl.Build
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Env
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.Coercion.Axiom
import GHC.Core.FVs
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Subst ( substTyCoVars )
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.Core
import GHC.Core.RoughMap( RoughMatchTc(..) )
import GHC.Core.Utils
import GHC.Core.Unfold( calcUnfoldingGuidance )
import GHC.Core.Unfold.Make
import GHC.Core.Lint
import GHC.Core.Make
import GHC.Core.Class
import GHC.Core.TyCon
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
import GHC.Core.Ppr
import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.Module
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModIface
import GHC.Unit.Home.ModInfo
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Logger
import GHC.Data.Bag
import GHC.Data.Maybe
import GHC.Data.FastString
import GHC.Data.List.SetOps
import GHC.Types.Annotations
import GHC.Types.SourceFile
import GHC.Types.SourceText
import GHC.Types.Basic hiding ( SuccessFlag(..) )
import GHC.Types.CompleteMatch
import GHC.Types.SrcLoc
import GHC.Types.TypeEnv
import GHC.Types.Unique.FM
import GHC.Types.Unique.DSet ( mkUniqDSet )
import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
import GHC.Types.Unique.Supply
import GHC.Types.Demand( isDeadEndSig )
import GHC.Types.Literal
import GHC.Types.Var as Var
import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.Name.Env
import GHC.Types.DefaultEnv ( ClassDefaults(..), defaultEnv )
import GHC.Types.Id
import GHC.Types.Id.Make
import GHC.Types.Id.Info
import GHC.Types.Tickish
import GHC.Types.TyThing
import GHC.Types.Error
import GHC.Parser.Annotation (noLocA)
import GHC.Hs.Extension ( GhcRn )
import GHC.Fingerprint
import Control.Monad
import GHC.Driver.Env.KnotVars
import GHC.Unit.Module.WholeCoreBindings
import Data.IORef
import Data.Foldable
import Data.Function ( on )
import Data.List(nub)
import Data.List.NonEmpty ( NonEmpty )
import qualified Data.List.NonEmpty as NE
import GHC.Builtin.Names (ioTyConName, rOOT_MAIN)
import GHC.Iface.Errors.Types
import Language.Haskell.Syntax.BooleanFormula (BooleanFormula)
import Language.Haskell.Syntax.BooleanFormula qualified as BF(BooleanFormula(..))
import Language.Haskell.Syntax.Extension (NoExtField (NoExtField))
typecheckIface :: ModIface
-> IfG ModDetails
typecheckIface :: ModIface -> IfG ModDetails
typecheckIface ModIface
iface
| let iface_mod :: Module
iface_mod = ModIface -> Module
forall (a :: ModIfacePhase). ModIface_ a -> Module
mi_semantic_module ModIface
iface
= Module
-> SDoc -> IsBootInterface -> IfL ModDetails -> IfG ModDetails
forall a lcl.
Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
initIfaceLcl Module
iface_mod (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"typecheckIface") (ModIface -> IsBootInterface
mi_boot ModIface
iface) (IfL ModDetails -> IfG ModDetails)
-> IfL ModDetails -> IfG ModDetails
forall a b. (a -> b) -> a -> b
$ do
{
ignore_prags <- GeneralFlag -> TcRnIf IfGblEnv IfLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_IgnoreInterfacePragmas
; names_w_things <- tcIfaceDecls ignore_prags (mi_decls iface)
; let type_env = [(Name, TyThing)] -> TypeEnv
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name, TyThing)]
names_w_things
; defaults <- mapM (tcIfaceDefault iface_mod) (mi_defaults iface)
; insts <- mapM tcIfaceInst (mi_insts iface)
; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; rules <- tcIfaceRules ignore_prags (mi_rules iface)
; anns <- tcIfaceAnnotations (mi_anns iface)
; exports <- ifaceExportNames (mi_exports iface)
; complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
text "Type envt:" <+> ppr (map fst names_w_things)])
; return $ ModDetails { md_types = type_env
, md_defaults = defaultEnv defaults
, md_insts = mkInstEnv insts
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
, md_exports = exports
, md_complete_matches = complete_matches
}
}
typecheckWholeCoreBindings :: IORef TypeEnv -> WholeCoreBindings -> IfG [CoreBind]
typecheckWholeCoreBindings :: IORef TypeEnv -> WholeCoreBindings -> IfG [CoreBind]
typecheckWholeCoreBindings IORef TypeEnv
type_var WholeCoreBindings {[IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
wcb_bindings :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
wcb_bindings :: WholeCoreBindings -> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
wcb_bindings, Module
wcb_module :: Module
wcb_module :: WholeCoreBindings -> Module
wcb_module} =
Module
-> SDoc -> IsBootInterface -> IfL [CoreBind] -> IfG [CoreBind]
forall a lcl.
Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
initIfaceLcl Module
wcb_module (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"typecheckWholeCoreBindings") IsBootInterface
NotBoot (IfL [CoreBind] -> IfG [CoreBind])
-> IfL [CoreBind] -> IfG [CoreBind]
forall a b. (a -> b) -> a -> b
$ do
IORef TypeEnv
-> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -> IfL [CoreBind]
tcTopIfaceBindings IORef TypeEnv
type_var [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
wcb_bindings
isAbstractIfaceDecl :: IfaceDecl -> Bool
isAbstractIfaceDecl :: IfaceDecl -> Bool
isAbstractIfaceDecl IfaceData{ ifCons :: IfaceDecl -> IfaceConDecls
ifCons = IfAbstractTyCon {} } = Bool
True
isAbstractIfaceDecl IfaceClass{ ifBody :: IfaceDecl -> IfaceClassBody
ifBody = IfaceClassBody
IfAbstractClass } = Bool
True
isAbstractIfaceDecl IfaceFamily{ ifFamFlav :: IfaceDecl -> IfaceFamTyConFlav
ifFamFlav = IfaceFamTyConFlav
IfaceAbstractClosedSynFamilyTyCon } = Bool
True
isAbstractIfaceDecl IfaceDecl
_ = Bool
False
ifMaybeRoles :: IfaceDecl -> Maybe [Role]
ifMaybeRoles :: IfaceDecl -> Maybe [Role]
ifMaybeRoles IfaceData { ifRoles :: IfaceDecl -> [Role]
ifRoles = [Role]
rs } = [Role] -> Maybe [Role]
forall a. a -> Maybe a
Just [Role]
rs
ifMaybeRoles IfaceSynonym { ifRoles :: IfaceDecl -> [Role]
ifRoles = [Role]
rs } = [Role] -> Maybe [Role]
forall a. a -> Maybe a
Just [Role]
rs
ifMaybeRoles IfaceClass { ifRoles :: IfaceDecl -> [Role]
ifRoles = [Role]
rs } = [Role] -> Maybe [Role]
forall a. a -> Maybe a
Just [Role]
rs
ifMaybeRoles IfaceDecl
_ = Maybe [Role]
forall a. Maybe a
Nothing
mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl
mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl
mergeIfaceDecl IfaceDecl
d1 IfaceDecl
d2
| IfaceDecl -> Bool
isAbstractIfaceDecl IfaceDecl
d1 = IfaceDecl
d2 IfaceDecl -> IfaceDecl -> IfaceDecl
`withRolesFrom` IfaceDecl
d1
| IfaceDecl -> Bool
isAbstractIfaceDecl IfaceDecl
d2 = IfaceDecl
d1 IfaceDecl -> IfaceDecl -> IfaceDecl
`withRolesFrom` IfaceDecl
d2
| IfaceClass{ ifBody :: IfaceDecl -> IfaceClassBody
ifBody = IfConcreteClass { ifSigs :: IfaceClassBody -> [IfaceClassOp]
ifSigs = [IfaceClassOp]
ops1, ifMinDef :: IfaceClassBody -> IfaceBooleanFormula
ifMinDef = IfaceBooleanFormula
bf1 } } <- IfaceDecl
d1
, IfaceClass{ ifBody :: IfaceDecl -> IfaceClassBody
ifBody = IfConcreteClass { ifSigs :: IfaceClassBody -> [IfaceClassOp]
ifSigs = [IfaceClassOp]
ops2, ifMinDef :: IfaceClassBody -> IfaceBooleanFormula
ifMinDef = IfaceBooleanFormula
bf2 } } <- IfaceDecl
d2
= let ops :: [IfaceClassOp]
ops = NameEnv IfaceClassOp -> [IfaceClassOp]
forall a. NameEnv a -> [a]
nonDetNameEnvElts (NameEnv IfaceClassOp -> [IfaceClassOp])
-> NameEnv IfaceClassOp -> [IfaceClassOp]
forall a b. (a -> b) -> a -> b
$
(IfaceClassOp -> IfaceClassOp -> IfaceClassOp)
-> NameEnv IfaceClassOp
-> NameEnv IfaceClassOp
-> NameEnv IfaceClassOp
forall a. (a -> a -> a) -> NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv_C IfaceClassOp -> IfaceClassOp -> IfaceClassOp
mergeIfaceClassOp
([(Name, IfaceClassOp)] -> NameEnv IfaceClassOp
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (Name
n, IfaceClassOp
op) | op :: IfaceClassOp
op@(IfaceClassOp Name
n IfaceType
_ Maybe (DefMethSpec IfaceType)
_) <- [IfaceClassOp]
ops1 ])
([(Name, IfaceClassOp)] -> NameEnv IfaceClassOp
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (Name
n, IfaceClassOp
op) | op :: IfaceClassOp
op@(IfaceClassOp Name
n IfaceType
_ Maybe (DefMethSpec IfaceType)
_) <- [IfaceClassOp]
ops2 ])
in IfaceDecl
d1 { ifBody = (ifBody d1) {
ifSigs = ops,
ifMinDef = mkOr [ bf1, bf2]
}
} IfaceDecl -> IfaceDecl -> IfaceDecl
`withRolesFrom` IfaceDecl
d2
| Bool
otherwise = IfaceDecl
d1 IfaceDecl -> IfaceDecl -> IfaceDecl
`withRolesFrom` IfaceDecl
d2
where
mkOr :: [IfaceBooleanFormula] -> IfaceBooleanFormula
mkOr :: [IfaceBooleanFormula] -> IfaceBooleanFormula
mkOr = IfaceBooleanFormula
-> ([[IfaceBooleanFormula]] -> IfaceBooleanFormula)
-> Maybe [[IfaceBooleanFormula]]
-> IfaceBooleanFormula
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([IfaceBooleanFormula] -> IfaceBooleanFormula
IfAnd []) ([IfaceBooleanFormula] -> IfaceBooleanFormula
mkOr' ([IfaceBooleanFormula] -> IfaceBooleanFormula)
-> ([[IfaceBooleanFormula]] -> [IfaceBooleanFormula])
-> [[IfaceBooleanFormula]]
-> IfaceBooleanFormula
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IfaceBooleanFormula] -> [IfaceBooleanFormula]
forall a. Eq a => [a] -> [a]
nub ([IfaceBooleanFormula] -> [IfaceBooleanFormula])
-> ([[IfaceBooleanFormula]] -> [IfaceBooleanFormula])
-> [[IfaceBooleanFormula]]
-> [IfaceBooleanFormula]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[IfaceBooleanFormula]] -> [IfaceBooleanFormula]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (Maybe [[IfaceBooleanFormula]] -> IfaceBooleanFormula)
-> ([IfaceBooleanFormula] -> Maybe [[IfaceBooleanFormula]])
-> [IfaceBooleanFormula]
-> IfaceBooleanFormula
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IfaceBooleanFormula -> Maybe [IfaceBooleanFormula])
-> [IfaceBooleanFormula] -> Maybe [[IfaceBooleanFormula]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceBooleanFormula -> Maybe [IfaceBooleanFormula]
fromOr
where
fromOr :: IfaceBooleanFormula -> Maybe [IfaceBooleanFormula]
fromOr IfaceBooleanFormula
bf = case IfaceBooleanFormula
bf of
(IfOr [IfaceBooleanFormula]
xs) -> [IfaceBooleanFormula] -> Maybe [IfaceBooleanFormula]
forall a. a -> Maybe a
Just [IfaceBooleanFormula]
xs
(IfAnd []) -> Maybe [IfaceBooleanFormula]
forall a. Maybe a
Nothing
IfaceBooleanFormula
_ -> [IfaceBooleanFormula] -> Maybe [IfaceBooleanFormula]
forall a. a -> Maybe a
Just [IfaceBooleanFormula
bf]
mkOr' :: [IfaceBooleanFormula] -> IfaceBooleanFormula
mkOr' [IfaceBooleanFormula
x] = IfaceBooleanFormula
x
mkOr' [IfaceBooleanFormula]
xs = [IfaceBooleanFormula] -> IfaceBooleanFormula
IfOr [IfaceBooleanFormula]
xs
withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl
IfaceDecl
d1 withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl
`withRolesFrom` IfaceDecl
d2
| Just [Role]
roles1 <- IfaceDecl -> Maybe [Role]
ifMaybeRoles IfaceDecl
d1
, Just [Role]
roles2 <- IfaceDecl -> Maybe [Role]
ifMaybeRoles IfaceDecl
d2
, Bool -> Bool
not (IfaceDecl -> Bool
isRepInjectiveIfaceDecl IfaceDecl
d1 Bool -> Bool -> Bool
|| IfaceDecl -> Bool
isRepInjectiveIfaceDecl IfaceDecl
d2)
= IfaceDecl
d1 { ifRoles = mergeRoles roles1 roles2 }
| Bool
otherwise = IfaceDecl
d1
where
mergeRoles :: [c] -> [c] -> [c]
mergeRoles [c]
roles1 [c]
roles2 = String -> (c -> c -> c) -> [c] -> [c] -> [c]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"mergeRoles" c -> c -> c
forall a. Ord a => a -> a -> a
max [c]
roles1 [c]
roles2
isRepInjectiveIfaceDecl :: IfaceDecl -> Bool
isRepInjectiveIfaceDecl :: IfaceDecl -> Bool
isRepInjectiveIfaceDecl IfaceData{ ifCons :: IfaceDecl -> IfaceConDecls
ifCons = IfDataTyCon{} } = Bool
True
isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav :: IfaceDecl -> IfaceFamTyConFlav
ifFamFlav = IfaceFamTyConFlav
IfaceDataFamilyTyCon } = Bool
True
isRepInjectiveIfaceDecl IfaceDecl
_ = Bool
False
mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp
mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp
mergeIfaceClassOp op1 :: IfaceClassOp
op1@(IfaceClassOp Name
_ IfaceType
_ (Just DefMethSpec IfaceType
_)) IfaceClassOp
_ = IfaceClassOp
op1
mergeIfaceClassOp IfaceClassOp
_ IfaceClassOp
op2 = IfaceClassOp
op2
mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl
mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl
mergeIfaceDecls = (IfaceDecl -> IfaceDecl -> IfaceDecl)
-> OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl
forall a. (a -> a -> a) -> OccEnv a -> OccEnv a -> OccEnv a
plusOccEnv_C IfaceDecl -> IfaceDecl -> IfaceDecl
mergeIfaceDecl
typecheckIfacesForMerging :: Module -> [ModIface] -> (KnotVars (IORef TypeEnv)) -> IfM lcl (TypeEnv, [ModDetails])
typecheckIfacesForMerging :: forall lcl.
Module
-> [ModIface]
-> KnotVars (IORef TypeEnv)
-> IfM lcl (TypeEnv, [ModDetails])
typecheckIfacesForMerging Module
mod [ModIface]
ifaces KnotVars (IORef TypeEnv)
tc_env_vars =
Module
-> SDoc
-> IsBootInterface
-> IfL (TypeEnv, [ModDetails])
-> IfM lcl (TypeEnv, [ModDetails])
forall a lcl.
Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
initIfaceLcl Module
mod (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"typecheckIfacesForMerging") IsBootInterface
NotBoot (IfL (TypeEnv, [ModDetails]) -> IfM lcl (TypeEnv, [ModDetails]))
-> IfL (TypeEnv, [ModDetails]) -> IfM lcl (TypeEnv, [ModDetails])
forall a b. (a -> b) -> a -> b
$ do
ignore_prags <- GeneralFlag -> TcRnIf IfGblEnv IfLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_IgnoreInterfacePragmas
let mk_decl_env [IfaceDecl]
decls
= [(OccName, IfaceDecl)] -> OccEnv IfaceDecl
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv [ (IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfaceDecl
decl, IfaceDecl
decl)
| IfaceDecl
decl <- [IfaceDecl]
decls
, case IfaceDecl
decl of
IfaceId { ifIdDetails :: IfaceDecl -> IfaceIdDetails
ifIdDetails = IfaceIdDetails
IfDFunId } -> Bool
False
IfaceDecl
_ -> Bool
True ]
decl_envs = (ModIface -> OccEnv IfaceDecl) -> [ModIface] -> [OccEnv IfaceDecl]
forall a b. (a -> b) -> [a] -> [b]
map ([IfaceDecl] -> OccEnv IfaceDecl
mk_decl_env ([IfaceDecl] -> OccEnv IfaceDecl)
-> (ModIface -> [IfaceDecl]) -> ModIface -> OccEnv IfaceDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Fingerprint, IfaceDecl) -> IfaceDecl)
-> [(Fingerprint, IfaceDecl)] -> [IfaceDecl]
forall a b. (a -> b) -> [a] -> [b]
map (Fingerprint, IfaceDecl) -> IfaceDecl
forall a b. (a, b) -> b
snd ([(Fingerprint, IfaceDecl)] -> [IfaceDecl])
-> (ModIface -> [(Fingerprint, IfaceDecl)])
-> ModIface
-> [IfaceDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> [(Fingerprint, IfaceDecl)]
ModIface -> [IfaceDeclExts 'ModIfaceFinal]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceDeclExts phase]
mi_decls) [ModIface]
ifaces
:: [OccEnv IfaceDecl]
decl_env = (OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl)
-> OccEnv IfaceDecl -> [OccEnv IfaceDecl] -> OccEnv IfaceDecl
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl
mergeIfaceDecls OccEnv IfaceDecl
forall a. OccEnv a
emptyOccEnv [OccEnv IfaceDecl]
decl_envs
:: OccEnv IfaceDecl
names_w_things <- tcIfaceDecls ignore_prags (map (\IfaceDecl
x -> (Fingerprint
fingerprint0, IfaceDecl
x))
(nonDetOccEnvElts decl_env))
let global_type_env = [(Name, TyThing)] -> TypeEnv
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name, TyThing)]
names_w_things
case lookupKnotVars tc_env_vars mod of
Just IORef TypeEnv
tc_env_var -> IORef TypeEnv -> TypeEnv -> TcRnIf IfGblEnv IfLclEnv ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar IORef TypeEnv
tc_env_var TypeEnv
global_type_env
Maybe (IORef TypeEnv)
Nothing -> () -> TcRnIf IfGblEnv IfLclEnv ()
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
details <- forM ifaces $ \ModIface
iface -> do
type_env <- (TypeEnv -> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv)
-> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM ((TypeEnv -> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv)
-> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv)
-> (TypeEnv -> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv)
-> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv
forall a b. (a -> b) -> a -> b
$ \TypeEnv
type_env ->
TypeEnv
-> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv
-> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv
forall a. TypeEnv -> IfL a -> IfL a
setImplicitEnvM TypeEnv
type_env (IOEnv (Env IfGblEnv IfLclEnv) TypeEnv
-> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv)
-> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv
-> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv
forall a b. (a -> b) -> a -> b
$ do
decls <- Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name, TyThing)]
tcIfaceDecls Bool
ignore_prags (ModIface -> [IfaceDeclExts 'ModIfaceFinal]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceDeclExts phase]
mi_decls ModIface
iface)
return (mkNameEnv decls)
setImplicitEnvM type_env $ do
defaults <- mapM (tcIfaceDefault $ mi_semantic_module iface) (mi_defaults iface)
insts <- mapM tcIfaceInst (mi_insts iface)
fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
rules <- tcIfaceRules ignore_prags (mi_rules iface)
anns <- tcIfaceAnnotations (mi_anns iface)
exports <- ifaceExportNames (mi_exports iface)
complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
return $ ModDetails { md_types = type_env
, md_defaults = defaultEnv defaults
, md_insts = mkInstEnv insts
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
, md_exports = exports
, md_complete_matches = complete_matches
}
return (global_type_env, details)
typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails
typecheckIfaceForInstantiate :: forall lcl. NameShape -> ModIface -> IfM lcl ModDetails
typecheckIfaceForInstantiate NameShape
nsubst ModIface
iface
| let iface_mod :: Module
iface_mod = ModIface -> Module
forall (a :: ModIfacePhase). ModIface_ a -> Module
mi_semantic_module ModIface
iface
= Module
-> SDoc
-> IsBootInterface
-> NameShape
-> IfL ModDetails
-> IfM lcl ModDetails
forall a lcl.
Module
-> SDoc -> IsBootInterface -> NameShape -> IfL a -> IfM lcl a
initIfaceLclWithSubst Module
iface_mod
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"typecheckIfaceForInstantiate")
(ModIface -> IsBootInterface
mi_boot ModIface
iface) NameShape
nsubst (IfL ModDetails -> IfM lcl ModDetails)
-> IfL ModDetails -> IfM lcl ModDetails
forall a b. (a -> b) -> a -> b
$ do
ignore_prags <- GeneralFlag -> TcRnIf IfGblEnv IfLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_IgnoreInterfacePragmas
type_env <- fixM $ \TypeEnv
type_env ->
TypeEnv
-> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv
-> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv
forall a. TypeEnv -> IfL a -> IfL a
setImplicitEnvM TypeEnv
type_env (IOEnv (Env IfGblEnv IfLclEnv) TypeEnv
-> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv)
-> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv
-> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv
forall a b. (a -> b) -> a -> b
$ do
decls <- Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name, TyThing)]
tcIfaceDecls Bool
ignore_prags (ModIface -> [IfaceDeclExts 'ModIfaceFinal]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceDeclExts phase]
mi_decls ModIface
iface)
return (mkNameEnv decls)
setImplicitEnvM type_env $ do
defaults <- mapM (tcIfaceDefault iface_mod) (mi_defaults iface)
insts <- mapM tcIfaceInst (mi_insts iface)
fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
rules <- tcIfaceRules ignore_prags (mi_rules iface)
anns <- tcIfaceAnnotations (mi_anns iface)
exports <- ifaceExportNames (mi_exports iface)
complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
return $ ModDetails { md_types = type_env
, md_defaults = defaultEnv defaults
, md_insts = mkInstEnv insts
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
, md_exports = exports
, md_complete_matches = complete_matches
}
tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo
tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo
tcHiBootIface HscSource
hsc_src Module
mod
| HscSource
HsBootFile <- HscSource
hsc_src
= SelfBootInfo -> TcRn SelfBootInfo
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return SelfBootInfo
NoSelfBoot
| Bool
otherwise
= do { SDoc -> TcRnIf TcGblEnv TcLclEnv ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"loadHiBootInterface" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)
; mode <- TcRnIf TcGblEnv TcLclEnv GhcMode
forall gbl lcl. TcRnIf gbl lcl GhcMode
getGhcMode
; if not (isOneShot mode)
then do { (_, hug) <- getEpsAndHug
; case lookupHugByModule mod hug of
Just HomeModInfo
info | ModIface -> IsBootInterface
mi_boot (HomeModInfo -> ModIface
hm_iface HomeModInfo
info) IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot
-> SelfBootInfo -> TcRn SelfBootInfo
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SelfBootInfo -> TcRn SelfBootInfo)
-> SelfBootInfo -> TcRn SelfBootInfo
forall a b. (a -> b) -> a -> b
$ SelfBoot { sb_mds :: ModDetails
sb_mds = HomeModInfo -> ModDetails
hm_details HomeModInfo
info }
Maybe HomeModInfo
_ -> SelfBootInfo -> TcRn SelfBootInfo
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return SelfBootInfo
NoSelfBoot }
else do
{ hsc_env <- getTopEnv
; read_result <- liftIO $ findAndReadIface hsc_env need
(fst (getModuleInstantiation mod)) mod
IsBoot
; case read_result of {
Succeeded (ModIface
iface, ModLocation
_path) ->
do { tc_iface <- IfG ModDetails -> TcRn ModDetails
forall a. IfG a -> TcRn a
initIfaceTcRn (IfG ModDetails -> TcRn ModDetails)
-> IfG ModDetails -> TcRn ModDetails
forall a b. (a -> b) -> a -> b
$ ModIface -> IfG ModDetails
typecheckIface ModIface
iface
; return $ SelfBoot { sb_mds = tc_iface } } ;
Failed MissingInterfaceError
err ->
do { eps <- TcRnIf TcGblEnv TcLclEnv ExternalPackageState
forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps
; case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of
Maybe ModuleNameWithIsBoot
Nothing -> SelfBootInfo -> TcRn SelfBootInfo
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return SelfBootInfo
NoSelfBoot
Just (GWIB { gwib_isBoot :: forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot = IsBootInterface
is_boot }) -> case IsBootInterface
is_boot of
IsBootInterface
IsBoot ->
let diag :: IfaceMessage
diag = MissingInterfaceError -> InterfaceLookingFor -> IfaceMessage
Can'tFindInterface MissingInterfaceError
err
(Module -> InterfaceLookingFor
LookingForHiBoot Module
mod)
in TcRnMessage -> TcRn SelfBootInfo
forall a. TcRnMessage -> TcM a
failWithTc (IfaceMessage -> TcRnMessage
TcRnInterfaceError IfaceMessage
diag)
IsBootInterface
NotBoot -> TcRnMessage -> TcRn SelfBootInfo
forall a. TcRnMessage -> TcM a
failWithTc (IfaceMessage -> TcRnMessage
TcRnInterfaceError (Module -> IfaceMessage
CircularImport Module
mod))
}}}}
where
need :: SDoc
need = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Need the hi-boot interface for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"to compare against the Real Thing"
tcIfaceDecl :: Bool
-> IfaceDecl
-> IfL TyThing
tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing
tcIfaceDecl = Maybe Class -> Bool -> IfaceDecl -> IfL TyThing
tc_iface_decl Maybe Class
forall a. Maybe a
Nothing
tc_iface_decl :: Maybe Class
-> Bool
-> IfaceDecl
-> IfL TyThing
tc_iface_decl :: Maybe Class -> Bool -> IfaceDecl -> IfL TyThing
tc_iface_decl Maybe Class
_ Bool
ignore_prags (IfaceId {ifName :: IfaceDecl -> Name
ifName = Name
name, ifType :: IfaceDecl -> IfaceType
ifType = IfaceType
iface_type,
ifIdDetails :: IfaceDecl -> IfaceIdDetails
ifIdDetails = IfaceIdDetails
details, ifIdInfo :: IfaceDecl -> IfaceIdInfo
ifIdInfo = IfaceIdInfo
info})
= do { ty <- IfaceType -> IfL Type
tcIfaceType IfaceType
iface_type
; details <- tcIdDetails name ty details
; info <- tcIdInfo ignore_prags TopLevel name ty info
; return (AnId (mkGlobalId details name ty info)) }
tc_iface_decl Maybe Class
_ Bool
_ (IfaceData {ifName :: IfaceDecl -> Name
ifName = Name
tc_name,
ifCType :: IfaceDecl -> Maybe CType
ifCType = Maybe CType
cType,
ifBinders :: IfaceDecl -> [IfaceTyConBinder]
ifBinders = [IfaceTyConBinder]
binders,
ifResKind :: IfaceDecl -> IfaceType
ifResKind = IfaceType
res_kind,
ifRoles :: IfaceDecl -> [Role]
ifRoles = [Role]
roles,
ifCtxt :: IfaceDecl -> IfaceContext
ifCtxt = IfaceContext
ctxt, ifGadtSyntax :: IfaceDecl -> Bool
ifGadtSyntax = Bool
gadt_syn,
ifCons :: IfaceDecl -> IfaceConDecls
ifCons = IfaceConDecls
rdr_cons,
ifParent :: IfaceDecl -> IfaceTyConParent
ifParent = IfaceTyConParent
mb_parent })
= [IfaceTyConBinder] -> ([TyConBinder] -> IfL TyThing) -> IfL TyThing
forall a. [IfaceTyConBinder] -> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders_AT [IfaceTyConBinder]
binders (([TyConBinder] -> IfL TyThing) -> IfL TyThing)
-> ([TyConBinder] -> IfL TyThing) -> IfL TyThing
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
binders' -> do
{ res_kind' <- IfaceType -> IfL Type
tcIfaceType IfaceType
res_kind
; tycon <- fixM $ \ TyCon
tycon -> do
{ stupid_theta <- IfaceContext -> IfL ThetaType
tcIfaceCtxt IfaceContext
ctxt
; parent' <- tc_parent tc_name mb_parent
; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons
; return (mkAlgTyCon tc_name binders' res_kind'
roles cType stupid_theta
cons parent' gadt_syn) }
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
where
tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav
tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav
tc_parent Name
tc_name IfaceTyConParent
IfNoParent
= do { tc_rep_name <- Name -> TcRnIf IfGblEnv IfLclEnv Name
forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tc_name
; return (VanillaAlgTyCon tc_rep_name) }
tc_parent Name
_ (IfDataInstance Name
ax_name IfaceTyCon
_ IfaceAppArgs
arg_tys)
= do { ax <- Name -> IfL (CoAxiom Unbranched)
tcIfaceUnbranchedAxiom Name
ax_name
; let fam_tc = CoAxiom Unbranched -> TyCon
forall (br :: BranchFlag). CoAxiom br -> TyCon
coAxiomTyCon CoAxiom Unbranched
ax
; lhs_tys <- tcIfaceAppArgs arg_tys
; return (DataFamInstTyCon ax fam_tc lhs_tys) }
tc_iface_decl Maybe Class
_ Bool
_ (IfaceSynonym {ifName :: IfaceDecl -> Name
ifName = Name
tc_name,
ifRoles :: IfaceDecl -> [Role]
ifRoles = [Role]
roles,
ifSynRhs :: IfaceDecl -> IfaceType
ifSynRhs = IfaceType
rhs_ty,
ifBinders :: IfaceDecl -> [IfaceTyConBinder]
ifBinders = [IfaceTyConBinder]
binders,
ifResKind :: IfaceDecl -> IfaceType
ifResKind = IfaceType
res_kind })
= [IfaceTyConBinder] -> ([TyConBinder] -> IfL TyThing) -> IfL TyThing
forall a. [IfaceTyConBinder] -> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders_AT [IfaceTyConBinder]
binders (([TyConBinder] -> IfL TyThing) -> IfL TyThing)
-> ([TyConBinder] -> IfL TyThing) -> IfL TyThing
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
binders' -> do
{ res_kind' <- IfaceType -> IfL Type
tcIfaceType IfaceType
res_kind
; rhs <- forkM (mk_doc tc_name) $
tcIfaceType rhs_ty
; let tycon = Name -> [TyConBinder] -> Type -> [Role] -> Type -> TyCon
buildSynTyCon Name
tc_name [TyConBinder]
binders' Type
res_kind' [Role]
roles Type
rhs
; return (ATyCon tycon) }
where
mk_doc :: a -> SDoc
mk_doc a
n = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Type synonym" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
n
tc_iface_decl Maybe Class
parent Bool
_ (IfaceFamily {ifName :: IfaceDecl -> Name
ifName = Name
tc_name,
ifFamFlav :: IfaceDecl -> IfaceFamTyConFlav
ifFamFlav = IfaceFamTyConFlav
fam_flav,
ifBinders :: IfaceDecl -> [IfaceTyConBinder]
ifBinders = [IfaceTyConBinder]
binders,
ifResKind :: IfaceDecl -> IfaceType
ifResKind = IfaceType
res_kind,
ifResVar :: IfaceDecl -> Maybe IfLclName
ifResVar = Maybe IfLclName
res, ifFamInj :: IfaceDecl -> Injectivity
ifFamInj = Injectivity
inj })
= [IfaceTyConBinder] -> ([TyConBinder] -> IfL TyThing) -> IfL TyThing
forall a. [IfaceTyConBinder] -> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders_AT [IfaceTyConBinder]
binders (([TyConBinder] -> IfL TyThing) -> IfL TyThing)
-> ([TyConBinder] -> IfL TyThing) -> IfL TyThing
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
binders' -> do
{ res_kind' <- IfaceType -> IfL Type
tcIfaceType IfaceType
res_kind
; rhs <- forkM (mk_doc tc_name) $
tc_fam_flav tc_name fam_flav
; res_name <- traverse (newIfaceName . mkTyVarOccFS . ifLclNameFS) res
; let tycon = Name
-> [TyConBinder]
-> Type
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon Name
tc_name [TyConBinder]
binders' Type
res_kind' Maybe Name
res_name FamTyConFlav
rhs Maybe Class
parent Injectivity
inj
; return (ATyCon tycon) }
where
mk_doc :: a -> SDoc
mk_doc a
n = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Type synonym" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
n
tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav
tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav
tc_fam_flav Name
tc_name IfaceFamTyConFlav
IfaceDataFamilyTyCon
= do { tc_rep_name <- Name -> TcRnIf IfGblEnv IfLclEnv Name
forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tc_name
; return (DataFamilyTyCon tc_rep_name) }
tc_fam_flav Name
_ IfaceFamTyConFlav
IfaceOpenSynFamilyTyCon= FamTyConFlav -> IfL FamTyConFlav
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return FamTyConFlav
OpenSynFamilyTyCon
tc_fam_flav Name
_ (IfaceClosedSynFamilyTyCon Maybe (Name, [IfaceAxBranch])
mb_ax_name_branches)
= do { ax <- ((Name, [IfaceAxBranch])
-> IOEnv (Env IfGblEnv IfLclEnv) (CoAxiom Branched))
-> Maybe (Name, [IfaceAxBranch])
-> IOEnv (Env IfGblEnv IfLclEnv) (Maybe (CoAxiom Branched))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Name -> IOEnv (Env IfGblEnv IfLclEnv) (CoAxiom Branched)
tcIfaceBranchedAxiom (Name -> IOEnv (Env IfGblEnv IfLclEnv) (CoAxiom Branched))
-> ((Name, [IfaceAxBranch]) -> Name)
-> (Name, [IfaceAxBranch])
-> IOEnv (Env IfGblEnv IfLclEnv) (CoAxiom Branched)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, [IfaceAxBranch]) -> Name
forall a b. (a, b) -> a
fst) Maybe (Name, [IfaceAxBranch])
mb_ax_name_branches
; return (ClosedSynFamilyTyCon ax) }
tc_fam_flav Name
_ IfaceFamTyConFlav
IfaceAbstractClosedSynFamilyTyCon
= FamTyConFlav -> IfL FamTyConFlav
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return FamTyConFlav
AbstractClosedSynFamilyTyCon
tc_fam_flav Name
_ IfaceFamTyConFlav
IfaceBuiltInSynFamTyCon
= String -> SDoc -> IfL FamTyConFlav
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tc_iface_decl"
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"IfaceBuiltInSynFamTyCon in interface file")
tc_iface_decl Maybe Class
_parent Bool
_ignore_prags
(IfaceClass {ifName :: IfaceDecl -> Name
ifName = Name
tc_name,
ifRoles :: IfaceDecl -> [Role]
ifRoles = [Role]
roles,
ifBinders :: IfaceDecl -> [IfaceTyConBinder]
ifBinders = [IfaceTyConBinder]
binders,
ifFDs :: IfaceDecl -> [FunDep IfLclName]
ifFDs = [FunDep IfLclName]
rdr_fds,
ifBody :: IfaceDecl -> IfaceClassBody
ifBody = IfaceClassBody
IfAbstractClass})
= [IfaceTyConBinder] -> ([TyConBinder] -> IfL TyThing) -> IfL TyThing
forall a. [IfaceTyConBinder] -> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders [IfaceTyConBinder]
binders (([TyConBinder] -> IfL TyThing) -> IfL TyThing)
-> ([TyConBinder] -> IfL TyThing) -> IfL TyThing
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
binders' -> do
{ fds <- (FunDep IfLclName
-> IOEnv (Env IfGblEnv IfLclEnv) (FunDep CoreBndr))
-> [FunDep IfLclName]
-> IOEnv (Env IfGblEnv IfLclEnv) [FunDep CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM FunDep IfLclName -> IOEnv (Env IfGblEnv IfLclEnv) (FunDep CoreBndr)
tc_fd [FunDep IfLclName]
rdr_fds
; cls <- buildClass tc_name binders' roles fds Nothing
; return (ATyCon (classTyCon cls)) }
tc_iface_decl Maybe Class
_parent Bool
ignore_prags
(IfaceClass {ifName :: IfaceDecl -> Name
ifName = Name
tc_name,
ifRoles :: IfaceDecl -> [Role]
ifRoles = [Role]
roles,
ifBinders :: IfaceDecl -> [IfaceTyConBinder]
ifBinders = [IfaceTyConBinder]
binders,
ifFDs :: IfaceDecl -> [FunDep IfLclName]
ifFDs = [FunDep IfLclName]
rdr_fds,
ifBody :: IfaceDecl -> IfaceClassBody
ifBody = IfConcreteClass {
ifClassCtxt :: IfaceClassBody -> IfaceContext
ifClassCtxt = IfaceContext
rdr_ctxt,
ifATs :: IfaceClassBody -> [IfaceAT]
ifATs = [IfaceAT]
rdr_ats, ifSigs :: IfaceClassBody -> [IfaceClassOp]
ifSigs = [IfaceClassOp]
rdr_sigs,
ifMinDef :: IfaceClassBody -> IfaceBooleanFormula
ifMinDef = IfaceBooleanFormula
if_mindef
}})
= [IfaceTyConBinder] -> ([TyConBinder] -> IfL TyThing) -> IfL TyThing
forall a. [IfaceTyConBinder] -> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders [IfaceTyConBinder]
binders (([TyConBinder] -> IfL TyThing) -> IfL TyThing)
-> ([TyConBinder] -> IfL TyThing) -> IfL TyThing
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
binders' -> do
{ SDoc -> TcRnIf IfGblEnv IfLclEnv ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tc-iface-class1" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
; ctxt <- (IfaceType -> IfL Type) -> IfaceContext -> IfL ThetaType
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceType -> IfL Type
tc_sc IfaceContext
rdr_ctxt
; traceIf (text "tc-iface-class2" <+> ppr tc_name)
; sigs <- mapM tc_sig rdr_sigs
; fds <- mapM tc_fd rdr_fds
; traceIf (text "tc-iface-class3" <+> ppr tc_name)
; mindef <- tc_boolean_formula if_mindef
; cls <- fixM $ \ Class
cls -> do
{ ats <- (IfaceAT -> IOEnv (Env IfGblEnv IfLclEnv) ClassATItem)
-> [IfaceAT] -> IOEnv (Env IfGblEnv IfLclEnv) [ClassATItem]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Class -> IfaceAT -> IOEnv (Env IfGblEnv IfLclEnv) ClassATItem
tc_at Class
cls) [IfaceAT]
rdr_ats
; traceIf (text "tc-iface-class4" <+> ppr tc_name)
; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) }
; return (ATyCon (classTyCon cls)) }
where
tc_sc :: IfaceType -> IfL Type
tc_sc IfaceType
pred = SDoc -> IfL Type -> IfL Type
forall a. SDoc -> IfL a -> IfL a
forkM (IfaceType -> SDoc
forall a. Outputable a => a -> SDoc
mk_sc_doc IfaceType
pred) (IfaceType -> IfL Type
tcIfaceType IfaceType
pred)
tc_sig :: IfaceClassOp -> IfL TcMethInfo
tc_sig :: IfaceClassOp -> IOEnv (Env IfGblEnv IfLclEnv) (KnotTied MethInfo)
tc_sig (IfaceClassOp Name
op_name IfaceType
rdr_ty Maybe (DefMethSpec IfaceType)
dm)
= do { let doc :: SDoc
doc = Name -> IfaceType -> SDoc
forall {a} {a}. (Outputable a, Outputable a) => a -> a -> SDoc
mk_op_doc Name
op_name IfaceType
rdr_ty
; op_ty <- SDoc -> IfL Type -> IfL Type
forall a. SDoc -> IfL a -> IfL a
forkM (SDoc
doc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ty") (IfL Type -> IfL Type) -> IfL Type -> IfL Type
forall a b. (a -> b) -> a -> b
$ IfaceType -> IfL Type
tcIfaceType IfaceType
rdr_ty
; dm' <- tc_dm doc dm
; return (op_name, op_ty, dm') }
tc_dm :: SDoc
-> Maybe (DefMethSpec IfaceType)
-> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
tc_dm :: SDoc
-> Maybe (DefMethSpec IfaceType)
-> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
tc_dm SDoc
_ Maybe (DefMethSpec IfaceType)
Nothing = Maybe (DefMethSpec (SrcSpan, Type))
-> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (DefMethSpec (SrcSpan, Type))
forall a. Maybe a
Nothing
tc_dm SDoc
_ (Just DefMethSpec IfaceType
VanillaDM) = Maybe (DefMethSpec (SrcSpan, Type))
-> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DefMethSpec (SrcSpan, Type) -> Maybe (DefMethSpec (SrcSpan, Type))
forall a. a -> Maybe a
Just DefMethSpec (SrcSpan, Type)
forall ty. DefMethSpec ty
VanillaDM)
tc_dm SDoc
doc (Just (GenericDM IfaceType
ty))
= do {
; ty' <- SDoc -> IfL Type -> IfL Type
forall a. SDoc -> IfL a -> IfL a
forkM (SDoc
doc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dm") (IfL Type -> IfL Type) -> IfL Type -> IfL Type
forall a b. (a -> b) -> a -> b
$ IfaceType -> IfL Type
tcIfaceType IfaceType
ty
; return (Just (GenericDM (noSrcSpan, ty'))) }
tc_at :: Class -> IfaceAT -> IOEnv (Env IfGblEnv IfLclEnv) ClassATItem
tc_at Class
cls (IfaceAT IfaceDecl
tc_decl Maybe IfaceType
if_def)
= do ATyCon tc <- Maybe Class -> Bool -> IfaceDecl -> IfL TyThing
tc_iface_decl (Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls) Bool
ignore_prags IfaceDecl
tc_decl
mb_def <- case if_def of
Maybe IfaceType
Nothing -> Maybe (Type, TyFamEqnValidityInfo)
-> IOEnv
(Env IfGblEnv IfLclEnv) (Maybe (Type, TyFamEqnValidityInfo))
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Type, TyFamEqnValidityInfo)
forall a. Maybe a
Nothing
Just IfaceType
def -> SDoc
-> IOEnv
(Env IfGblEnv IfLclEnv) (Maybe (Type, TyFamEqnValidityInfo))
-> IOEnv
(Env IfGblEnv IfLclEnv) (Maybe (Type, TyFamEqnValidityInfo))
forall a. SDoc -> IfL a -> IfL a
forkM (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
mk_at_doc TyCon
tc) (IOEnv (Env IfGblEnv IfLclEnv) (Maybe (Type, TyFamEqnValidityInfo))
-> IOEnv
(Env IfGblEnv IfLclEnv) (Maybe (Type, TyFamEqnValidityInfo)))
-> IOEnv
(Env IfGblEnv IfLclEnv) (Maybe (Type, TyFamEqnValidityInfo))
-> IOEnv
(Env IfGblEnv IfLclEnv) (Maybe (Type, TyFamEqnValidityInfo))
forall a b. (a -> b) -> a -> b
$
[CoreBndr]
-> IOEnv
(Env IfGblEnv IfLclEnv) (Maybe (Type, TyFamEqnValidityInfo))
-> IOEnv
(Env IfGblEnv IfLclEnv) (Maybe (Type, TyFamEqnValidityInfo))
forall a. [CoreBndr] -> IfL a -> IfL a
extendIfaceTyVarEnv (TyCon -> [CoreBndr]
tyConTyVars TyCon
tc) (IOEnv (Env IfGblEnv IfLclEnv) (Maybe (Type, TyFamEqnValidityInfo))
-> IOEnv
(Env IfGblEnv IfLclEnv) (Maybe (Type, TyFamEqnValidityInfo)))
-> IOEnv
(Env IfGblEnv IfLclEnv) (Maybe (Type, TyFamEqnValidityInfo))
-> IOEnv
(Env IfGblEnv IfLclEnv) (Maybe (Type, TyFamEqnValidityInfo))
forall a b. (a -> b) -> a -> b
$
do { tc_def <- IfaceType -> IfL Type
tcIfaceType IfaceType
def
; return (Just (tc_def, NoVI)) }
return (ATI tc mb_def)
tc_boolean_formula :: IfaceBooleanFormula -> IfL (BooleanFormula GhcRn)
tc_boolean_formula :: IfaceBooleanFormula -> IfL ClassMinimalDef
tc_boolean_formula (IfAnd [IfaceBooleanFormula]
ibfs ) = [LBooleanFormula GhcRn] -> ClassMinimalDef
[GenLocated SrcSpanAnnL ClassMinimalDef] -> ClassMinimalDef
forall p. [LBooleanFormula p] -> BooleanFormula p
BF.And ([GenLocated SrcSpanAnnL ClassMinimalDef] -> ClassMinimalDef)
-> ([ClassMinimalDef] -> [GenLocated SrcSpanAnnL ClassMinimalDef])
-> [ClassMinimalDef]
-> ClassMinimalDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClassMinimalDef -> GenLocated SrcSpanAnnL ClassMinimalDef)
-> [ClassMinimalDef] -> [GenLocated SrcSpanAnnL ClassMinimalDef]
forall a b. (a -> b) -> [a] -> [b]
map ClassMinimalDef -> GenLocated SrcSpanAnnL ClassMinimalDef
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA ([ClassMinimalDef] -> ClassMinimalDef)
-> IOEnv (Env IfGblEnv IfLclEnv) [ClassMinimalDef]
-> IfL ClassMinimalDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IfaceBooleanFormula -> IfL ClassMinimalDef)
-> [IfaceBooleanFormula]
-> IOEnv (Env IfGblEnv IfLclEnv) [ClassMinimalDef]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse IfaceBooleanFormula -> IfL ClassMinimalDef
tc_boolean_formula [IfaceBooleanFormula]
ibfs
tc_boolean_formula (IfOr [IfaceBooleanFormula]
ibfs ) = [LBooleanFormula GhcRn] -> ClassMinimalDef
[GenLocated SrcSpanAnnL ClassMinimalDef] -> ClassMinimalDef
forall p. [LBooleanFormula p] -> BooleanFormula p
BF.Or ([GenLocated SrcSpanAnnL ClassMinimalDef] -> ClassMinimalDef)
-> ([ClassMinimalDef] -> [GenLocated SrcSpanAnnL ClassMinimalDef])
-> [ClassMinimalDef]
-> ClassMinimalDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClassMinimalDef -> GenLocated SrcSpanAnnL ClassMinimalDef)
-> [ClassMinimalDef] -> [GenLocated SrcSpanAnnL ClassMinimalDef]
forall a b. (a -> b) -> [a] -> [b]
map ClassMinimalDef -> GenLocated SrcSpanAnnL ClassMinimalDef
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA ([ClassMinimalDef] -> ClassMinimalDef)
-> IOEnv (Env IfGblEnv IfLclEnv) [ClassMinimalDef]
-> IfL ClassMinimalDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IfaceBooleanFormula -> IfL ClassMinimalDef)
-> [IfaceBooleanFormula]
-> IOEnv (Env IfGblEnv IfLclEnv) [ClassMinimalDef]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse IfaceBooleanFormula -> IfL ClassMinimalDef
tc_boolean_formula [IfaceBooleanFormula]
ibfs
tc_boolean_formula (IfParens IfaceBooleanFormula
ibf) = LBooleanFormula GhcRn -> ClassMinimalDef
GenLocated SrcSpanAnnL ClassMinimalDef -> ClassMinimalDef
forall p. LBooleanFormula p -> BooleanFormula p
BF.Parens (GenLocated SrcSpanAnnL ClassMinimalDef -> ClassMinimalDef)
-> (ClassMinimalDef -> GenLocated SrcSpanAnnL ClassMinimalDef)
-> ClassMinimalDef
-> ClassMinimalDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassMinimalDef -> GenLocated SrcSpanAnnL ClassMinimalDef
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (ClassMinimalDef -> ClassMinimalDef)
-> IfL ClassMinimalDef -> IfL ClassMinimalDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceBooleanFormula -> IfL ClassMinimalDef
tc_boolean_formula IfaceBooleanFormula
ibf
tc_boolean_formula (IfVar IfLclName
nm ) = LIdP GhcRn -> ClassMinimalDef
GenLocated SrcSpanAnnN Name -> ClassMinimalDef
forall p. LIdP p -> BooleanFormula p
BF.Var (GenLocated SrcSpanAnnN Name -> ClassMinimalDef)
-> (Name -> GenLocated SrcSpanAnnN Name) -> Name -> ClassMinimalDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> GenLocated SrcSpanAnnN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Name -> ClassMinimalDef)
-> TcRnIf IfGblEnv IfLclEnv Name -> IfL ClassMinimalDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OccName -> TcRnIf IfGblEnv IfLclEnv Name
lookupIfaceTop (OccName -> TcRnIf IfGblEnv IfLclEnv Name)
-> (IfLclName -> OccName)
-> IfLclName
-> TcRnIf IfGblEnv IfLclEnv Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> OccName
mkVarOccFS (FastString -> OccName)
-> (IfLclName -> FastString) -> IfLclName -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfLclName -> FastString
ifLclNameFS (IfLclName -> TcRnIf IfGblEnv IfLclEnv Name)
-> IfLclName -> TcRnIf IfGblEnv IfLclEnv Name
forall a b. (a -> b) -> a -> b
$ IfLclName
nm)
mk_sc_doc :: a -> SDoc
mk_sc_doc a
pred = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Superclass" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
pred
mk_at_doc :: a -> SDoc
mk_at_doc a
tc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Associated type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
tc
mk_op_doc :: a -> a -> SDoc
mk_op_doc a
op_name a
op_ty = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Class op" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
op_name, a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
op_ty]
tc_iface_decl Maybe Class
_ Bool
_ (IfaceAxiom { ifName :: IfaceDecl -> Name
ifName = Name
tc_name, ifTyCon :: IfaceDecl -> IfaceTyCon
ifTyCon = IfaceTyCon
tc
, ifAxBranches :: IfaceDecl -> [IfaceAxBranch]
ifAxBranches = [IfaceAxBranch]
branches, ifRole :: IfaceDecl -> Role
ifRole = Role
role })
= do { tc_tycon <- IfaceTyCon -> IOEnv (Env IfGblEnv IfLclEnv) TyCon
tcIfaceTyCon IfaceTyCon
tc
; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)
$ tc_ax_branches branches
; let axiom = CoAxiom { co_ax_unique :: Unique
co_ax_unique = Name -> Unique
nameUnique Name
tc_name
, co_ax_name :: Name
co_ax_name = Name
tc_name
, co_ax_tc :: TyCon
co_ax_tc = TyCon
tc_tycon
, co_ax_role :: Role
co_ax_role = Role
role
, co_ax_branches :: Branches Branched
co_ax_branches = [CoAxBranch] -> Branches Branched
manyBranches [CoAxBranch]
tc_branches
, co_ax_implicit :: Bool
co_ax_implicit = Bool
False }
; return (ACoAxiom axiom) }
tc_iface_decl Maybe Class
_ Bool
_ (IfacePatSyn{ ifName :: IfaceDecl -> Name
ifName = Name
name
, ifPatMatcher :: IfaceDecl -> (Name, Bool)
ifPatMatcher = (Name, Bool)
if_matcher
, ifPatBuilder :: IfaceDecl -> Maybe (Name, Bool)
ifPatBuilder = Maybe (Name, Bool)
if_builder
, ifPatIsInfix :: IfaceDecl -> Bool
ifPatIsInfix = Bool
is_infix
, ifPatUnivBndrs :: IfaceDecl -> [IfaceForAllSpecBndr]
ifPatUnivBndrs = [IfaceForAllSpecBndr]
univ_bndrs
, ifPatExBndrs :: IfaceDecl -> [IfaceForAllSpecBndr]
ifPatExBndrs = [IfaceForAllSpecBndr]
ex_bndrs
, ifPatProvCtxt :: IfaceDecl -> IfaceContext
ifPatProvCtxt = IfaceContext
prov_ctxt
, ifPatReqCtxt :: IfaceDecl -> IfaceContext
ifPatReqCtxt = IfaceContext
req_ctxt
, ifPatArgs :: IfaceDecl -> IfaceContext
ifPatArgs = IfaceContext
args
, ifPatTy :: IfaceDecl -> IfaceType
ifPatTy = IfaceType
pat_ty
, ifFieldLabels :: IfaceDecl -> [FieldLabel]
ifFieldLabels = [FieldLabel]
field_labels })
= do { SDoc -> TcRnIf IfGblEnv IfLclEnv ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tc_iface_decl" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
; matcher <- (Name, Bool) -> IfL (Name, Type, Bool)
tc_pr (Name, Bool)
if_matcher
; builder <- traverse tc_pr if_builder
; bindIfaceForAllBndrs univ_bndrs $ \[VarBndr CoreBndr Specificity]
univ_tvs -> do
{ [IfaceForAllSpecBndr]
-> ([VarBndr CoreBndr Specificity] -> IfL TyThing) -> IfL TyThing
forall vis a.
[VarBndr IfaceBndr vis]
-> ([VarBndr CoreBndr vis] -> IfL a) -> IfL a
bindIfaceForAllBndrs [IfaceForAllSpecBndr]
ex_bndrs (([VarBndr CoreBndr Specificity] -> IfL TyThing) -> IfL TyThing)
-> ([VarBndr CoreBndr Specificity] -> IfL TyThing) -> IfL TyThing
forall a b. (a -> b) -> a -> b
$ \[VarBndr CoreBndr Specificity]
ex_tvs -> do
{ patsyn <- SDoc -> IfL PatSyn -> IfL PatSyn
forall a. SDoc -> IfL a -> IfL a
forkM (Name -> SDoc
forall a. Outputable a => a -> SDoc
mk_doc Name
name) (IfL PatSyn -> IfL PatSyn) -> IfL PatSyn -> IfL PatSyn
forall a b. (a -> b) -> a -> b
$
do { prov_theta <- IfaceContext -> IfL ThetaType
tcIfaceCtxt IfaceContext
prov_ctxt
; req_theta <- tcIfaceCtxt req_ctxt
; pat_ty <- tcIfaceType pat_ty
; arg_tys <- mapM tcIfaceType args
; return $ buildPatSyn name is_infix matcher builder
(univ_tvs, req_theta)
(ex_tvs, prov_theta)
arg_tys pat_ty field_labels }
; return $ AConLike . PatSynCon $ patsyn }}}
where
mk_doc :: a -> SDoc
mk_doc a
n = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Pattern synonym" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
n
tc_pr :: (IfExtName, Bool) -> IfL (Name, Type, Bool)
tc_pr :: (Name, Bool) -> IfL (Name, Type, Bool)
tc_pr (Name
nm, Bool
b) = do { id <- SDoc -> IfL CoreBndr -> IfL CoreBndr
forall a. SDoc -> IfL a -> IfL a
forkM (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm) (Name -> IfL CoreBndr
tcIfaceExtId Name
nm)
; return (nm, idType id, b) }
tcTopIfaceBindings :: IORef TypeEnv -> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> IfL [CoreBind]
tcTopIfaceBindings :: IORef TypeEnv
-> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -> IfL [CoreBind]
tcTopIfaceBindings IORef TypeEnv
ty_var [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
ver_decls
= do
int <- (IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo
-> IOEnv
(Env IfGblEnv IfLclEnv) (IfaceBindingX IfaceMaybeRhs CoreBndr))
-> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> IOEnv
(Env IfGblEnv IfLclEnv) [IfaceBindingX IfaceMaybeRhs CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo
-> IOEnv
(Env IfGblEnv IfLclEnv) (IfaceBindingX IfaceMaybeRhs CoreBndr)
forall a.
IfaceBindingX a IfaceTopBndrInfo -> IfL (IfaceBindingX a CoreBndr)
tcTopBinders [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
ver_decls
let all_ids :: [Id] = concatMap toList int
liftIO $ modifyIORef ty_var (flip extendTypeEnvList (map AnId all_ids))
extendIfaceIdEnv all_ids $ mapM tc_iface_bindings int
tcTopBinders :: IfaceBindingX a IfaceTopBndrInfo -> IfL (IfaceBindingX a Id)
tcTopBinders :: forall a.
IfaceBindingX a IfaceTopBndrInfo -> IfL (IfaceBindingX a CoreBndr)
tcTopBinders = (IfaceTopBndrInfo -> IfL CoreBndr)
-> IfaceBindingX a IfaceTopBndrInfo
-> IOEnv (Env IfGblEnv IfLclEnv) (IfaceBindingX a CoreBndr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> IfaceBindingX a a -> f (IfaceBindingX a b)
traverse IfaceTopBndrInfo -> IfL CoreBndr
mk_top_id
tc_iface_bindings :: IfaceBindingX IfaceMaybeRhs Id -> IfL CoreBind
tc_iface_bindings :: IfaceBindingX IfaceMaybeRhs CoreBndr
-> IOEnv (Env IfGblEnv IfLclEnv) CoreBind
tc_iface_bindings (IfaceNonRec CoreBndr
b IfaceMaybeRhs
rhs) = do
rhs' <- CoreBndr -> IfaceMaybeRhs -> IfL CoreExpr
tc_iface_binding CoreBndr
b IfaceMaybeRhs
rhs
return $ NonRec b rhs'
tc_iface_bindings (IfaceRec [(CoreBndr, IfaceMaybeRhs)]
bs) = do
rs <- ((CoreBndr, IfaceMaybeRhs)
-> IOEnv (Env IfGblEnv IfLclEnv) (CoreBndr, CoreExpr))
-> [(CoreBndr, IfaceMaybeRhs)]
-> IOEnv (Env IfGblEnv IfLclEnv) [(CoreBndr, CoreExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(CoreBndr
b, IfaceMaybeRhs
rhs) -> (CoreBndr
b,) (CoreExpr -> (CoreBndr, CoreExpr))
-> IfL CoreExpr
-> IOEnv (Env IfGblEnv IfLclEnv) (CoreBndr, CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreBndr -> IfaceMaybeRhs -> IfL CoreExpr
tc_iface_binding CoreBndr
b IfaceMaybeRhs
rhs) [(CoreBndr, IfaceMaybeRhs)]
bs
return (Rec rs)
tc_iface_binding :: Id -> IfaceMaybeRhs -> IfL CoreExpr
tc_iface_binding :: CoreBndr -> IfaceMaybeRhs -> IfL CoreExpr
tc_iface_binding CoreBndr
i IfaceMaybeRhs
IfUseUnfoldingRhs =
case Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate (Unfolding -> Maybe CoreExpr) -> Unfolding -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Unfolding
realIdUnfolding CoreBndr
i of
Just CoreExpr
e -> CoreExpr -> IfL CoreExpr
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e
Maybe CoreExpr
Nothing -> String -> SDoc -> IfL CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tc_iface_binding" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Binding" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
i) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"had an unfolding when the interface file was created"
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"which has now gone missing, something has badly gone wrong."
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Unfolding:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Unfolding -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreBndr -> Unfolding
realIdUnfolding CoreBndr
i)])
tc_iface_binding CoreBndr
_ (IfRhs IfaceExpr
rhs) = IfaceExpr -> IfL CoreExpr
tcIfaceExpr IfaceExpr
rhs
mk_top_id :: IfaceTopBndrInfo -> IfL Id
mk_top_id :: IfaceTopBndrInfo -> IfL CoreBndr
mk_top_id (IfGblTopBndr Name
gbl_name)
| Module -> Maybe Module
forall a. a -> Maybe a
Just Module
rOOT_MAIN Maybe Module -> Maybe Module -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Maybe Module
nameModule_maybe Name
gbl_name
= do
ATyCon ioTyCon <- Name -> IfL TyThing
tcIfaceGlobal Name
ioTyConName
return $ mkExportedVanillaId gbl_name (mkTyConApp ioTyCon [unitTy])
| Bool
otherwise = Name -> IfL CoreBndr
tcIfaceExtId Name
gbl_name
mk_top_id (IfLclTopBndr IfLclName
raw_name IfaceType
iface_type IfaceIdInfo
info IfaceIdDetails
details) = do
ty <- IfaceType -> IfL Type
tcIfaceType IfaceType
iface_type
rec { details' <- tcIdDetails name ty details
; let occ = case IdDetails
details' of
RecSelId { sel_tycon :: IdDetails -> RecSelParent
sel_tycon = RecSelParent
parent }
-> let con_fs :: FastString
con_fs = Name -> FastString
forall a. NamedThing a => a -> FastString
getOccFS (Name -> FastString) -> Name -> FastString
forall a b. (a -> b) -> a -> b
$ RecSelParent -> Name
recSelFirstConName RecSelParent
parent
in FastString -> FastString -> OccName
mkRecFieldOccFS FastString
con_fs (IfLclName -> FastString
ifLclNameFS IfLclName
raw_name)
IdDetails
_ -> FastString -> OccName
mkVarOccFS (IfLclName -> FastString
ifLclNameFS IfLclName
raw_name)
; name <- newIfaceName occ }
info' <- tcIdInfo False TopLevel name ty info
let new_id = IdDetails -> Name -> Type -> IdInfo -> CoreBndr
mkGlobalId IdDetails
details' Name
name Type
ty IdInfo
info'
return new_id
tcIfaceDecls :: Bool
-> [(Fingerprint, IfaceDecl)]
-> IfL [(Name,TyThing)]
tcIfaceDecls :: Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name, TyThing)]
tcIfaceDecls Bool
ignore_prags [(Fingerprint, IfaceDecl)]
ver_decls
= ((Fingerprint, IfaceDecl) -> IfL [(Name, TyThing)])
-> [(Fingerprint, IfaceDecl)] -> IfL [(Name, TyThing)]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (Bool -> (Fingerprint, IfaceDecl) -> IfL [(Name, TyThing)]
tc_iface_decl_fingerprint Bool
ignore_prags) [(Fingerprint, IfaceDecl)]
ver_decls
tc_iface_decl_fingerprint :: Bool
-> (Fingerprint, IfaceDecl)
-> IfL [(Name,TyThing)]
tc_iface_decl_fingerprint :: Bool -> (Fingerprint, IfaceDecl) -> IfL [(Name, TyThing)]
tc_iface_decl_fingerprint Bool
ignore_prags (Fingerprint
_version, IfaceDecl
decl)
= do {
let !main_name :: Name
main_name = IfaceDecl -> Name
ifName IfaceDecl
decl
; thing <- SDoc -> IfL TyThing -> IfL TyThing
forall a. SDoc -> IfL a -> IfL a
forkM SDoc
doc (IfL TyThing -> IfL TyThing) -> IfL TyThing -> IfL TyThing
forall a b. (a -> b) -> a -> b
$ do { Name -> TcRnIf IfGblEnv IfLclEnv ()
bumpDeclStats Name
main_name
; Bool -> IfaceDecl -> IfL TyThing
tcIfaceDecl Bool
ignore_prags IfaceDecl
decl }
; let mini_env = [(OccName, TyThing)] -> OccEnv TyThing
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv [(TyThing -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyThing
t, TyThing
t) | TyThing
t <- TyThing -> [TyThing]
implicitTyThings TyThing
thing]
lookup Name
n = case OccEnv TyThing -> OccName -> Maybe TyThing
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv TyThing
mini_env (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
n) of
Just TyThing
thing -> TyThing
thing
Maybe TyThing
Nothing ->
String -> SDoc -> TyThing
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tc_iface_decl_fingerprint" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
main_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ IfaceDecl -> SDoc
forall a. Outputable a => a -> SDoc
ppr (IfaceDecl
decl))
; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl)
; return $ (main_name, thing) :
[(n, lookup n) | n <- implicit_names]
}
where
doc :: SDoc
doc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Declaration for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (IfaceDecl -> Name
ifName IfaceDecl
decl)
bumpDeclStats :: Name -> IfL ()
bumpDeclStats :: Name -> TcRnIf IfGblEnv IfLclEnv ()
bumpDeclStats Name
name
= do { SDoc -> TcRnIf IfGblEnv IfLclEnv ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Loading decl for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
; (ExternalPackageState -> ExternalPackageState)
-> TcRnIf IfGblEnv IfLclEnv ()
forall gbl lcl.
(ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl ()
updateEps_ (\ExternalPackageState
eps -> let stats :: EpsStats
stats = ExternalPackageState -> EpsStats
eps_stats ExternalPackageState
eps
in ExternalPackageState
eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
}
tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar)
tc_fd :: FunDep IfLclName -> IOEnv (Env IfGblEnv IfLclEnv) (FunDep CoreBndr)
tc_fd ([IfLclName]
tvs1, [IfLclName]
tvs2) = do { tvs1' <- (IfLclName -> IfL CoreBndr)
-> [IfLclName] -> IOEnv (Env IfGblEnv IfLclEnv) [CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfLclName -> IfL CoreBndr
tcIfaceTyVar [IfLclName]
tvs1
; tvs2' <- mapM tcIfaceTyVar tvs2
; return (tvs1', tvs2') }
tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
tc_ax_branches [IfaceAxBranch]
if_branches = ([CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch])
-> [CoAxBranch] -> [IfaceAxBranch] -> IfL [CoAxBranch]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
tc_ax_branch [] [IfaceAxBranch]
if_branches
tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
tc_ax_branch [CoAxBranch]
prev_branches
(IfaceAxBranch { ifaxbTyVars :: IfaceAxBranch -> [IfaceTvBndr]
ifaxbTyVars = [IfaceTvBndr]
tv_bndrs
, ifaxbEtaTyVars :: IfaceAxBranch -> [IfaceTvBndr]
ifaxbEtaTyVars = [IfaceTvBndr]
eta_tv_bndrs
, ifaxbCoVars :: IfaceAxBranch -> [IfaceIdBndr]
ifaxbCoVars = [IfaceIdBndr]
cv_bndrs
, ifaxbLHS :: IfaceAxBranch -> IfaceAppArgs
ifaxbLHS = IfaceAppArgs
lhs, ifaxbRHS :: IfaceAxBranch -> IfaceType
ifaxbRHS = IfaceType
rhs
, ifaxbRoles :: IfaceAxBranch -> [Role]
ifaxbRoles = [Role]
roles, ifaxbIncomps :: IfaceAxBranch -> [Arity]
ifaxbIncomps = [Arity]
incomps })
= [IfaceTyConBinder]
-> ([TyConBinder] -> IfL [CoAxBranch]) -> IfL [CoAxBranch]
forall a. [IfaceTyConBinder] -> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders_AT
((IfaceTvBndr -> IfaceTyConBinder)
-> [IfaceTvBndr] -> [IfaceTyConBinder]
forall a b. (a -> b) -> [a] -> [b]
map (\IfaceTvBndr
b -> IfaceBndr -> TyConBndrVis -> IfaceTyConBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr (IfaceTvBndr -> IfaceBndr
IfaceTvBndr IfaceTvBndr
b) (ForAllTyFlag -> TyConBndrVis
NamedTCB ForAllTyFlag
Inferred)) [IfaceTvBndr]
tv_bndrs) (([TyConBinder] -> IfL [CoAxBranch]) -> IfL [CoAxBranch])
-> ([TyConBinder] -> IfL [CoAxBranch]) -> IfL [CoAxBranch]
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
tvs ->
[IfaceIdBndr]
-> ([CoreBndr] -> IfL [CoAxBranch]) -> IfL [CoAxBranch]
forall a. [IfaceIdBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceIds [IfaceIdBndr]
cv_bndrs (([CoreBndr] -> IfL [CoAxBranch]) -> IfL [CoAxBranch])
-> ([CoreBndr] -> IfL [CoAxBranch]) -> IfL [CoAxBranch]
forall a b. (a -> b) -> a -> b
$ \ [CoreBndr]
cvs -> do
{ tc_lhs <- IfaceAppArgs -> IfL ThetaType
tcIfaceAppArgs IfaceAppArgs
lhs
; tc_rhs <- tcIfaceType rhs
; eta_tvs <- bindIfaceTyVars eta_tv_bndrs return
; this_mod <- getIfModule
; let loc = FastString -> SrcSpan
mkGeneralSrcSpan (String -> FastString
fsLit String
"module " FastString -> FastString -> FastString
`appendFS`
ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod))
br = CoAxBranch { cab_loc :: SrcSpan
cab_loc = SrcSpan
loc
, cab_tvs :: [CoreBndr]
cab_tvs = [TyConBinder] -> [CoreBndr]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tvs
, cab_eta_tvs :: [CoreBndr]
cab_eta_tvs = [CoreBndr]
eta_tvs
, cab_cvs :: [CoreBndr]
cab_cvs = [CoreBndr]
cvs
, cab_lhs :: ThetaType
cab_lhs = ThetaType
tc_lhs
, cab_roles :: [Role]
cab_roles = [Role]
roles
, cab_rhs :: Type
cab_rhs = Type
tc_rhs
, cab_incomps :: [CoAxBranch]
cab_incomps = (Arity -> CoAxBranch) -> [Arity] -> [CoAxBranch]
forall a b. (a -> b) -> [a] -> [b]
map ([CoAxBranch]
prev_branches [CoAxBranch] -> Arity -> CoAxBranch
forall a. Outputable a => [a] -> Arity -> a
`getNth`) [Arity]
incomps }
; return (prev_branches ++ [br]) }
tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs
tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs
tcIfaceDataCons Name
tycon_name TyCon
tycon [TyConBinder]
tc_tybinders IfaceConDecls
if_cons
= case IfaceConDecls
if_cons of
IfaceConDecls
IfAbstractTyCon
-> AlgTyConRhs -> IfL AlgTyConRhs
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return AlgTyConRhs
AbstractTyCon
IfDataTyCon Bool
type_data [IfaceConDecl]
cons
-> do { data_cons <- (IfaceConDecl -> IOEnv (Env IfGblEnv IfLclEnv) DataCon)
-> [IfaceConDecl] -> IOEnv (Env IfGblEnv IfLclEnv) [DataCon]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceConDecl -> IOEnv (Env IfGblEnv IfLclEnv) DataCon
tc_con_decl [IfaceConDecl]
cons
; return $
mkLevPolyDataTyConRhs
(isFixedRuntimeRepKind $ tyConResKind tycon)
type_data
data_cons }
IfNewTyCon IfaceConDecl
con
-> do { data_con <- IfaceConDecl -> IOEnv (Env IfGblEnv IfLclEnv) DataCon
tc_con_decl IfaceConDecl
con
; mkNewTyConRhs tycon_name tycon data_con }
where
univ_tvs :: [TyVar]
univ_tvs :: [CoreBndr]
univ_tvs = [TyConBinder] -> [CoreBndr]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_tybinders
tag_map :: NameEnv ConTag
tag_map :: NameEnv Arity
tag_map = TyCon -> NameEnv Arity
mkTyConTagMap TyCon
tycon
tc_con_decl :: IfaceConDecl -> IOEnv (Env IfGblEnv IfLclEnv) DataCon
tc_con_decl (IfCon { ifConInfix :: IfaceConDecl -> Bool
ifConInfix = Bool
is_infix,
ifConExTCvs :: IfaceConDecl -> [IfaceBndr]
ifConExTCvs = [IfaceBndr]
ex_bndrs,
ifConUserTvBinders :: IfaceConDecl -> [IfaceForAllSpecBndr]
ifConUserTvBinders = [IfaceForAllSpecBndr]
user_bndrs,
ifConName :: IfaceConDecl -> Name
ifConName = Name
dc_name,
ifConCtxt :: IfaceConDecl -> IfaceContext
ifConCtxt = IfaceContext
ctxt, ifConEqSpec :: IfaceConDecl -> [IfaceTvBndr]
ifConEqSpec = [IfaceTvBndr]
spec,
ifConArgTys :: IfaceConDecl -> [(IfaceType, IfaceType)]
ifConArgTys = [(IfaceType, IfaceType)]
args, ifConFields :: IfaceConDecl -> [FieldLabel]
ifConFields = [FieldLabel]
lbl_names,
ifConStricts :: IfaceConDecl -> [IfaceBang]
ifConStricts = [IfaceBang]
if_stricts,
ifConSrcStricts :: IfaceConDecl -> [IfaceSrcBang]
ifConSrcStricts = [IfaceSrcBang]
if_src_stricts})
=
[IfaceBndr]
-> ([CoreBndr] -> IOEnv (Env IfGblEnv IfLclEnv) DataCon)
-> IOEnv (Env IfGblEnv IfLclEnv) DataCon
forall a. [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceBndrs [IfaceBndr]
ex_bndrs (([CoreBndr] -> IOEnv (Env IfGblEnv IfLclEnv) DataCon)
-> IOEnv (Env IfGblEnv IfLclEnv) DataCon)
-> ([CoreBndr] -> IOEnv (Env IfGblEnv IfLclEnv) DataCon)
-> IOEnv (Env IfGblEnv IfLclEnv) DataCon
forall a b. (a -> b) -> a -> b
$ \ [CoreBndr]
ex_tvs -> do
{ SDoc -> TcRnIf IfGblEnv IfLclEnv ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Start interface-file tc_con_decl" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
dc_name)
; user_tv_bndrs <- (IfaceForAllSpecBndr
-> IOEnv (Env IfGblEnv IfLclEnv) (VarBndr CoreBndr Specificity))
-> [IfaceForAllSpecBndr]
-> IOEnv (Env IfGblEnv IfLclEnv) [VarBndr CoreBndr Specificity]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Bndr IfaceBndr
bd Specificity
vis) ->
case IfaceBndr
bd of
IfaceIdBndr (IfaceType
_, IfLclName
name, IfaceType
_) ->
CoreBndr -> Specificity -> VarBndr CoreBndr Specificity
forall var argf. var -> argf -> VarBndr var argf
Bndr (CoreBndr -> Specificity -> VarBndr CoreBndr Specificity)
-> IfL CoreBndr
-> IOEnv
(Env IfGblEnv IfLclEnv)
(Specificity -> VarBndr CoreBndr Specificity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfLclName -> IfL CoreBndr
tcIfaceLclId IfLclName
name IOEnv
(Env IfGblEnv IfLclEnv)
(Specificity -> VarBndr CoreBndr Specificity)
-> IOEnv (Env IfGblEnv IfLclEnv) Specificity
-> IOEnv (Env IfGblEnv IfLclEnv) (VarBndr CoreBndr Specificity)
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Specificity -> IOEnv (Env IfGblEnv IfLclEnv) Specificity
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Specificity
vis
IfaceTvBndr (IfLclName
name, IfaceType
_) ->
CoreBndr -> Specificity -> VarBndr CoreBndr Specificity
forall var argf. var -> argf -> VarBndr var argf
Bndr (CoreBndr -> Specificity -> VarBndr CoreBndr Specificity)
-> IfL CoreBndr
-> IOEnv
(Env IfGblEnv IfLclEnv)
(Specificity -> VarBndr CoreBndr Specificity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfLclName -> IfL CoreBndr
tcIfaceTyVar IfLclName
name IOEnv
(Env IfGblEnv IfLclEnv)
(Specificity -> VarBndr CoreBndr Specificity)
-> IOEnv (Env IfGblEnv IfLclEnv) Specificity
-> IOEnv (Env IfGblEnv IfLclEnv) (VarBndr CoreBndr Specificity)
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Specificity -> IOEnv (Env IfGblEnv IfLclEnv) Specificity
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Specificity
vis)
[IfaceForAllSpecBndr]
user_bndrs
; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
do { eq_spec <- tcIfaceEqSpec spec
; theta <- tcIfaceCtxt ctxt
; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys")
$ mapM (\(IfaceType
w, IfaceType
ty) -> Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
mkScaled (Type -> Type -> Scaled Type)
-> IfL Type -> IOEnv (Env IfGblEnv IfLclEnv) (Type -> Scaled Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceType -> IfL Type
tcIfaceType IfaceType
w IOEnv (Env IfGblEnv IfLclEnv) (Type -> Scaled Type)
-> IfL Type -> IOEnv (Env IfGblEnv IfLclEnv) (Scaled Type)
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IfaceType -> IfL Type
tcIfaceType IfaceType
ty) args
; stricts <- mapM tc_strict if_stricts
; return (eq_spec, theta, arg_tys, stricts) }
; let orig_res_ty = TyCon -> ThetaType -> Type
mkFamilyTyConApp TyCon
tycon
(Subst -> [CoreBndr] -> ThetaType
substTyCoVars ([(CoreBndr, Type)] -> Subst
mkTvSubstPrs ((EqSpec -> (CoreBndr, Type)) -> [EqSpec] -> [(CoreBndr, Type)]
forall a b. (a -> b) -> [a] -> [b]
map EqSpec -> (CoreBndr, Type)
eqSpecPair [EqSpec]
eq_spec))
([TyConBinder] -> [CoreBndr]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_tybinders))
; prom_rep_name <- newTyConRepName dc_name
; let bang_opts = [HsImplBang] -> DataConBangOpts
FixedBangOpts [HsImplBang]
stricts
; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
bang_opts
dc_name is_infix prom_rep_name
(map src_strict if_src_stricts)
lbl_names
univ_tvs ex_tvs user_tv_bndrs
eq_spec theta
arg_tys orig_res_ty tycon tag_map
; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
; return con }
mk_doc :: a -> SDoc
mk_doc a
con_name = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Constructor" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
con_name
tc_strict :: IfaceBang -> IfL HsImplBang
tc_strict :: IfaceBang -> IOEnv (Env IfGblEnv IfLclEnv) HsImplBang
tc_strict IfaceBang
IfNoBang = HsImplBang -> IOEnv (Env IfGblEnv IfLclEnv) HsImplBang
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsImplBang
HsLazy)
tc_strict IfaceBang
IfStrict = HsImplBang -> IOEnv (Env IfGblEnv IfLclEnv) HsImplBang
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> HsImplBang
HsStrict Bool
True)
tc_strict IfaceBang
IfUnpack = HsImplBang -> IOEnv (Env IfGblEnv IfLclEnv) HsImplBang
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Coercion -> HsImplBang
HsUnpack Maybe Coercion
forall a. Maybe a
Nothing)
tc_strict (IfUnpackCo IfaceCoercion
if_co) = do { co <- IfaceCoercion -> IfL Coercion
tcIfaceCo IfaceCoercion
if_co
; return (HsUnpack (Just co)) }
src_strict :: IfaceSrcBang -> HsSrcBang
src_strict :: IfaceSrcBang -> HsSrcBang
src_strict (IfSrcBang SrcUnpackedness
unpk SrcStrictness
bang) = SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
mkHsSrcBang SourceText
NoSourceText SrcUnpackedness
unpk SrcStrictness
bang
tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]
tcIfaceEqSpec :: [IfaceTvBndr] -> IfL [EqSpec]
tcIfaceEqSpec [IfaceTvBndr]
spec
= (IfaceTvBndr -> IOEnv (Env IfGblEnv IfLclEnv) EqSpec)
-> [IfaceTvBndr] -> IfL [EqSpec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceTvBndr -> IOEnv (Env IfGblEnv IfLclEnv) EqSpec
do_item [IfaceTvBndr]
spec
where
do_item :: IfaceTvBndr -> IOEnv (Env IfGblEnv IfLclEnv) EqSpec
do_item (IfLclName
occ, IfaceType
if_ty) = do { tv <- IfLclName -> IfL CoreBndr
tcIfaceTyVar IfLclName
occ
; ty <- tcIfaceType if_ty
; return (mkEqSpec tv ty) }
tcRoughTyCon :: Maybe IfaceTyCon -> RoughMatchTc
tcRoughTyCon :: Maybe IfaceTyCon -> RoughMatchTc
tcRoughTyCon (Just IfaceTyCon
tc) = Name -> RoughMatchTc
RM_KnownTc (IfaceTyCon -> Name
ifaceTyConName IfaceTyCon
tc)
tcRoughTyCon Maybe IfaceTyCon
Nothing = RoughMatchTc
RM_WildCard
tcIfaceDefaults :: Module -> [(Module, IfaceDefault)] -> IfG [NonEmpty ClassDefaults]
tcIfaceDefaults :: Module -> [(Module, IfaceDefault)] -> IfG [NonEmpty ClassDefaults]
tcIfaceDefaults Module
this_mod [(Module, IfaceDefault)]
defaults
= Module
-> SDoc
-> IsBootInterface
-> IfL [NonEmpty ClassDefaults]
-> IfG [NonEmpty ClassDefaults]
forall a lcl.
Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
initIfaceLcl Module
this_mod (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Import defaults") IsBootInterface
NotBoot
(IfL [NonEmpty ClassDefaults] -> IfG [NonEmpty ClassDefaults])
-> IfL [NonEmpty ClassDefaults] -> IfG [NonEmpty ClassDefaults]
forall a b. (a -> b) -> a -> b
$ (ClassDefaults -> ClassDefaults -> Bool)
-> [ClassDefaults] -> [NonEmpty ClassDefaults]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NE.groupBy (TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
(==) (TyCon -> TyCon -> Bool)
-> (ClassDefaults -> TyCon)
-> ClassDefaults
-> ClassDefaults
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ClassDefaults -> TyCon
cd_class)
([ClassDefaults] -> [NonEmpty ClassDefaults])
-> IOEnv (Env IfGblEnv IfLclEnv) [ClassDefaults]
-> IfL [NonEmpty ClassDefaults]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Module, IfaceDefault)
-> IOEnv (Env IfGblEnv IfLclEnv) ClassDefaults)
-> [(Module, IfaceDefault)]
-> IOEnv (Env IfGblEnv IfLclEnv) [ClassDefaults]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Module
-> IfaceDefault -> IOEnv (Env IfGblEnv IfLclEnv) ClassDefaults)
-> (Module, IfaceDefault)
-> IOEnv (Env IfGblEnv IfLclEnv) ClassDefaults
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Module
-> IfaceDefault -> IOEnv (Env IfGblEnv IfLclEnv) ClassDefaults
tcIfaceDefault) [(Module, IfaceDefault)]
defaults
tcIfaceDefault :: Module -> IfaceDefault -> IfL ClassDefaults
tcIfaceDefault :: Module
-> IfaceDefault -> IOEnv (Env IfGblEnv IfLclEnv) ClassDefaults
tcIfaceDefault Module
this_mod IfaceDefault { ifDefaultCls :: IfaceDefault -> IfaceTyCon
ifDefaultCls = IfaceTyCon
clsCon
, ifDefaultTys :: IfaceDefault -> IfaceContext
ifDefaultTys = IfaceContext
tys
, ifDefaultWarn :: IfaceDefault -> Maybe IfaceWarningTxt
ifDefaultWarn = Maybe IfaceWarningTxt
iface_warn }
= do { clsCon' <- IfaceTyCon -> IOEnv (Env IfGblEnv IfLclEnv) TyCon
tcIfaceTyCon IfaceTyCon
clsCon
; tys' <- traverse tcIfaceType tys
; let warn = (IfaceWarningTxt -> WarningTxt GhcRn)
-> Maybe IfaceWarningTxt -> Maybe (WarningTxt GhcRn)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IfaceWarningTxt -> WarningTxt GhcRn
fromIfaceWarningTxt Maybe IfaceWarningTxt
iface_warn
; return ClassDefaults { cd_class = clsCon'
, cd_types = tys'
, cd_module = Just this_mod
, cd_warn = warn } }
tcIfaceInst :: IfaceClsInst -> IfL ClsInst
tcIfaceInst :: IfaceClsInst -> IOEnv (Env IfGblEnv IfLclEnv) ClsInst
tcIfaceInst (IfaceClsInst { ifDFun :: IfaceClsInst -> Name
ifDFun = Name
dfun_name, ifOFlag :: IfaceClsInst -> OverlapFlag
ifOFlag = OverlapFlag
oflag
, ifInstCls :: IfaceClsInst -> Name
ifInstCls = Name
cls, ifInstTys :: IfaceClsInst -> [Maybe IfaceTyCon]
ifInstTys = [Maybe IfaceTyCon]
mb_tcs
, ifInstOrph :: IfaceClsInst -> IsOrphan
ifInstOrph = IsOrphan
orph, ifInstWarn :: IfaceClsInst -> Maybe IfaceWarningTxt
ifInstWarn = Maybe IfaceWarningTxt
iface_warn })
= do { dfun <- SDoc -> IfL CoreBndr -> IfL CoreBndr
forall a. SDoc -> IfL a -> IfL a
forkM (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Dict fun" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
dfun_name) (IfL CoreBndr -> IfL CoreBndr) -> IfL CoreBndr -> IfL CoreBndr
forall a b. (a -> b) -> a -> b
$
(TyThing -> CoreBndr) -> IfL TyThing -> IfL CoreBndr
forall a b.
(a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HasDebugCallStack => TyThing -> CoreBndr
TyThing -> CoreBndr
tyThingId (Name -> IfL TyThing
tcIfaceImplicit Name
dfun_name)
; let mb_tcs' = (Maybe IfaceTyCon -> RoughMatchTc)
-> [Maybe IfaceTyCon] -> [RoughMatchTc]
forall a b. (a -> b) -> [a] -> [b]
map Maybe IfaceTyCon -> RoughMatchTc
tcRoughTyCon [Maybe IfaceTyCon]
mb_tcs
warn = (IfaceWarningTxt -> WarningTxt GhcRn)
-> Maybe IfaceWarningTxt -> Maybe (WarningTxt GhcRn)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IfaceWarningTxt -> WarningTxt GhcRn
fromIfaceWarningTxt Maybe IfaceWarningTxt
iface_warn
; return (mkImportedClsInst cls mb_tcs' dfun_name dfun oflag orph warn) }
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst :: IfaceFamInst -> IOEnv (Env IfGblEnv IfLclEnv) FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstFam :: IfaceFamInst -> Name
ifFamInstFam = Name
fam, ifFamInstTys :: IfaceFamInst -> [Maybe IfaceTyCon]
ifFamInstTys = [Maybe IfaceTyCon]
mb_tcs
, ifFamInstAxiom :: IfaceFamInst -> Name
ifFamInstAxiom = Name
axiom_name
, ifFamInstOrph :: IfaceFamInst -> IsOrphan
ifFamInstOrph = IsOrphan
orphan } )
= do { axiom' <- SDoc -> IfL (CoAxiom Unbranched) -> IfL (CoAxiom Unbranched)
forall a. SDoc -> IfL a -> IfL a
forkM (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Axiom" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
axiom_name) (IfL (CoAxiom Unbranched) -> IfL (CoAxiom Unbranched))
-> IfL (CoAxiom Unbranched) -> IfL (CoAxiom Unbranched)
forall a b. (a -> b) -> a -> b
$
Name -> IfL (CoAxiom Unbranched)
tcIfaceUnbranchedAxiom Name
axiom_name
; let mb_tcs' = (Maybe IfaceTyCon -> RoughMatchTc)
-> [Maybe IfaceTyCon] -> [RoughMatchTc]
forall a b. (a -> b) -> [a] -> [b]
map Maybe IfaceTyCon -> RoughMatchTc
tcRoughTyCon [Maybe IfaceTyCon]
mb_tcs
; return (mkImportedFamInst fam mb_tcs' axiom' orphan) }
tcIfaceRules :: Bool
-> [IfaceRule]
-> IfL [CoreRule]
tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]
tcIfaceRules Bool
ignore_prags [IfaceRule]
if_rules
| Bool
ignore_prags = [CoreRule] -> IfL [CoreRule]
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise = (IfaceRule -> IOEnv (Env IfGblEnv IfLclEnv) CoreRule)
-> [IfaceRule] -> IfL [CoreRule]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceRule -> IOEnv (Env IfGblEnv IfLclEnv) CoreRule
tcIfaceRule [IfaceRule]
if_rules
tcIfaceRule :: IfaceRule -> IfL CoreRule
tcIfaceRule :: IfaceRule -> IOEnv (Env IfGblEnv IfLclEnv) CoreRule
tcIfaceRule (IfaceRule {ifRuleName :: IfaceRule -> FastString
ifRuleName = FastString
name, ifActivation :: IfaceRule -> Activation
ifActivation = Activation
act, ifRuleBndrs :: IfaceRule -> [IfaceBndr]
ifRuleBndrs = [IfaceBndr]
bndrs,
ifRuleHead :: IfaceRule -> Name
ifRuleHead = Name
fn, ifRuleArgs :: IfaceRule -> [IfaceExpr]
ifRuleArgs = [IfaceExpr]
args, ifRuleRhs :: IfaceRule -> IfaceExpr
ifRuleRhs = IfaceExpr
rhs,
ifRuleAuto :: IfaceRule -> Bool
ifRuleAuto = Bool
auto, ifRuleOrph :: IfaceRule -> IsOrphan
ifRuleOrph = IsOrphan
orph })
= do { ~(bndrs', args', rhs') <-
SDoc
-> IfL ([CoreBndr], [CoreExpr], CoreExpr)
-> IfL ([CoreBndr], [CoreExpr], CoreExpr)
forall a. SDoc -> IfL a -> IfL a
forkM (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Rule" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
pprRuleName FastString
name) (IfL ([CoreBndr], [CoreExpr], CoreExpr)
-> IfL ([CoreBndr], [CoreExpr], CoreExpr))
-> IfL ([CoreBndr], [CoreExpr], CoreExpr)
-> IfL ([CoreBndr], [CoreExpr], CoreExpr)
forall a b. (a -> b) -> a -> b
$
[IfaceBndr]
-> ([CoreBndr] -> IfL ([CoreBndr], [CoreExpr], CoreExpr))
-> IfL ([CoreBndr], [CoreExpr], CoreExpr)
forall a. [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceBndrs [IfaceBndr]
bndrs (([CoreBndr] -> IfL ([CoreBndr], [CoreExpr], CoreExpr))
-> IfL ([CoreBndr], [CoreExpr], CoreExpr))
-> ([CoreBndr] -> IfL ([CoreBndr], [CoreExpr], CoreExpr))
-> IfL ([CoreBndr], [CoreExpr], CoreExpr)
forall a b. (a -> b) -> a -> b
$ \ [CoreBndr]
bndrs' ->
do { args' <- (IfaceExpr -> IfL CoreExpr)
-> [IfaceExpr] -> IOEnv (Env IfGblEnv IfLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceExpr -> IfL CoreExpr
tcIfaceExpr [IfaceExpr]
args
; rhs' <- tcIfaceExpr rhs
; whenGOptM Opt_DoCoreLinting $ do
{ dflags <- getDynFlags
; (_, lcl_env) <- getEnvs
; let in_scope :: [Var]
in_scope = ((UniqFM FastString CoreBndr -> [CoreBndr]
forall {k} (key :: k) elt. UniqFM key elt -> [elt]
nonDetEltsUFM (UniqFM FastString CoreBndr -> [CoreBndr])
-> UniqFM FastString CoreBndr -> [CoreBndr]
forall a b. (a -> b) -> a -> b
$ IfLclEnv -> UniqFM FastString CoreBndr
if_tv_env IfLclEnv
lcl_env) [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++
(UniqFM FastString CoreBndr -> [CoreBndr]
forall {k} (key :: k) elt. UniqFM key elt -> [elt]
nonDetEltsUFM (UniqFM FastString CoreBndr -> [CoreBndr])
-> UniqFM FastString CoreBndr -> [CoreBndr]
forall a b. (a -> b) -> a -> b
$ IfLclEnv -> UniqFM FastString CoreBndr
if_id_env IfLclEnv
lcl_env) [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++
[CoreBndr]
bndrs' [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++
[CoreExpr] -> [CoreBndr]
exprsFreeIdsList [CoreExpr]
args')
; case lintExpr (initLintConfig dflags in_scope) rhs' of
Maybe (Bag SDoc)
Nothing -> () -> TcRnIf IfGblEnv IfLclEnv ()
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Bag SDoc
errs -> do
logger <- IOEnv (Env IfGblEnv IfLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
liftIO $ displayLintResults logger False doc
(pprCoreExpr rhs')
(emptyBag, errs) }
; return (bndrs', args', rhs') }
; let mb_tcs = (IfaceExpr -> Maybe Name) -> [IfaceExpr] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceExpr -> Maybe Name
ifTopFreeName [IfaceExpr]
args
; this_mod <- getIfModule
; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
ru_bndrs = bndrs', ru_args = args',
ru_rhs = occurAnalyseExpr rhs',
ru_rough = mb_tcs,
ru_origin = this_mod,
ru_orphan = orph,
ru_auto = auto,
ru_local = False }) }
where
ifTopFreeName :: IfaceExpr -> Maybe Name
ifTopFreeName :: IfaceExpr -> Maybe Name
ifTopFreeName (IfaceType (IfaceTyConApp IfaceTyCon
tc IfaceAppArgs
_ )) = Name -> Maybe Name
forall a. a -> Maybe a
Just (IfaceTyCon -> Name
ifaceTyConName IfaceTyCon
tc)
ifTopFreeName (IfaceType (IfaceTupleTy TupleSort
s PromotionFlag
_ IfaceAppArgs
ts)) = Name -> Maybe Name
forall a. a -> Maybe a
Just (TupleSort -> Arity -> Name
tupleTyConName TupleSort
s (IfaceContext -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length (IfaceAppArgs -> IfaceContext
appArgsIfaceTypes IfaceAppArgs
ts)))
ifTopFreeName (IfaceApp IfaceExpr
f IfaceExpr
_) = IfaceExpr -> Maybe Name
ifTopFreeName IfaceExpr
f
ifTopFreeName (IfaceExt Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
ifTopFreeName IfaceExpr
_ = Maybe Name
forall a. Maybe a
Nothing
doc :: SDoc
doc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Unfolding of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
name
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
tcIfaceAnnotations = (IfaceAnnotation -> IOEnv (Env IfGblEnv IfLclEnv) Annotation)
-> [IfaceAnnotation] -> IfL [Annotation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceAnnotation -> IOEnv (Env IfGblEnv IfLclEnv) Annotation
tcIfaceAnnotation
tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
tcIfaceAnnotation :: IfaceAnnotation -> IOEnv (Env IfGblEnv IfLclEnv) Annotation
tcIfaceAnnotation (IfaceAnnotation IfaceAnnTarget
target AnnPayload
serialized) = do
target' <- IfaceAnnTarget -> IfL (AnnTarget Name)
tcIfaceAnnTarget IfaceAnnTarget
target
return $ Annotation {
ann_target = target',
ann_value = serialized
}
tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
tcIfaceAnnTarget (NamedTarget OccName
occ) =
Name -> AnnTarget Name
forall name. name -> AnnTarget name
NamedTarget (Name -> AnnTarget Name)
-> TcRnIf IfGblEnv IfLclEnv Name -> IfL (AnnTarget Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OccName -> TcRnIf IfGblEnv IfLclEnv Name
lookupIfaceTop OccName
occ
tcIfaceAnnTarget (ModuleTarget Module
mod) =
AnnTarget Name -> IfL (AnnTarget Name)
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnnTarget Name -> IfL (AnnTarget Name))
-> AnnTarget Name -> IfL (AnnTarget Name)
forall a b. (a -> b) -> a -> b
$ Module -> AnnTarget Name
forall name. Module -> AnnTarget name
ModuleTarget Module
mod
tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
tcIfaceCompleteMatches = (IfaceCompleteMatch -> IOEnv (Env IfGblEnv IfLclEnv) CompleteMatch)
-> [IfaceCompleteMatch] -> IfL [CompleteMatch]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceCompleteMatch -> IOEnv (Env IfGblEnv IfLclEnv) CompleteMatch
tcIfaceCompleteMatch
tcIfaceCompleteMatch :: IfaceCompleteMatch -> IfL CompleteMatch
tcIfaceCompleteMatch :: IfaceCompleteMatch -> IOEnv (Env IfGblEnv IfLclEnv) CompleteMatch
tcIfaceCompleteMatch (IfaceCompleteMatch [Name]
ms Maybe Name
mtc) =
CompleteMatch -> IOEnv (Env IfGblEnv IfLclEnv) CompleteMatch
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CompleteMatch -> IOEnv (Env IfGblEnv IfLclEnv) CompleteMatch)
-> CompleteMatch -> IOEnv (Env IfGblEnv IfLclEnv) CompleteMatch
forall a b. (a -> b) -> a -> b
$ UniqDSet Name -> Maybe Name -> CompleteMatch
forall con. UniqDSet con -> Maybe Name -> CompleteMatchX con
CompleteMatch ([Name] -> UniqDSet Name
forall a. Uniquable a => [a] -> UniqDSet a
mkUniqDSet [Name]
ms) Maybe Name
mtc
tcIfaceType :: IfaceType -> IfL Type
tcIfaceType :: IfaceType -> IfL Type
tcIfaceType = IfaceType -> IfL Type
go
where
go :: IfaceType -> IfL Type
go (IfaceTyVar IfLclName
n) = CoreBndr -> Type
TyVarTy (CoreBndr -> Type) -> IfL CoreBndr -> IfL Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfLclName -> IfL CoreBndr
tcIfaceTyVar IfLclName
n
go (IfaceFreeTyVar CoreBndr
n) = String -> SDoc -> IfL Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcIfaceType:IfaceFreeTyVar" (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
n)
go (IfaceLitTy IfaceTyLit
l) = TyLit -> Type
LitTy (TyLit -> Type) -> IOEnv (Env IfGblEnv IfLclEnv) TyLit -> IfL Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceTyLit -> IOEnv (Env IfGblEnv IfLclEnv) TyLit
tcIfaceTyLit IfaceTyLit
l
go (IfaceFunTy FunTyFlag
flag IfaceType
w IfaceType
t1 IfaceType
t2) = FunTyFlag -> Type -> Type -> Type -> Type
FunTy FunTyFlag
flag (Type -> Type -> Type -> Type)
-> IfL Type -> IOEnv (Env IfGblEnv IfLclEnv) (Type -> Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceType -> IfL Type
tcIfaceType IfaceType
w IOEnv (Env IfGblEnv IfLclEnv) (Type -> Type -> Type)
-> IfL Type -> IOEnv (Env IfGblEnv IfLclEnv) (Type -> Type)
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IfaceType -> IfL Type
go IfaceType
t1 IOEnv (Env IfGblEnv IfLclEnv) (Type -> Type)
-> IfL Type -> IfL Type
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IfaceType -> IfL Type
go IfaceType
t2
go (IfaceTupleTy TupleSort
s PromotionFlag
i IfaceAppArgs
tks) = TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type
tcIfaceTupleTy TupleSort
s PromotionFlag
i IfaceAppArgs
tks
go (IfaceAppTy IfaceType
t IfaceAppArgs
ts)
= do { t' <- IfaceType -> IfL Type
go IfaceType
t
; ts' <- traverse go (appArgsIfaceTypes ts)
; pure (foldl' AppTy t' ts') }
go (IfaceTyConApp IfaceTyCon
tc IfaceAppArgs
tks)
= do { tc' <- IfaceTyCon -> IOEnv (Env IfGblEnv IfLclEnv) TyCon
tcIfaceTyCon IfaceTyCon
tc
; tks' <- mapM go (appArgsIfaceTypes tks)
; return (mkTyConApp tc' tks') }
go (IfaceForAllTy IfaceForAllBndr
bndr IfaceType
t)
= IfaceForAllBndr
-> (CoreBndr -> ForAllTyFlag -> IfL Type) -> IfL Type
forall vis a.
VarBndr IfaceBndr vis -> (CoreBndr -> vis -> IfL a) -> IfL a
bindIfaceForAllBndr IfaceForAllBndr
bndr ((CoreBndr -> ForAllTyFlag -> IfL Type) -> IfL Type)
-> (CoreBndr -> ForAllTyFlag -> IfL Type) -> IfL Type
forall a b. (a -> b) -> a -> b
$ \ CoreBndr
tv' ForAllTyFlag
vis ->
ForAllTyBinder -> Type -> Type
ForAllTy (CoreBndr -> ForAllTyFlag -> ForAllTyBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr CoreBndr
tv' ForAllTyFlag
vis) (Type -> Type) -> IfL Type -> IfL Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceType -> IfL Type
go IfaceType
t
go (IfaceCastTy IfaceType
ty IfaceCoercion
co) = Type -> Coercion -> Type
CastTy (Type -> Coercion -> Type)
-> IfL Type -> IOEnv (Env IfGblEnv IfLclEnv) (Coercion -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceType -> IfL Type
go IfaceType
ty IOEnv (Env IfGblEnv IfLclEnv) (Coercion -> Type)
-> IfL Coercion -> IfL Type
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IfaceCoercion -> IfL Coercion
tcIfaceCo IfaceCoercion
co
go (IfaceCoercionTy IfaceCoercion
co) = Coercion -> Type
CoercionTy (Coercion -> Type) -> IfL Coercion -> IfL Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceCoercion -> IfL Coercion
tcIfaceCo IfaceCoercion
co
tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type
tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type
tcIfaceTupleTy TupleSort
sort PromotionFlag
is_promoted IfaceAppArgs
args
= do { args' <- IfaceAppArgs -> IfL ThetaType
tcIfaceAppArgs IfaceAppArgs
args
; let arity = ThetaType -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length ThetaType
args'
; base_tc <- tcTupleTyCon True sort arity
; case is_promoted of
PromotionFlag
NotPromoted
-> Type -> IfL Type
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> ThetaType -> Type
mkTyConApp TyCon
base_tc ThetaType
args')
PromotionFlag
IsPromoted
-> do { let tc :: TyCon
tc = DataCon -> TyCon
promoteDataCon (TyCon -> DataCon
tyConSingleDataCon TyCon
base_tc)
kind_args :: ThetaType
kind_args = (Type -> Type) -> ThetaType -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Type -> Type
Type -> Type
typeKind ThetaType
args'
; Type -> IfL Type
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc (ThetaType
kind_args ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ ThetaType
args')) } }
tcTupleTyCon :: Bool
-> TupleSort
-> Arity
-> IfL TyCon
tcTupleTyCon :: Bool -> TupleSort -> Arity -> IOEnv (Env IfGblEnv IfLclEnv) TyCon
tcTupleTyCon Bool
in_type TupleSort
sort Arity
arity
= case TupleSort
sort of
TupleSort
ConstraintTuple -> TyCon -> IOEnv (Env IfGblEnv IfLclEnv) TyCon
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Arity -> TyCon
cTupleTyCon Arity
arity)
TupleSort
BoxedTuple -> TyCon -> IOEnv (Env IfGblEnv IfLclEnv) TyCon
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Boxity -> Arity -> TyCon
tupleTyCon Boxity
Boxed Arity
arity)
TupleSort
UnboxedTuple -> TyCon -> IOEnv (Env IfGblEnv IfLclEnv) TyCon
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Boxity -> Arity -> TyCon
tupleTyCon Boxity
Unboxed Arity
arity')
where arity' :: Arity
arity' | Bool
in_type = Arity
arity Arity -> Arity -> Arity
forall a. Integral a => a -> a -> a
`div` Arity
2
| Bool
otherwise = Arity
arity
tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type]
tcIfaceAppArgs :: IfaceAppArgs -> IfL ThetaType
tcIfaceAppArgs = (IfaceType -> IfL Type) -> IfaceContext -> IfL ThetaType
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceType -> IfL Type
tcIfaceType (IfaceContext -> IfL ThetaType)
-> (IfaceAppArgs -> IfaceContext) -> IfaceAppArgs -> IfL ThetaType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfaceAppArgs -> IfaceContext
appArgsIfaceTypes
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
tcIfaceCtxt IfaceContext
sts = (IfaceType -> IfL Type) -> IfaceContext -> IfL ThetaType
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceType -> IfL Type
tcIfaceType IfaceContext
sts
tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
tcIfaceTyLit :: IfaceTyLit -> IOEnv (Env IfGblEnv IfLclEnv) TyLit
tcIfaceTyLit (IfaceNumTyLit Integer
n) = TyLit -> IOEnv (Env IfGblEnv IfLclEnv) TyLit
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> TyLit
NumTyLit Integer
n)
tcIfaceTyLit (IfaceStrTyLit LexicalFastString
n) = TyLit -> IOEnv (Env IfGblEnv IfLclEnv) TyLit
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> TyLit
StrTyLit (LexicalFastString -> FastString
getLexicalFastString LexicalFastString
n))
tcIfaceTyLit (IfaceCharTyLit Char
n) = TyLit -> IOEnv (Env IfGblEnv IfLclEnv) TyLit
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> TyLit
CharTyLit Char
n)
tcIfaceCo :: IfaceCoercion -> IfL Coercion
tcIfaceCo :: IfaceCoercion -> IfL Coercion
tcIfaceCo = IfaceCoercion -> IfL Coercion
go
where
go_mco :: IfaceMCoercion -> IOEnv (Env IfGblEnv IfLclEnv) MCoercion
go_mco IfaceMCoercion
IfaceMRefl = MCoercion -> IOEnv (Env IfGblEnv IfLclEnv) MCoercion
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MCoercion
MRefl
go_mco (IfaceMCo IfaceCoercion
co) = Coercion -> MCoercion
MCo (Coercion -> MCoercion)
-> IfL Coercion -> IOEnv (Env IfGblEnv IfLclEnv) MCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IfaceCoercion -> IfL Coercion
go IfaceCoercion
co)
go :: IfaceCoercion -> IfL Coercion
go (IfaceReflCo IfaceType
t) = Type -> Coercion
Refl (Type -> Coercion) -> IfL Type -> IfL Coercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceType -> IfL Type
tcIfaceType IfaceType
t
go (IfaceGReflCo Role
r IfaceType
t IfaceMCoercion
mco) = Role -> Type -> MCoercion -> Coercion
GRefl Role
r (Type -> MCoercion -> Coercion)
-> IfL Type
-> IOEnv (Env IfGblEnv IfLclEnv) (MCoercion -> Coercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceType -> IfL Type
tcIfaceType IfaceType
t IOEnv (Env IfGblEnv IfLclEnv) (MCoercion -> Coercion)
-> IOEnv (Env IfGblEnv IfLclEnv) MCoercion -> IfL Coercion
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IfaceMCoercion -> IOEnv (Env IfGblEnv IfLclEnv) MCoercion
go_mco IfaceMCoercion
mco
go (IfaceFunCo Role
r IfaceCoercion
w IfaceCoercion
c1 IfaceCoercion
c2) = HasDebugCallStack =>
Role -> Coercion -> Coercion -> Coercion -> Coercion
Role -> Coercion -> Coercion -> Coercion -> Coercion
mkFunCoNoFTF Role
r (Coercion -> Coercion -> Coercion -> Coercion)
-> IfL Coercion
-> IOEnv (Env IfGblEnv IfLclEnv) (Coercion -> Coercion -> Coercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceCoercion -> IfL Coercion
go IfaceCoercion
w IOEnv (Env IfGblEnv IfLclEnv) (Coercion -> Coercion -> Coercion)
-> IfL Coercion
-> IOEnv (Env IfGblEnv IfLclEnv) (Coercion -> Coercion)
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IfaceCoercion -> IfL Coercion
go IfaceCoercion
c1 IOEnv (Env IfGblEnv IfLclEnv) (Coercion -> Coercion)
-> IfL Coercion -> IfL Coercion
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IfaceCoercion -> IfL Coercion
go IfaceCoercion
c2
go (IfaceTyConAppCo Role
r IfaceTyCon
tc [IfaceCoercion]
cs) = Role -> TyCon -> [Coercion] -> Coercion
TyConAppCo Role
r (TyCon -> [Coercion] -> Coercion)
-> IOEnv (Env IfGblEnv IfLclEnv) TyCon
-> IOEnv (Env IfGblEnv IfLclEnv) ([Coercion] -> Coercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceTyCon -> IOEnv (Env IfGblEnv IfLclEnv) TyCon
tcIfaceTyCon IfaceTyCon
tc IOEnv (Env IfGblEnv IfLclEnv) ([Coercion] -> Coercion)
-> IOEnv (Env IfGblEnv IfLclEnv) [Coercion] -> IfL Coercion
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (IfaceCoercion -> IfL Coercion)
-> [IfaceCoercion] -> IOEnv (Env IfGblEnv IfLclEnv) [Coercion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceCoercion -> IfL Coercion
go [IfaceCoercion]
cs
go (IfaceAppCo IfaceCoercion
c1 IfaceCoercion
c2) = Coercion -> Coercion -> Coercion
AppCo (Coercion -> Coercion -> Coercion)
-> IfL Coercion
-> IOEnv (Env IfGblEnv IfLclEnv) (Coercion -> Coercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceCoercion -> IfL Coercion
go IfaceCoercion
c1 IOEnv (Env IfGblEnv IfLclEnv) (Coercion -> Coercion)
-> IfL Coercion -> IfL Coercion
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IfaceCoercion -> IfL Coercion
go IfaceCoercion
c2
go (IfaceForAllCo IfaceBndr
tv ForAllTyFlag
visL ForAllTyFlag
visR IfaceCoercion
k IfaceCoercion
c) = do { k' <- IfaceCoercion -> IfL Coercion
go IfaceCoercion
k
; bindIfaceBndr tv $ \ CoreBndr
tv' ->
CoreBndr
-> ForAllTyFlag -> ForAllTyFlag -> Coercion -> Coercion -> Coercion
ForAllCo CoreBndr
tv' ForAllTyFlag
visL ForAllTyFlag
visR Coercion
k' (Coercion -> Coercion) -> IfL Coercion -> IfL Coercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceCoercion -> IfL Coercion
go IfaceCoercion
c }
go (IfaceCoVarCo IfLclName
n) = CoreBndr -> Coercion
CoVarCo (CoreBndr -> Coercion) -> IfL CoreBndr -> IfL Coercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfLclName -> IfL CoreBndr
go_var IfLclName
n
go (IfaceUnivCo UnivCoProvenance
p Role
r IfaceType
t1 IfaceType
t2 [IfaceCoercion]
ds) = do { t1' <- IfaceType -> IfL Type
tcIfaceType IfaceType
t1; t2' <- tcIfaceType t2
; ds' <- mapM go ds
; return (UnivCo { uco_prov = p, uco_role = r
, uco_lty = t1', uco_rty = t2'
, uco_deps = ds' }) }
go (IfaceSymCo IfaceCoercion
c) = Coercion -> Coercion
SymCo (Coercion -> Coercion) -> IfL Coercion -> IfL Coercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceCoercion -> IfL Coercion
go IfaceCoercion
c
go (IfaceTransCo IfaceCoercion
c1 IfaceCoercion
c2) = Coercion -> Coercion -> Coercion
TransCo (Coercion -> Coercion -> Coercion)
-> IfL Coercion
-> IOEnv (Env IfGblEnv IfLclEnv) (Coercion -> Coercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceCoercion -> IfL Coercion
go IfaceCoercion
c1
IOEnv (Env IfGblEnv IfLclEnv) (Coercion -> Coercion)
-> IfL Coercion -> IfL Coercion
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IfaceCoercion -> IfL Coercion
go IfaceCoercion
c2
go (IfaceInstCo IfaceCoercion
c1 IfaceCoercion
t2) = Coercion -> Coercion -> Coercion
InstCo (Coercion -> Coercion -> Coercion)
-> IfL Coercion
-> IOEnv (Env IfGblEnv IfLclEnv) (Coercion -> Coercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceCoercion -> IfL Coercion
go IfaceCoercion
c1
IOEnv (Env IfGblEnv IfLclEnv) (Coercion -> Coercion)
-> IfL Coercion -> IfL Coercion
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IfaceCoercion -> IfL Coercion
go IfaceCoercion
t2
go (IfaceSelCo CoSel
d IfaceCoercion
c) = do { c' <- IfaceCoercion -> IfL Coercion
go IfaceCoercion
c
; return $ mkSelCo d c' }
go (IfaceLRCo LeftOrRight
lr IfaceCoercion
c) = LeftOrRight -> Coercion -> Coercion
LRCo LeftOrRight
lr (Coercion -> Coercion) -> IfL Coercion -> IfL Coercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceCoercion -> IfL Coercion
go IfaceCoercion
c
go (IfaceKindCo IfaceCoercion
c) = Coercion -> Coercion
KindCo (Coercion -> Coercion) -> IfL Coercion -> IfL Coercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceCoercion -> IfL Coercion
go IfaceCoercion
c
go (IfaceSubCo IfaceCoercion
c) = Coercion -> Coercion
SubCo (Coercion -> Coercion) -> IfL Coercion -> IfL Coercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceCoercion -> IfL Coercion
go IfaceCoercion
c
go (IfaceAxiomCo IfaceAxiomRule
ax [IfaceCoercion]
cos) = CoAxiomRule -> [Coercion] -> Coercion
AxiomCo (CoAxiomRule -> [Coercion] -> Coercion)
-> IOEnv (Env IfGblEnv IfLclEnv) CoAxiomRule
-> IOEnv (Env IfGblEnv IfLclEnv) ([Coercion] -> Coercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceAxiomRule -> IOEnv (Env IfGblEnv IfLclEnv) CoAxiomRule
tcIfaceAxiomRule IfaceAxiomRule
ax
IOEnv (Env IfGblEnv IfLclEnv) ([Coercion] -> Coercion)
-> IOEnv (Env IfGblEnv IfLclEnv) [Coercion] -> IfL Coercion
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (IfaceCoercion -> IfL Coercion)
-> [IfaceCoercion] -> IOEnv (Env IfGblEnv IfLclEnv) [Coercion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceCoercion -> IfL Coercion
go [IfaceCoercion]
cos
go (IfaceFreeCoVar CoreBndr
c) = String -> SDoc -> IfL Coercion
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcIfaceCo:IfaceFreeCoVar" (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
c)
go (IfaceHoleCo CoreBndr
c) = String -> SDoc -> IfL Coercion
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcIfaceCo:IfaceHoleCo" (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
c)
go_var :: IfLclName -> IfL CoVar
go_var :: IfLclName -> IfL CoreBndr
go_var = IfLclName -> IfL CoreBndr
tcIfaceLclId
tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
tcIfaceExpr (IfaceType IfaceType
ty)
= Type -> CoreExpr
forall b. Type -> Expr b
Type (Type -> CoreExpr) -> IfL Type -> IfL CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceType -> IfL Type
tcIfaceType IfaceType
ty
tcIfaceExpr (IfaceCo IfaceCoercion
co)
= Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion (Coercion -> CoreExpr) -> IfL Coercion -> IfL CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceCoercion -> IfL Coercion
tcIfaceCo IfaceCoercion
co
tcIfaceExpr (IfaceCast IfaceExpr
expr IfaceCoercion
co)
= CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (CoreExpr -> Coercion -> CoreExpr)
-> IfL CoreExpr
-> IOEnv (Env IfGblEnv IfLclEnv) (Coercion -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceExpr -> IfL CoreExpr
tcIfaceExpr IfaceExpr
expr IOEnv (Env IfGblEnv IfLclEnv) (Coercion -> CoreExpr)
-> IfL Coercion -> IfL CoreExpr
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IfaceCoercion -> IfL Coercion
tcIfaceCo IfaceCoercion
co
tcIfaceExpr (IfaceLcl IfLclName
name)
= CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var (CoreBndr -> CoreExpr) -> IfL CoreBndr -> IfL CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfLclName -> IfL CoreBndr
tcIfaceLclId IfLclName
name
tcIfaceExpr (IfaceExt Name
gbl)
= CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var (CoreBndr -> CoreExpr) -> IfL CoreBndr -> IfL CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IfL CoreBndr
tcIfaceExtId Name
gbl
tcIfaceExpr (IfaceLitRubbish TypeOrConstraint
tc IfaceType
rep)
= do rep' <- IfaceType -> IfL Type
tcIfaceType IfaceType
rep
return (Lit (LitRubbish tc rep'))
tcIfaceExpr (IfaceLit Literal
lit)
= do lit' <- Literal -> IfL Literal
tcIfaceLit Literal
lit
return (Lit lit')
tcIfaceExpr (IfaceFCall ForeignCall
cc IfaceType
ty) = do
ty' <- IfaceType -> IfL Type
tcIfaceType IfaceType
ty
u <- newUnique
return (Var (mkFCallId u cc ty'))
tcIfaceExpr (IfaceTuple TupleSort
sort [IfaceExpr]
args)
= do { args' <- (IfaceExpr -> IfL CoreExpr)
-> [IfaceExpr] -> IOEnv (Env IfGblEnv IfLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceExpr -> IfL CoreExpr
tcIfaceExpr [IfaceExpr]
args
; tc <- tcTupleTyCon False sort arity
; let con_tys = (CoreExpr -> Type) -> [CoreExpr] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType [CoreExpr]
args'
some_con_args = (Type -> CoreExpr) -> ThetaType -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type ThetaType
con_tys [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
args'
con_args = case TupleSort
sort of
TupleSort
UnboxedTuple -> (Type -> CoreExpr) -> ThetaType -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> CoreExpr
forall b. Type -> Expr b
Type (Type -> CoreExpr) -> (Type -> Type) -> Type -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep) ThetaType
con_tys [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
some_con_args
TupleSort
_ -> [CoreExpr]
some_con_args
con_id = DataCon -> CoreBndr
dataConWorkId (TyCon -> DataCon
tyConSingleDataCon TyCon
tc)
; return (mkApps (Var con_id) con_args) }
where
arity :: Arity
arity = [IfaceExpr] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [IfaceExpr]
args
tcIfaceExpr (IfaceLam (IfaceBndr
bndr, IfaceOneShot
os) IfaceExpr
body)
= IfaceBndr -> (CoreBndr -> IfL CoreExpr) -> IfL CoreExpr
forall a. IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceBndr IfaceBndr
bndr ((CoreBndr -> IfL CoreExpr) -> IfL CoreExpr)
-> (CoreBndr -> IfL CoreExpr) -> IfL CoreExpr
forall a b. (a -> b) -> a -> b
$ \CoreBndr
bndr' ->
CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam (IfaceOneShot -> CoreBndr -> CoreBndr
tcIfaceOneShot IfaceOneShot
os CoreBndr
bndr') (CoreExpr -> CoreExpr) -> IfL CoreExpr -> IfL CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceExpr -> IfL CoreExpr
tcIfaceExpr IfaceExpr
body
where
tcIfaceOneShot :: IfaceOneShot -> CoreBndr -> CoreBndr
tcIfaceOneShot IfaceOneShot
IfaceOneShot CoreBndr
b = CoreBndr -> CoreBndr
setOneShotLambda CoreBndr
b
tcIfaceOneShot IfaceOneShot
_ CoreBndr
b = CoreBndr
b
tcIfaceExpr (IfaceApp IfaceExpr
fun IfaceExpr
arg)
= CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreExpr -> CoreExpr -> CoreExpr)
-> IfL CoreExpr
-> IOEnv (Env IfGblEnv IfLclEnv) (CoreExpr -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceExpr -> IfL CoreExpr
tcIfaceExpr IfaceExpr
fun IOEnv (Env IfGblEnv IfLclEnv) (CoreExpr -> CoreExpr)
-> IfL CoreExpr -> IfL CoreExpr
forall a b.
IOEnv (Env IfGblEnv IfLclEnv) (a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IfaceExpr -> IfL CoreExpr
tcIfaceExpr IfaceExpr
arg
tcIfaceExpr (IfaceECase IfaceExpr
scrut IfaceType
ty)
= do { scrut' <- IfaceExpr -> IfL CoreExpr
tcIfaceExpr IfaceExpr
scrut
; ty' <- tcIfaceType ty
; return (castBottomExpr scrut' ty') }
tcIfaceExpr (IfaceCase IfaceExpr
scrut IfLclName
case_bndr [IfaceAlt]
alts) = do
scrut' <- IfaceExpr -> IfL CoreExpr
tcIfaceExpr IfaceExpr
scrut
case_bndr_name <- newIfaceName (mkVarOccFS (ifLclNameFS case_bndr))
let
scrut_ty = HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
scrut'
case_mult = Type
ManyTy
case_bndr' = HasDebugCallStack => Name -> Type -> Type -> CoreBndr
Name -> Type -> Type -> CoreBndr
mkLocalIdOrCoVar Name
case_bndr_name Type
case_mult Type
scrut_ty
tc_app = Type -> (TyCon, ThetaType)
splitTyConApp Type
scrut_ty
extendIfaceIdEnv [case_bndr'] $ do
alts' <- mapM (tcIfaceAlt scrut' case_mult tc_app) alts
return (Case scrut' case_bndr' (coreAltsType alts') alts')
tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr IfLclName
fs IfaceType
ty IfaceIdInfo
info JoinPointHood
ji) IfaceExpr
rhs) IfaceExpr
body)
= do { name <- OccName -> TcRnIf IfGblEnv IfLclEnv Name
newIfaceName (FastString -> OccName
mkVarOccFS (IfLclName -> FastString
ifLclNameFS IfLclName
fs))
; ty' <- tcIfaceType ty
; id_info <- tcIdInfo False
NotTopLevel name ty' info
; let id = HasDebugCallStack => Name -> Type -> Type -> IdInfo -> CoreBndr
Name -> Type -> Type -> IdInfo -> CoreBndr
mkLocalIdWithInfo Name
name Type
ManyTy Type
ty' IdInfo
id_info
CoreBndr -> JoinPointHood -> CoreBndr
`asJoinId_maybe` JoinPointHood
ji
; rhs' <- tcIfaceExpr rhs
; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
; return (Let (NonRec id rhs') body') }
tcIfaceExpr (IfaceLet (IfaceRec [(IfaceLetBndr, IfaceExpr)]
pairs) IfaceExpr
body)
= do { ids <- (IfaceLetBndr -> IfL CoreBndr)
-> [IfaceLetBndr] -> IOEnv (Env IfGblEnv IfLclEnv) [CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceLetBndr -> IfL CoreBndr
tc_rec_bndr (((IfaceLetBndr, IfaceExpr) -> IfaceLetBndr)
-> [(IfaceLetBndr, IfaceExpr)] -> [IfaceLetBndr]
forall a b. (a -> b) -> [a] -> [b]
map (IfaceLetBndr, IfaceExpr) -> IfaceLetBndr
forall a b. (a, b) -> a
fst [(IfaceLetBndr, IfaceExpr)]
pairs)
; extendIfaceIdEnv ids $ do
{ pairs' <- zipWithM tc_pair pairs ids
; body' <- tcIfaceExpr body
; return (Let (Rec pairs') body') } }
where
tc_rec_bndr :: IfaceLetBndr -> IfL CoreBndr
tc_rec_bndr (IfLetBndr IfLclName
fs IfaceType
ty IfaceIdInfo
_ JoinPointHood
ji)
= do { name <- OccName -> TcRnIf IfGblEnv IfLclEnv Name
newIfaceName (FastString -> OccName
mkVarOccFS (IfLclName -> FastString
ifLclNameFS IfLclName
fs))
; ty' <- tcIfaceType ty
; return (mkLocalId name ManyTy ty' `asJoinId_maybe` ji) }
tc_pair :: (IfaceLetBndr, IfaceExpr)
-> CoreBndr -> IOEnv (Env IfGblEnv IfLclEnv) (CoreBndr, CoreExpr)
tc_pair (IfLetBndr IfLclName
_ IfaceType
_ IfaceIdInfo
info JoinPointHood
_, IfaceExpr
rhs) CoreBndr
id
= do { rhs' <- IfaceExpr -> IfL CoreExpr
tcIfaceExpr IfaceExpr
rhs
; id_info <- tcIdInfo False
NotTopLevel (idName id) (idType id) info
; return (setIdInfo id id_info, rhs') }
tcIfaceExpr (IfaceTick IfaceTickish
tickish IfaceExpr
expr) = do
expr' <- IfaceExpr -> IfL CoreExpr
tcIfaceExpr IfaceExpr
expr
need_notes <- needSourceNotes <$> getDynFlags
case tickish of
IfaceSource{} | Bool -> Bool
not (Bool
need_notes)
-> CoreExpr -> IfL CoreExpr
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
expr'
IfaceTickish
_otherwise -> do
tickish' <- IfaceTickish -> IfL CoreTickish
tcIfaceTickish IfaceTickish
tickish
return (Tick tickish' expr')
tcIfaceTickish :: IfaceTickish -> IfL CoreTickish
tcIfaceTickish :: IfaceTickish -> IfL CoreTickish
tcIfaceTickish (IfaceHpcTick Module
modl Arity
ix) = CoreTickish -> IfL CoreTickish
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> Arity -> CoreTickish
forall (pass :: TickishPass). Module -> Arity -> GenTickish pass
HpcTick Module
modl Arity
ix)
tcIfaceTickish (IfaceSCC CostCentre
cc Bool
tick Bool
push) = CoreTickish -> IfL CoreTickish
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CostCentre -> Bool -> Bool -> CoreTickish
forall (pass :: TickishPass).
CostCentre -> Bool -> Bool -> GenTickish pass
ProfNote CostCentre
cc Bool
tick Bool
push)
tcIfaceTickish (IfaceSource RealSrcSpan
src FastString
name) = CoreTickish -> IfL CoreTickish
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> LexicalFastString -> CoreTickish
forall (pass :: TickishPass).
RealSrcSpan -> LexicalFastString -> GenTickish pass
SourceNote RealSrcSpan
src (FastString -> LexicalFastString
LexicalFastString FastString
name))
tcIfaceTickish (IfaceBreakpoint Arity
ix [IfaceExpr]
fvs Module
modl) = do
fvs' <- (IfaceExpr -> IfL CoreExpr)
-> [IfaceExpr] -> IOEnv (Env IfGblEnv IfLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceExpr -> IfL CoreExpr
tcIfaceExpr [IfaceExpr]
fvs
return (Breakpoint NoExtField ix [f | Var f <- fvs'] modl)
tcIfaceLit :: Literal -> IfL Literal
tcIfaceLit :: Literal -> IfL Literal
tcIfaceLit Literal
lit = Literal -> IfL Literal
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Literal
lit
tcIfaceAlt :: CoreExpr -> Mult -> (TyCon, [Type])
-> IfaceAlt
-> IfL CoreAlt
tcIfaceAlt :: CoreExpr
-> Type
-> (TyCon, ThetaType)
-> IfaceAlt
-> IOEnv (Env IfGblEnv IfLclEnv) CoreAlt
tcIfaceAlt CoreExpr
_ Type
_ (TyCon, ThetaType)
_ (IfaceAlt IfaceConAlt
IfaceDefaultAlt [IfLclName]
names IfaceExpr
rhs)
= Bool
-> IOEnv (Env IfGblEnv IfLclEnv) CoreAlt
-> IOEnv (Env IfGblEnv IfLclEnv) CoreAlt
forall a. HasCallStack => Bool -> a -> a
assert ([IfLclName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IfLclName]
names) (IOEnv (Env IfGblEnv IfLclEnv) CoreAlt
-> IOEnv (Env IfGblEnv IfLclEnv) CoreAlt)
-> IOEnv (Env IfGblEnv IfLclEnv) CoreAlt
-> IOEnv (Env IfGblEnv IfLclEnv) CoreAlt
forall a b. (a -> b) -> a -> b
$ do
rhs' <- IfaceExpr -> IfL CoreExpr
tcIfaceExpr IfaceExpr
rhs
return (Alt DEFAULT [] rhs')
tcIfaceAlt CoreExpr
_ Type
_ (TyCon, ThetaType)
_ (IfaceAlt (IfaceLitAlt Literal
lit) [IfLclName]
names IfaceExpr
rhs)
= Bool
-> IOEnv (Env IfGblEnv IfLclEnv) CoreAlt
-> IOEnv (Env IfGblEnv IfLclEnv) CoreAlt
forall a. HasCallStack => Bool -> a -> a
assert ([IfLclName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IfLclName]
names) (IOEnv (Env IfGblEnv IfLclEnv) CoreAlt
-> IOEnv (Env IfGblEnv IfLclEnv) CoreAlt)
-> IOEnv (Env IfGblEnv IfLclEnv) CoreAlt
-> IOEnv (Env IfGblEnv IfLclEnv) CoreAlt
forall a b. (a -> b) -> a -> b
$ do
lit' <- Literal -> IfL Literal
tcIfaceLit Literal
lit
rhs' <- tcIfaceExpr rhs
return (Alt (LitAlt lit') [] rhs')
tcIfaceAlt CoreExpr
scrut Type
mult (TyCon
tycon, ThetaType
inst_tys) (IfaceAlt (IfaceDataAlt Name
data_occ) [IfLclName]
arg_strs IfaceExpr
rhs)
= do { con <- Name -> IOEnv (Env IfGblEnv IfLclEnv) DataCon
tcIfaceDataCon Name
data_occ
; when (debugIsOn && not (con `elem` tyConDataCons tycon))
(failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
; tcIfaceDataAlt mult con inst_tys arg_strs rhs }
tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [IfLclName] -> IfaceExpr
-> IfL CoreAlt
tcIfaceDataAlt :: Type
-> DataCon
-> ThetaType
-> [IfLclName]
-> IfaceExpr
-> IOEnv (Env IfGblEnv IfLclEnv) CoreAlt
tcIfaceDataAlt Type
mult DataCon
con ThetaType
inst_tys [IfLclName]
arg_strs IfaceExpr
rhs
= do { uniqs <- IOEnv (Env IfGblEnv IfLclEnv) [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
; let (ex_tvs, arg_ids)
= dataConRepFSInstPat (map ifLclNameFS arg_strs) uniqs mult con inst_tys
; rhs' <- extendIfaceEnvs ex_tvs $
extendIfaceIdEnv arg_ids $
tcIfaceExpr rhs
; return (Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs') }
tcIdDetails :: Name -> Type -> IfaceIdDetails -> IfL IdDetails
tcIdDetails :: Name -> Type -> IfaceIdDetails -> IfL IdDetails
tcIdDetails Name
_ Type
_ IfaceIdDetails
IfVanillaId = IdDetails -> IfL IdDetails
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return IdDetails
VanillaId
tcIdDetails Name
_ Type
_ (IfWorkerLikeId [CbvMark]
dmds) = IdDetails -> IfL IdDetails
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdDetails -> IfL IdDetails) -> IdDetails -> IfL IdDetails
forall a b. (a -> b) -> a -> b
$ [CbvMark] -> IdDetails
WorkerLikeId [CbvMark]
dmds
tcIdDetails Name
_ Type
ty IfaceIdDetails
IfDFunId
= IdDetails -> IfL IdDetails
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IdDetails
DFunId (TyCon -> Bool
isNewTyCon (Class -> TyCon
classTyCon Class
cls)))
where
([CoreBndr]
_, ThetaType
_, Class
cls, ThetaType
_) = Type -> ([CoreBndr], ThetaType, Class, ThetaType)
tcSplitDFunTy Type
ty
tcIdDetails Name
nm Type
_ (IfRecSelId Either IfaceTyCon IfaceDecl
tc Name
_first_con Bool
naughty FieldLabel
fl)
= do { tc' <- (IfaceTyCon -> IOEnv (Env IfGblEnv IfLclEnv) RecSelParent)
-> (IfaceDecl -> IOEnv (Env IfGblEnv IfLclEnv) RecSelParent)
-> Either IfaceTyCon IfaceDecl
-> IOEnv (Env IfGblEnv IfLclEnv) RecSelParent
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((TyCon -> RecSelParent)
-> IOEnv (Env IfGblEnv IfLclEnv) TyCon
-> IOEnv (Env IfGblEnv IfLclEnv) RecSelParent
forall a b.
(a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyCon -> RecSelParent
RecSelData (IOEnv (Env IfGblEnv IfLclEnv) TyCon
-> IOEnv (Env IfGblEnv IfLclEnv) RecSelParent)
-> (IfaceTyCon -> IOEnv (Env IfGblEnv IfLclEnv) TyCon)
-> IfaceTyCon
-> IOEnv (Env IfGblEnv IfLclEnv) RecSelParent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfaceTyCon -> IOEnv (Env IfGblEnv IfLclEnv) TyCon
tcIfaceTyCon)
((TyThing -> RecSelParent)
-> IfL TyThing -> IOEnv (Env IfGblEnv IfLclEnv) RecSelParent
forall a b.
(a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PatSyn -> RecSelParent
RecSelPatSyn (PatSyn -> RecSelParent)
-> (TyThing -> PatSyn) -> TyThing -> RecSelParent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyThing -> PatSyn
tyThingPatSyn) (IfL TyThing -> IOEnv (Env IfGblEnv IfLclEnv) RecSelParent)
-> (IfaceDecl -> IfL TyThing)
-> IfaceDecl
-> IOEnv (Env IfGblEnv IfLclEnv) RecSelParent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> IfaceDecl -> IfL TyThing
tcIfaceDecl Bool
False)
Either IfaceTyCon IfaceDecl
tc
; let all_cons = RecSelParent -> [ConLike]
recSelParentCons RecSelParent
tc'
cons_partitioned = [ConLike] -> [FieldLabelString] -> RecSelInfo
conLikesRecSelInfo [ConLike]
all_cons [FieldLabel -> FieldLabelString
flLabel FieldLabel
fl]
; return (RecSelId
{ sel_tycon = tc'
, sel_naughty = naughty
, sel_fieldLabel = fl { flSelector = nm }
, sel_cons = cons_partitioned }
) }
where
tyThingPatSyn :: TyThing -> PatSyn
tyThingPatSyn (AConLike (PatSynCon PatSyn
ps)) = PatSyn
ps
tyThingPatSyn TyThing
_ = String -> PatSyn
forall a. HasCallStack => String -> a
panic String
"tcIdDetails: expecting patsyn"
tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
tcIdInfo Bool
ignore_prags TopLevelFlag
toplvl Name
name Type
ty IfaceIdInfo
info = do
lcl_env <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
let init_info = if IfLclEnv -> IsBootInterface
if_boot IfLclEnv
lcl_env IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot
then IdInfo
vanillaIdInfo IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
BootUnfolding
else IdInfo
vanillaIdInfo
foldlM tcPrag init_info (needed_prags info)
where
needed_prags :: [IfaceInfoItem] -> [IfaceInfoItem]
needed_prags :: IfaceIdInfo -> IfaceIdInfo
needed_prags IfaceIdInfo
items
| Bool -> Bool
not Bool
ignore_prags = IfaceIdInfo
items
| Bool
otherwise = (IfaceInfoItem -> Bool) -> IfaceIdInfo -> IfaceIdInfo
forall a. (a -> Bool) -> [a] -> [a]
filter IfaceInfoItem -> Bool
need_prag IfaceIdInfo
items
need_prag :: IfaceInfoItem -> Bool
need_prag :: IfaceInfoItem -> Bool
need_prag (HsUnfold Bool
_ (IfCoreUnfold UnfoldingSource
src IfUnfoldingCache
_ IfGuidance
_ IfaceExpr
_)) = UnfoldingSource -> Bool
isCompulsorySource UnfoldingSource
src
need_prag IfaceInfoItem
_ = Bool
False
tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
tcPrag IdInfo
info IfaceInfoItem
HsNoCafRefs = IdInfo -> IfL IdInfo
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdInfo
info IdInfo -> CafInfo -> IdInfo
`setCafInfo` CafInfo
NoCafRefs)
tcPrag IdInfo
info (HsArity Arity
arity) = IdInfo -> IfL IdInfo
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdInfo
info IdInfo -> Arity -> IdInfo
`setArityInfo` Arity
arity)
tcPrag IdInfo
info (HsDmdSig DmdSig
str) = IdInfo -> IfL IdInfo
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdInfo
info IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` DmdSig
str)
tcPrag IdInfo
info (HsCprSig CprSig
cpr) = IdInfo -> IfL IdInfo
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdInfo
info IdInfo -> CprSig -> IdInfo
`setCprSigInfo` CprSig
cpr)
tcPrag IdInfo
info (HsInline InlinePragma
prag) = IdInfo -> IfL IdInfo
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdInfo
info IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
prag)
tcPrag IdInfo
info (HsLFInfo IfaceLFInfo
lf_info) = do
lf_info <- IfaceLFInfo -> IfL LambdaFormInfo
tcLFInfo IfaceLFInfo
lf_info
return (info `setLFInfo` lf_info)
tcPrag IdInfo
info (HsTagSig TagSig
sig) = do
IdInfo -> IfL IdInfo
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdInfo
info IdInfo -> TagSig -> IdInfo
`setTagSig` TagSig
sig)
tcPrag IdInfo
info (HsUnfold Bool
lb IfaceUnfolding
if_unf)
= do { unf <- TopLevelFlag
-> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
tcUnfolding TopLevelFlag
toplvl Name
name Type
ty IdInfo
info IfaceUnfolding
if_unf
; let info1 | Bool
lb = IdInfo
info IdInfo -> OccInfo -> IdInfo
`setOccInfo` OccInfo
strongLoopBreaker
| Bool
otherwise = IdInfo
info
; return (info1 `setUnfoldingInfo` unf) }
tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo
tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo
tcLFInfo IfaceLFInfo
lfi = case IfaceLFInfo
lfi of
IfLFReEntrant Arity
rep_arity ->
LambdaFormInfo -> IfL LambdaFormInfo
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TopLevelFlag -> Arity -> Bool -> ArgDescr -> LambdaFormInfo
LFReEntrant TopLevelFlag
TopLevel Arity
rep_arity Bool
True ArgDescr
ArgUnknown)
IfLFThunk Bool
updatable Bool
mb_fun ->
LambdaFormInfo -> IfL LambdaFormInfo
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TopLevelFlag
-> Bool -> Bool -> StandardFormInfo -> Bool -> LambdaFormInfo
LFThunk TopLevelFlag
TopLevel Bool
True Bool
updatable StandardFormInfo
NonStandardThunk Bool
mb_fun)
IfaceLFInfo
IfLFUnlifted ->
LambdaFormInfo -> IfL LambdaFormInfo
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LambdaFormInfo
LFUnlifted
IfLFCon Name
con_name ->
DataCon -> LambdaFormInfo
LFCon (DataCon -> LambdaFormInfo)
-> IOEnv (Env IfGblEnv IfLclEnv) DataCon -> IfL LambdaFormInfo
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Name -> IOEnv (Env IfGblEnv IfLclEnv) DataCon
tcIfaceDataCon Name
con_name
IfLFUnknown Bool
fun_flag ->
LambdaFormInfo -> IfL LambdaFormInfo
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> LambdaFormInfo
LFUnknown Bool
fun_flag)
tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
tcUnfolding :: TopLevelFlag
-> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
tcUnfolding TopLevelFlag
toplvl Name
name Type
_ IdInfo
info (IfCoreUnfold UnfoldingSource
src IfUnfoldingCache
cache IfGuidance
if_guidance IfaceExpr
if_expr)
= do { uf_opts <- DynFlags -> UnfoldingOpts
unfoldingOpts (DynFlags -> UnfoldingOpts)
-> IOEnv (Env IfGblEnv IfLclEnv) DynFlags
-> IOEnv (Env IfGblEnv IfLclEnv) UnfoldingOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env IfGblEnv IfLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; expr <- tcUnfoldingRhs (isCompulsorySource src) toplvl name if_expr
; let guidance = case IfGuidance
if_guidance of
IfWhen Arity
arity Bool
unsat_ok Bool
boring_ok -> Arity -> Bool -> Bool -> UnfoldingGuidance
UnfWhen Arity
arity Bool
unsat_ok Bool
boring_ok
IfGuidance
IfNoGuidance -> UnfoldingOpts -> Bool -> Bool -> CoreExpr -> UnfoldingGuidance
calcUnfoldingGuidance UnfoldingOpts
uf_opts Bool
is_top_bottoming Bool
False CoreExpr
expr
; return $ mkCoreUnfolding src True expr (Just cache) guidance }
where
is_top_bottoming :: Bool
is_top_bottoming = TopLevelFlag -> Bool
isTopLevel TopLevelFlag
toplvl Bool -> Bool -> Bool
&& DmdSig -> Bool
isDeadEndSig (IdInfo -> DmdSig
dmdSigInfo IdInfo
info)
tcUnfolding TopLevelFlag
_toplvl Name
name Type
dfun_ty IdInfo
_ (IfDFunUnfold [IfaceBndr]
bs [IfaceExpr]
ops)
= [IfaceBndr] -> ([CoreBndr] -> IfL Unfolding) -> IfL Unfolding
forall a. [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceBndrs [IfaceBndr]
bs (([CoreBndr] -> IfL Unfolding) -> IfL Unfolding)
-> ([CoreBndr] -> IfL Unfolding) -> IfL Unfolding
forall a b. (a -> b) -> a -> b
$ \ [CoreBndr]
bs' ->
do { ops1 <- SDoc
-> IOEnv (Env IfGblEnv IfLclEnv) [CoreExpr]
-> IOEnv (Env IfGblEnv IfLclEnv) [CoreExpr]
forall a. SDoc -> IfL a -> IfL a
forkM SDoc
doc (IOEnv (Env IfGblEnv IfLclEnv) [CoreExpr]
-> IOEnv (Env IfGblEnv IfLclEnv) [CoreExpr])
-> IOEnv (Env IfGblEnv IfLclEnv) [CoreExpr]
-> IOEnv (Env IfGblEnv IfLclEnv) [CoreExpr]
forall a b. (a -> b) -> a -> b
$ (IfaceExpr -> IfL CoreExpr)
-> [IfaceExpr] -> IOEnv (Env IfGblEnv IfLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IfaceExpr -> IfL CoreExpr
tcIfaceExpr [IfaceExpr]
ops
; return $ mkDFunUnfolding bs' (classDataCon cls) ops1 }
where
doc :: SDoc
doc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Class ops for dfun" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
([CoreBndr]
_, ThetaType
_, Class
cls, ThetaType
_) = Type -> ([CoreBndr], ThetaType, Class, ThetaType)
tcSplitDFunTy Type
dfun_ty
tcUnfoldingRhs :: Bool
-> TopLevelFlag -> Name -> IfaceExpr -> IfL CoreExpr
tcUnfoldingRhs :: Bool -> TopLevelFlag -> Name -> IfaceExpr -> IfL CoreExpr
tcUnfoldingRhs Bool
is_compulsory TopLevelFlag
toplvl Name
name IfaceExpr
expr
= SDoc -> IfL CoreExpr -> IfL CoreExpr
forall a. SDoc -> IfL a -> IfL a
forkM SDoc
doc (IfL CoreExpr -> IfL CoreExpr) -> IfL CoreExpr -> IfL CoreExpr
forall a b. (a -> b) -> a -> b
$ do
core_expr' <- IfaceExpr -> IfL CoreExpr
tcIfaceExpr IfaceExpr
expr
when (isTopLevel toplvl) $
whenGOptM Opt_DoCoreLinting $ do
in_scope <- nonDetEltsUniqSet <$> get_in_scope
dflags <- getDynFlags
logger <- getLogger
case lintUnfolding is_compulsory (initLintConfig dflags in_scope) noSrcLoc core_expr' of
Maybe (Bag SDoc)
Nothing -> () -> TcRnIf IfGblEnv IfLclEnv ()
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Bag SDoc
errs -> IO () -> TcRnIf IfGblEnv IfLclEnv ()
forall a. IO a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TcRnIf IfGblEnv IfLclEnv ())
-> IO () -> TcRnIf IfGblEnv IfLclEnv ()
forall a b. (a -> b) -> a -> b
$
Logger -> Bool -> SDoc -> SDoc -> WarnsAndErrs -> IO ()
displayLintResults Logger
logger Bool
False SDoc
doc
(CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
core_expr') (Bag SDoc
forall a. Bag a
emptyBag, Bag SDoc
errs)
return core_expr'
where
doc :: SDoc
doc = Bool -> SDoc -> SDoc
forall doc. IsOutput doc => Bool -> doc -> doc
ppWhen Bool
is_compulsory (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Compulsory") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Unfolding of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
get_in_scope :: IfL VarSet
get_in_scope :: IOEnv (Env IfGblEnv IfLclEnv) (UniqSet CoreBndr)
get_in_scope
= do { (gbl_env, lcl_env) <- TcRnIf IfGblEnv IfLclEnv (IfGblEnv, IfLclEnv)
forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs
; let type_envs = KnotVars (IfG TypeEnv) -> [IfG TypeEnv]
forall a. KnotVars a -> [a]
knotVarElems (IfGblEnv -> KnotVars (IfG TypeEnv)
if_rec_types IfGblEnv
gbl_env)
; top_level_vars <- concat <$> mapM (fmap typeEnvIds . setLclEnv ()) type_envs
; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`
bindingsVars (if_id_env lcl_env) `unionVarSet`
mkVarSet top_level_vars) }
bindingsVars :: FastStringEnv Var -> VarSet
bindingsVars :: UniqFM FastString CoreBndr -> UniqSet CoreBndr
bindingsVars UniqFM FastString CoreBndr
ufm = [CoreBndr] -> UniqSet CoreBndr
mkVarSet ([CoreBndr] -> UniqSet CoreBndr) -> [CoreBndr] -> UniqSet CoreBndr
forall a b. (a -> b) -> a -> b
$ UniqFM FastString CoreBndr -> [CoreBndr]
forall {k} (key :: k) elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM FastString CoreBndr
ufm
tcIfaceOneShot :: IfaceOneShot -> OneShotInfo
tcIfaceOneShot :: IfaceOneShot -> OneShotInfo
tcIfaceOneShot IfaceOneShot
IfaceNoOneShot = OneShotInfo
NoOneShotInfo
tcIfaceOneShot IfaceOneShot
IfaceOneShot = OneShotInfo
OneShotLam
tcIfaceGlobal :: Name -> IfL TyThing
tcIfaceGlobal :: Name -> IfL TyThing
tcIfaceGlobal Name
name
| Just TyThing
thing <- Name -> Maybe TyThing
wiredInNameTyThing_maybe Name
name
= do { TyThing -> TcRnIf IfGblEnv IfLclEnv ()
ifCheckWiredInThing TyThing
thing; TyThing -> IfL TyThing
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing }
| Bool
otherwise
= do { env <- TcRnIf IfGblEnv IfLclEnv IfGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; cur_mod <- if_mod <$> getLclEnv
; case lookupKnotVars (if_rec_types env) (fromMaybe cur_mod (nameModule_maybe name)) of
Just IfG TypeEnv
get_type_env
-> do
{ type_env <- () -> IfG TypeEnv -> IOEnv (Env IfGblEnv IfLclEnv) TypeEnv
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv () IfG TypeEnv
get_type_env
; case lookupNameEnv type_env name of
Just TyThing
thing -> TyThing -> IfL TyThing
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing
Maybe TyThing
Nothing -> IfL TyThing
via_external
}
Maybe (IfG TypeEnv)
_ -> IfL TyThing
via_external }
where
via_external :: IfL TyThing
via_external = do
{ hsc_env <- TcRnIf IfGblEnv IfLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; mb_thing <- liftIO (lookupType hsc_env name)
; case mb_thing of {
Just TyThing
thing -> TyThing -> IfL TyThing
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing ;
Maybe TyThing
Nothing -> do
{ mb_thing <- Name -> IfM IfLclEnv (MaybeErr IfaceMessage TyThing)
forall lcl. Name -> IfM lcl (MaybeErr IfaceMessage TyThing)
importDecl Name
name
; case mb_thing of
Failed IfaceMessage
err -> SDoc -> IfL TyThing
forall a. SDoc -> IfL a
failIfM (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> IfaceMessage -> SDoc
forall e. Diagnostic e => e -> SDoc
pprDiagnostic IfaceMessage
err)
Succeeded TyThing
thing -> TyThing -> IfL TyThing
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing
}}}
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon :: IfaceTyCon -> IOEnv (Env IfGblEnv IfLclEnv) TyCon
tcIfaceTyCon (IfaceTyCon Name
name IfaceTyConInfo
_info)
= do { thing <- Name -> IfL TyThing
tcIfaceGlobal Name
name
; case thing of
ATyCon TyCon
tc -> TyCon -> IOEnv (Env IfGblEnv IfLclEnv) TyCon
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tc
AConLike (RealDataCon DataCon
dc) -> TyCon -> IOEnv (Env IfGblEnv IfLclEnv) TyCon
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DataCon -> TyCon
promoteDataCon DataCon
dc)
TyThing
_ -> String -> SDoc -> IOEnv (Env IfGblEnv IfLclEnv) TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcIfaceTyCon" (TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
thing) }
tcIfaceAxiomRule :: IfaceAxiomRule -> IfL CoAxiomRule
tcIfaceAxiomRule :: IfaceAxiomRule -> IOEnv (Env IfGblEnv IfLclEnv) CoAxiomRule
tcIfaceAxiomRule (IfaceAR_X IfLclName
n)
| Just CoAxiomRule
axr <- UniqFM FastString CoAxiomRule -> FastString -> Maybe CoAxiomRule
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM FastString CoAxiomRule
typeNatCoAxiomRules (IfLclName -> FastString
ifLclNameFS IfLclName
n)
= CoAxiomRule -> IOEnv (Env IfGblEnv IfLclEnv) CoAxiomRule
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoAxiomRule
axr
| Bool
otherwise
= String -> SDoc -> IOEnv (Env IfGblEnv IfLclEnv) CoAxiomRule
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcIfaceAxiomRule" (IfLclName -> SDoc
forall a. Outputable a => a -> SDoc
ppr IfLclName
n)
tcIfaceAxiomRule (IfaceAR_U Name
name) = do { ax <- Name -> IfL (CoAxiom Unbranched)
tcIfaceUnbranchedAxiom Name
name; return (UnbranchedAxiom ax) }
tcIfaceAxiomRule (IfaceAR_B Name
name Arity
i) = do { ax <- Name -> IOEnv (Env IfGblEnv IfLclEnv) (CoAxiom Branched)
tcIfaceBranchedAxiom Name
name; return (BranchedAxiom ax i) }
tcIfaceUnbranchedAxiom :: IfExtName -> IfL (CoAxiom Unbranched)
tcIfaceUnbranchedAxiom :: Name -> IfL (CoAxiom Unbranched)
tcIfaceUnbranchedAxiom Name
name
= do { thing <- Name -> IfL TyThing
tcIfaceImplicit Name
name
; return (toUnbranchedAxiom (tyThingCoAxiom thing)) }
tcIfaceBranchedAxiom :: IfExtName -> IfL (CoAxiom Branched)
tcIfaceBranchedAxiom :: Name -> IOEnv (Env IfGblEnv IfLclEnv) (CoAxiom Branched)
tcIfaceBranchedAxiom Name
name
= do { thing <- Name -> IfL TyThing
tcIfaceImplicit Name
name
; return (tyThingCoAxiom thing) }
tcIfaceDataCon :: Name -> IfL DataCon
tcIfaceDataCon :: Name -> IOEnv (Env IfGblEnv IfLclEnv) DataCon
tcIfaceDataCon Name
name = do { thing <- Name -> IfL TyThing
tcIfaceGlobal Name
name
; case thing of
AConLike (RealDataCon DataCon
dc) -> DataCon -> IOEnv (Env IfGblEnv IfLclEnv) DataCon
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return DataCon
dc
TyThing
_ -> String -> SDoc -> IOEnv (Env IfGblEnv IfLclEnv) DataCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcIfaceDataCon" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nameSDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
thing) }
tcIfaceExtId :: Name -> IfL Id
tcIfaceExtId :: Name -> IfL CoreBndr
tcIfaceExtId Name
name = do { thing <- Name -> IfL TyThing
tcIfaceGlobal Name
name
; case thing of
AnId CoreBndr
id -> CoreBndr -> IfL CoreBndr
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreBndr
id
TyThing
_ -> String -> SDoc -> IfL CoreBndr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcIfaceExtId" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nameSDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
thing) }
tcIfaceImplicit :: Name -> IfL TyThing
tcIfaceImplicit :: Name -> IfL TyThing
tcIfaceImplicit Name
n = do
lcl_env <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
case if_implicits_env lcl_env of
Maybe TypeEnv
Nothing -> Name -> IfL TyThing
tcIfaceGlobal Name
n
Just TypeEnv
tenv ->
case TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv TypeEnv
tenv Name
n of
Maybe TyThing
Nothing -> String -> SDoc -> IfL TyThing
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcIfaceInst" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeEnv
tenv)
Just TyThing
tything -> TyThing -> IfL TyThing
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
tything
bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
bindIfaceId :: forall a. IfaceIdBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceId (IfaceType
w, IfLclName
fs, IfaceType
ty) CoreBndr -> IfL a
thing_inside
= do { name <- OccName -> TcRnIf IfGblEnv IfLclEnv Name
newIfaceName (FastString -> OccName
mkVarOccFS (IfLclName -> FastString
ifLclNameFS IfLclName
fs))
; ty' <- tcIfaceType ty
; w' <- tcIfaceType w
; let id = HasDebugCallStack => Name -> Type -> Type -> CoreBndr
Name -> Type -> Type -> CoreBndr
mkLocalIdOrCoVar Name
name Type
w' Type
ty'
; extendIfaceIdEnv [id] (thing_inside id) }
bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
bindIfaceIds :: forall a. [IfaceIdBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceIds [] [CoreBndr] -> IfL a
thing_inside = [CoreBndr] -> IfL a
thing_inside []
bindIfaceIds (IfaceIdBndr
b:[IfaceIdBndr]
bs) [CoreBndr] -> IfL a
thing_inside
= IfaceIdBndr -> (CoreBndr -> IfL a) -> IfL a
forall a. IfaceIdBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceId IfaceIdBndr
b ((CoreBndr -> IfL a) -> IfL a) -> (CoreBndr -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \CoreBndr
b' ->
[IfaceIdBndr] -> ([CoreBndr] -> IfL a) -> IfL a
forall a. [IfaceIdBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceIds [IfaceIdBndr]
bs (([CoreBndr] -> IfL a) -> IfL a) -> ([CoreBndr] -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \[CoreBndr]
bs' ->
[CoreBndr] -> IfL a
thing_inside (CoreBndr
b'CoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
:[CoreBndr]
bs')
bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceBndr :: forall a. IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceBndr (IfaceIdBndr IfaceIdBndr
bndr) CoreBndr -> IfL a
thing_inside
= IfaceIdBndr -> (CoreBndr -> IfL a) -> IfL a
forall a. IfaceIdBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceId IfaceIdBndr
bndr CoreBndr -> IfL a
thing_inside
bindIfaceBndr (IfaceTvBndr IfaceTvBndr
bndr) CoreBndr -> IfL a
thing_inside
= IfaceTvBndr -> (CoreBndr -> IfL a) -> IfL a
forall a. IfaceTvBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceTyVar IfaceTvBndr
bndr CoreBndr -> IfL a
thing_inside
bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceBndrs :: forall a. [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceBndrs [] [CoreBndr] -> IfL a
thing_inside = [CoreBndr] -> IfL a
thing_inside []
bindIfaceBndrs (IfaceBndr
b:[IfaceBndr]
bs) [CoreBndr] -> IfL a
thing_inside
= IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
forall a. IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceBndr IfaceBndr
b ((CoreBndr -> IfL a) -> IfL a) -> (CoreBndr -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \ CoreBndr
b' ->
[IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
forall a. [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceBndrs [IfaceBndr]
bs (([CoreBndr] -> IfL a) -> IfL a) -> ([CoreBndr] -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \ [CoreBndr]
bs' ->
[CoreBndr] -> IfL a
thing_inside (CoreBndr
b'CoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
:[CoreBndr]
bs')
bindIfaceForAllBndrs :: [VarBndr IfaceBndr vis] -> ([VarBndr TyCoVar vis] -> IfL a) -> IfL a
bindIfaceForAllBndrs :: forall vis a.
[VarBndr IfaceBndr vis]
-> ([VarBndr CoreBndr vis] -> IfL a) -> IfL a
bindIfaceForAllBndrs [] [VarBndr CoreBndr vis] -> IfL a
thing_inside = [VarBndr CoreBndr vis] -> IfL a
thing_inside []
bindIfaceForAllBndrs (VarBndr IfaceBndr vis
bndr:[VarBndr IfaceBndr vis]
bndrs) [VarBndr CoreBndr vis] -> IfL a
thing_inside
= VarBndr IfaceBndr vis -> (CoreBndr -> vis -> IfL a) -> IfL a
forall vis a.
VarBndr IfaceBndr vis -> (CoreBndr -> vis -> IfL a) -> IfL a
bindIfaceForAllBndr VarBndr IfaceBndr vis
bndr ((CoreBndr -> vis -> IfL a) -> IfL a)
-> (CoreBndr -> vis -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \CoreBndr
tv vis
vis ->
[VarBndr IfaceBndr vis]
-> ([VarBndr CoreBndr vis] -> IfL a) -> IfL a
forall vis a.
[VarBndr IfaceBndr vis]
-> ([VarBndr CoreBndr vis] -> IfL a) -> IfL a
bindIfaceForAllBndrs [VarBndr IfaceBndr vis]
bndrs (([VarBndr CoreBndr vis] -> IfL a) -> IfL a)
-> ([VarBndr CoreBndr vis] -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \[VarBndr CoreBndr vis]
bndrs' ->
[VarBndr CoreBndr vis] -> IfL a
thing_inside (CoreBndr -> vis -> VarBndr CoreBndr vis
forall var argf. var -> argf -> VarBndr var argf
Bndr CoreBndr
tv vis
vis VarBndr CoreBndr vis
-> [VarBndr CoreBndr vis] -> [VarBndr CoreBndr vis]
forall a. a -> [a] -> [a]
: [VarBndr CoreBndr vis]
bndrs')
bindIfaceForAllBndr :: (VarBndr IfaceBndr vis) -> (TyCoVar -> vis -> IfL a) -> IfL a
bindIfaceForAllBndr :: forall vis a.
VarBndr IfaceBndr vis -> (CoreBndr -> vis -> IfL a) -> IfL a
bindIfaceForAllBndr (Bndr (IfaceTvBndr IfaceTvBndr
tv) vis
vis) CoreBndr -> vis -> IfL a
thing_inside
= IfaceTvBndr -> (CoreBndr -> IfL a) -> IfL a
forall a. IfaceTvBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceTyVar IfaceTvBndr
tv ((CoreBndr -> IfL a) -> IfL a) -> (CoreBndr -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \CoreBndr
tv' -> CoreBndr -> vis -> IfL a
thing_inside CoreBndr
tv' vis
vis
bindIfaceForAllBndr (Bndr (IfaceIdBndr IfaceIdBndr
tv) vis
vis) CoreBndr -> vis -> IfL a
thing_inside
= IfaceIdBndr -> (CoreBndr -> IfL a) -> IfL a
forall a. IfaceIdBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceId IfaceIdBndr
tv ((CoreBndr -> IfL a) -> IfL a) -> (CoreBndr -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \CoreBndr
tv' -> CoreBndr -> vis -> IfL a
thing_inside CoreBndr
tv' vis
vis
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar :: forall a. IfaceTvBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceTyVar (IfLclName
occ,IfaceType
kind) CoreBndr -> IfL a
thing_inside
= do { name <- OccName -> TcRnIf IfGblEnv IfLclEnv Name
newIfaceName (FastString -> OccName
mkTyVarOccFS (IfLclName -> FastString
ifLclNameFS IfLclName
occ))
; tyvar <- mk_iface_tyvar name kind
; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
bindIfaceTyVars :: forall a. [IfaceTvBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceTyVars [] [CoreBndr] -> IfL a
thing_inside = [CoreBndr] -> IfL a
thing_inside []
bindIfaceTyVars (IfaceTvBndr
bndr:[IfaceTvBndr]
bndrs) [CoreBndr] -> IfL a
thing_inside
= IfaceTvBndr -> (CoreBndr -> IfL a) -> IfL a
forall a. IfaceTvBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceTyVar IfaceTvBndr
bndr ((CoreBndr -> IfL a) -> IfL a) -> (CoreBndr -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \CoreBndr
tv ->
[IfaceTvBndr] -> ([CoreBndr] -> IfL a) -> IfL a
forall a. [IfaceTvBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceTyVars [IfaceTvBndr]
bndrs (([CoreBndr] -> IfL a) -> IfL a) -> ([CoreBndr] -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \[CoreBndr]
tvs ->
[CoreBndr] -> IfL a
thing_inside (CoreBndr
tv CoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
: [CoreBndr]
tvs)
mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
mk_iface_tyvar :: Name -> IfaceType -> IfL CoreBndr
mk_iface_tyvar Name
name IfaceType
ifKind
= do { kind <- IfaceType -> IfL Type
tcIfaceType IfaceType
ifKind
; return (Var.mkTyVar name kind) }
bindIfaceTyConBinders :: [IfaceTyConBinder]
-> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders :: forall a. [IfaceTyConBinder] -> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders [] [TyConBinder] -> IfL a
thing_inside = [TyConBinder] -> IfL a
thing_inside []
bindIfaceTyConBinders (IfaceTyConBinder
b:[IfaceTyConBinder]
bs) [TyConBinder] -> IfL a
thing_inside
= (IfaceBndr -> (CoreBndr -> IfL a) -> IfL a)
-> IfaceTyConBinder -> (TyConBinder -> IfL a) -> IfL a
forall a.
(IfaceBndr -> (CoreBndr -> IfL a) -> IfL a)
-> IfaceTyConBinder -> (TyConBinder -> IfL a) -> IfL a
bindIfaceTyConBinderX IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
forall a. IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceBndr IfaceTyConBinder
b ((TyConBinder -> IfL a) -> IfL a)
-> (TyConBinder -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \ TyConBinder
b' ->
[IfaceTyConBinder] -> ([TyConBinder] -> IfL a) -> IfL a
forall a. [IfaceTyConBinder] -> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders [IfaceTyConBinder]
bs (([TyConBinder] -> IfL a) -> IfL a)
-> ([TyConBinder] -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
bs' ->
[TyConBinder] -> IfL a
thing_inside (TyConBinder
b'TyConBinder -> [TyConBinder] -> [TyConBinder]
forall a. a -> [a] -> [a]
:[TyConBinder]
bs')
bindIfaceTyConBinders_AT :: [IfaceTyConBinder]
-> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders_AT :: forall a. [IfaceTyConBinder] -> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders_AT [] [TyConBinder] -> IfL a
thing_inside
= [TyConBinder] -> IfL a
thing_inside []
bindIfaceTyConBinders_AT (IfaceTyConBinder
b : [IfaceTyConBinder]
bs) [TyConBinder] -> IfL a
thing_inside
= (IfaceBndr -> (CoreBndr -> IfL a) -> IfL a)
-> IfaceTyConBinder -> (TyConBinder -> IfL a) -> IfL a
forall a.
(IfaceBndr -> (CoreBndr -> IfL a) -> IfL a)
-> IfaceTyConBinder -> (TyConBinder -> IfL a) -> IfL a
bindIfaceTyConBinderX IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
forall a. IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
bind_tv IfaceTyConBinder
b ((TyConBinder -> IfL a) -> IfL a)
-> (TyConBinder -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \TyConBinder
b' ->
[IfaceTyConBinder] -> ([TyConBinder] -> IfL a) -> IfL a
forall a. [IfaceTyConBinder] -> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders_AT [IfaceTyConBinder]
bs (([TyConBinder] -> IfL a) -> IfL a)
-> ([TyConBinder] -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \[TyConBinder]
bs' ->
[TyConBinder] -> IfL a
thing_inside (TyConBinder
b'TyConBinder -> [TyConBinder] -> [TyConBinder]
forall a. a -> [a] -> [a]
:[TyConBinder]
bs')
where
bind_tv :: IfaceBndr
-> (CoreBndr -> IOEnv (Env IfGblEnv IfLclEnv) b)
-> IOEnv (Env IfGblEnv IfLclEnv) b
bind_tv IfaceBndr
tv CoreBndr -> IOEnv (Env IfGblEnv IfLclEnv) b
thing
= do { mb_tv <- IfaceBndr -> IfL (Maybe CoreBndr)
lookupIfaceVar IfaceBndr
tv
; case mb_tv of
Just CoreBndr
b' -> CoreBndr -> IOEnv (Env IfGblEnv IfLclEnv) b
thing CoreBndr
b'
Maybe CoreBndr
Nothing -> IfaceBndr
-> (CoreBndr -> IOEnv (Env IfGblEnv IfLclEnv) b)
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall a. IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceBndr IfaceBndr
tv CoreBndr -> IOEnv (Env IfGblEnv IfLclEnv) b
thing }
bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a)
-> IfaceTyConBinder
-> (TyConBinder -> IfL a) -> IfL a
bindIfaceTyConBinderX :: forall a.
(IfaceBndr -> (CoreBndr -> IfL a) -> IfL a)
-> IfaceTyConBinder -> (TyConBinder -> IfL a) -> IfL a
bindIfaceTyConBinderX IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
bind_tv (Bndr IfaceBndr
tv TyConBndrVis
vis) TyConBinder -> IfL a
thing_inside
= IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
bind_tv IfaceBndr
tv ((CoreBndr -> IfL a) -> IfL a) -> (CoreBndr -> IfL a) -> IfL a
forall a b. (a -> b) -> a -> b
$ \CoreBndr
tv' ->
TyConBinder -> IfL a
thing_inside (CoreBndr -> TyConBndrVis -> TyConBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr CoreBndr
tv' TyConBndrVis
vis)
hydrateCgBreakInfo :: CgBreakInfo -> IfL ([Maybe (Id, Word)], Type)
hydrateCgBreakInfo :: CgBreakInfo -> IfL ([Maybe (CoreBndr, Word)], Type)
hydrateCgBreakInfo CgBreakInfo{[Maybe (IfaceIdBndr, Word)]
[IfaceTvBndr]
IfaceType
cgb_tyvars :: [IfaceTvBndr]
cgb_vars :: [Maybe (IfaceIdBndr, Word)]
cgb_resty :: IfaceType
cgb_resty :: CgBreakInfo -> IfaceType
cgb_vars :: CgBreakInfo -> [Maybe (IfaceIdBndr, Word)]
cgb_tyvars :: CgBreakInfo -> [IfaceTvBndr]
..} = do
[IfaceTvBndr]
-> ([CoreBndr] -> IfL ([Maybe (CoreBndr, Word)], Type))
-> IfL ([Maybe (CoreBndr, Word)], Type)
forall a. [IfaceTvBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceTyVars [IfaceTvBndr]
cgb_tyvars (([CoreBndr] -> IfL ([Maybe (CoreBndr, Word)], Type))
-> IfL ([Maybe (CoreBndr, Word)], Type))
-> ([CoreBndr] -> IfL ([Maybe (CoreBndr, Word)], Type))
-> IfL ([Maybe (CoreBndr, Word)], Type)
forall a b. (a -> b) -> a -> b
$ \[CoreBndr]
_ -> do
result_ty <- IfaceType -> IfL Type
tcIfaceType IfaceType
cgb_resty
mbVars <- mapM (traverse (\(IfaceIdBndr
if_gbl, Word
offset) -> (,Word
offset) (CoreBndr -> (CoreBndr, Word))
-> IfL CoreBndr -> IOEnv (Env IfGblEnv IfLclEnv) (CoreBndr, Word)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceIdBndr -> (CoreBndr -> IfL CoreBndr) -> IfL CoreBndr
forall a. IfaceIdBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceId IfaceIdBndr
if_gbl CoreBndr -> IfL CoreBndr
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return)) cgb_vars
return (mbVars, result_ty)
tcIfaceImport :: HscEnv -> IfaceImport -> ImportUserSpec
tcIfaceImport :: HscEnv -> IfaceImport -> ImportUserSpec
tcIfaceImport HscEnv
_ (IfaceImport ImpDeclSpec
spec ImpIfaceList
ImpIfaceAll) = ImpDeclSpec -> ImpUserList -> ImportUserSpec
ImpUserSpec ImpDeclSpec
spec ImpUserList
ImpUserAll
tcIfaceImport HscEnv
_ (IfaceImport ImpDeclSpec
spec (ImpIfaceEverythingBut NameSet
ns)) = ImpDeclSpec -> ImpUserList -> ImportUserSpec
ImpUserSpec ImpDeclSpec
spec (NameSet -> ImpUserList
ImpUserEverythingBut NameSet
ns)
tcIfaceImport HscEnv
hsc_env (IfaceImport ImpDeclSpec
spec (ImpIfaceExplicit IfGlobalRdrEnv
gre)) = ImpDeclSpec -> ImpUserList -> ImportUserSpec
ImpUserSpec ImpDeclSpec
spec (GlobalRdrEnv -> ImpUserList
ImpUserExplicit ((Name -> IO GREInfo) -> IfGlobalRdrEnv -> GlobalRdrEnv
forall info noInfo.
(Name -> IO info) -> GlobalRdrEnvX noInfo -> GlobalRdrEnvX info
hydrateGlobalRdrEnv Name -> IO GREInfo
get_GRE_info IfGlobalRdrEnv
gre))
where
get_GRE_info :: Name -> IO GREInfo
get_GRE_info Name
nm = TyThing -> GREInfo
tyThingGREInfo (TyThing -> GREInfo) -> IO TyThing -> IO GREInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env Name
nm