------------------------------------------------------
buildSynTyCon :: Name -> [TyVar]
-> SynTyConRhs
+ -> Kind -- Kind of the RHS
-> Maybe (TyCon, [Type]) -- family instance if applicable
-> TcRnIf m n TyCon
-buildSynTyCon tc_name tvs rhs@(OpenSynTyCon rhs_ki _) _
+buildSynTyCon tc_name tvs rhs@(OpenSynTyCon {}) rhs_kind _
= let
- kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
+ kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
in
return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon
-buildSynTyCon tc_name tvs rhs@(SynonymTyCon rhs_ty) mb_family
+buildSynTyCon tc_name tvs rhs@(SynonymTyCon {}) rhs_kind mb_family
= do { -- We need to tie a knot as the coercion of a data instance depends
-- on the instance representation tycon and vice versa.
; tycon <- fixM (\ tycon_rec -> do
{ parent <- mkParentInfo mb_family tc_name tvs tycon_rec
; let { tycon = mkSynTyCon tc_name kind tvs rhs parent
- ; kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
+ ; kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
}
; return tycon
})
| IfaceSyn { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
- ifOpenSyn :: Bool, -- Is an open family?
- ifSynRhs :: IfaceType, -- Type for an ordinary
- -- synonym and kind for an
- -- open family
- ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
+ ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon)
+ ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn
+ -- Nothing for an open family
+ ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-- Just <=> instance of family
-- Invariant: ifOpenSyn == False
-- for family instances
= hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
- ifOpenSyn = False, ifSynRhs = mono_ty,
+ ifSynRhs = Just mono_ty,
ifFamInst = mbFamInst})
= hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
- ifOpenSyn = True, ifSynRhs = mono_ty})
+ ifSynRhs = Nothing, ifSynKind = kind })
= hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
- 4 (dcolon <+> ppr mono_ty)
+ 4 (dcolon <+> ppr kind)
pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
ifTyVars = tyvars, ifCons = condecls,
freeNamesIfConDecls (ifCons d)
freeNamesIfDecl d@IfaceSyn{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
- freeNamesIfType (ifSynRhs d) &&&
+ freeNamesIfSynRhs (ifSynRhs d) &&&
freeNamesIfTcFam (ifFamInst d)
freeNamesIfDecl d@IfaceClass{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
fnList freeNamesIfClsSig (ifSigs d)
-- All other changes are handled via the version info on the tycon
+freeNamesIfSynRhs :: Maybe IfaceType -> NameSet
+freeNamesIfSynRhs (Just ty) = freeNamesIfType ty
+freeNamesIfSynRhs Nothing = emptyNameSet
+
freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet
freeNamesIfTcFam (Just (tc,tys)) =
freeNamesIfTc tc &&& fnList freeNamesIfType tys
| isSynTyCon tycon
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
- ifOpenSyn = syn_isOpen,
- ifSynRhs = toIfaceType syn_tyki,
+ ifSynRhs = syn_rhs,
+ ifSynKind = syn_ki,
ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
}
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
tyvars = tyConTyVars tycon
- (syn_isOpen, syn_tyki) = case synTyConRhs tycon of
- OpenSynTyCon ki _ -> (True , ki)
- SynonymTyCon ty -> (False, ty)
+ (syn_rhs, syn_ki)
+ = case synTyConRhs tycon of
+ OpenSynTyCon ki _ -> (Nothing, toIfaceType ki)
+ SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
ifaceConDecls (NewTyCon { data_con = con }) =
IfNewTyCon (ifaceConDecl con)
; info <- tcIdInfo ignore_prags name ty info
; return (AnId (mkVanillaGlobalWithInfo name ty info)) }
-tcIfaceDecl _
- (IfaceData {ifName = occ_name,
- ifTyVars = tv_bndrs,
- ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
- ifCons = rdr_cons,
- ifRec = is_rec,
- ifGeneric = want_generic,
- ifFamInst = mb_family })
+tcIfaceDecl _ (IfaceData {ifName = occ_name,
+ ifTyVars = tv_bndrs,
+ ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
+ ifCons = rdr_cons,
+ ifRec = is_rec,
+ ifGeneric = want_generic,
+ ifFamInst = mb_family })
= do { tc_name <- lookupIfaceTop occ_name
; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
; return (ATyCon tycon)
}}
-tcIfaceDecl _
- (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
- ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty,
- ifFamInst = mb_family})
+tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
+ ifSynRhs = mb_rhs_ty,
+ ifSynKind = kind, ifFamInst = mb_family})
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
- ; rhs_tyki <- tcIfaceType rdr_rhs_ty
- ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing
- else SynonymTyCon rhs_tyki
- ; famInst <- case mb_family of
- Nothing -> return Nothing
- Just (fam, tys) ->
- do { famTyCon <- tcIfaceTyCon fam
- ; insttys <- mapM tcIfaceType tys
- ; return $ Just (famTyCon, insttys)
- }
- ; tycon <- buildSynTyCon tc_name tyvars rhs famInst
+ ; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop]
+ ; ~(rhs, fam) <- forkM (mk_doc tc_name) $
+ do { rhs <- tc_syn_rhs rhs_kind mb_rhs_ty
+ ; fam <- tc_syn_fam mb_family
+ ; return (rhs, fam) }
+ ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam
; return $ ATyCon tycon
}
+ where
+ mk_doc n = ptext (sLit "Type syonym") <+> ppr n
+ tc_syn_rhs kind Nothing = return (OpenSynTyCon kind Nothing)
+ tc_syn_rhs _ (Just ty) = do { rhs_ty <- tcIfaceType ty
+ ; return (SynonymTyCon rhs_ty) }
+ tc_syn_fam Nothing
+ = return Nothing
+ tc_syn_fam (Just (fam, tys))
+ = do { famTyCon <- tcIfaceTyCon fam
+ ; insttys <- mapM tcIfaceType tys
+ ; return $ Just (famTyCon, insttys) }
tcIfaceDecl ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name,
; return (tv,ty) }
\end{code}
+Note [Synonym kind loop]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that we eagerly grab the *kind* from the interface file, but
+build a forkM thunk for the *rhs* (and family stuff). To see why,
+consider this (Trac #2412)
+
+M.hs: module M where { import X; data T = MkT S }
+X.hs: module X where { import {-# SOURCE #-} M; type S = T }
+M.hs-boot: module M where { data T }
+
+When kind-checking M.hs we need S's kind. But we do not want to
+find S's kind from (typeKind S-rhs), because we don't want to look at
+S-rhs yet! Since S is imported from X.hi, S gets just one chance to
+be defined, and we must not do that until we've finished with M.T.
+
+Solution: record S's kind in the interface file; now we can safely
+look at it.
%************************************************************************
%* *
InstBindings(..),
-- Global environment
- tcExtendGlobalEnv,
+ tcExtendGlobalEnv, setGlobalTypeEnv,
tcExtendGlobalValEnv,
tcLookupLocatedGlobal, tcLookupGlobal,
tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
\begin{code}
+setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
+-- Use this to update the global type env
+-- It updates both * the normal tcg_type_env field
+-- * the tcg_type_env_var field seen by interface files
+setGlobalTypeEnv tcg_env new_type_env
+ = do { -- Sync the type-envt variable seen by interface files
+ writeMutVar (tcg_type_env_var tcg_env) new_type_env
+ ; return (tcg_env { tcg_type_env = new_type_env }) }
+
tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
-- Given a mixture of Ids, TyCons, Classes, all from the
-- module being compiled, extend the global environment
tcExtendGlobalEnv things thing_inside
- = do { env <- getGblEnv
- ; let ge' = extendTypeEnvList (tcg_type_env env) things
- ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
+ = do { tcg_env <- getGblEnv
+ ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things
+ ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
+ ; setGblEnv tcg_env' thing_inside }
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
-- Same deal as tcExtendGlobalEnv, but for Ids
tcExtendGlobalValEnv ids thing_inside
= tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
-\end{code}
-\begin{code}
tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
-- Extend the global environments for the type/class knot tying game
+-- Just like tcExtendGlobalEnv, except the argument is a list of pairs
tcExtendRecEnv gbl_stuff thing_inside
- = updGblEnv upd thing_inside
- where
- upd env = env { tcg_type_env = extend (tcg_type_env env) }
- extend env = extendNameEnvList env gbl_stuff
+ = do { tcg_env <- getGblEnv
+ ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff
+ ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
+ ; setGblEnv tcg_env' thing_inside }
\end{code}
-- Must be done after processing the exports
tcg_env <- checkHiBootIface tcg_env boot_iface ;
- -- Make the new type env available to stuff slurped from interface files
- -- Must do this after checkHiBootIface, because the latter might add new
- -- bindings for boot_dfuns, which may be mentioned in imported unfoldings
- writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
+ -- The new type env is already available to stuff slurped from
+ -- interface files, via TcEnv.updateGlobalTypeEnv
+ -- It's important that this includes the stuff in checkHiBootIface,
+ -- because the latter might add new bindings for boot_dfuns,
+ -- which may be mentioned in imported unfoldings
-- Rename the Haddock documentation
tcg_env <- rnHaddock module_info maybe_doc tcg_env ;
(bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
+
let { final_type_env = extendTypeEnvWithIds type_env bind_ids
- ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
- tcg_binds = binds',
+ ; tcg_env' = tcg_env { tcg_binds = binds',
tcg_rules = rules',
tcg_fords = fords' } } ;
- return (tcg_env' { tcg_binds = tcg_binds tcg_env' })
+ setGlobalTypeEnv tcg_env' final_type_env
}
tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
; type_env1 = extendTypeEnvWithIds type_env0 val_ids
; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
; dfun_ids = map iDFunId inst_infos }
- ; return (gbl_env { tcg_type_env = type_env2 })
+ ; setGlobalTypeEnv gbl_env type_env2
}}}}
spliceInHsBootErr (SpliceDecl (L loc _), _)
-- Check the exports of the boot module, one by one
; mapM_ check_export boot_exports
- -- Check instance declarations
- ; mb_dfun_prs <- mapM check_inst boot_insts
- ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds,
- tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns }
- dfun_prs = catMaybes mb_dfun_prs
- boot_dfuns = map fst dfun_prs
- dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun)
- | (boot_dfun, dfun) <- dfun_prs ]
-
-- Check for no family instances
; unless (null boot_fam_insts) $
panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
-- be the equivalent to the dfun bindings returned for class
-- instances? We can't easily equate tycons...
+ -- Check instance declarations
+ ; mb_dfun_prs <- mapM check_inst boot_insts
+ ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
+ final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns
+ dfun_prs = catMaybes mb_dfun_prs
+ boot_dfuns = map fst dfun_prs
+ dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun)
+ | (boot_dfun, dfun) <- dfun_prs ]
+
; failIfErrsM
- ; return tcg_env' }
+ ; setGlobalTypeEnv tcg_env' final_type_env }
where
check_export boot_avail -- boot_avail is exported by the boot iface
| name `elem` dfun_names = return ()
tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
-- If there are any errors, tcTyAndClassDecls fails here
- -- Make these type and class decls available to stuff slurped from interface files
- writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
-
-
setGblEnv tcg_env $ do {
-- Source-language instances, including derivings,
-- and import the supporting declarations
-- (4) construct representation tycon
; rep_tc_name <- newFamInstTyConName tc_name loc
; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
- (Just (family, t_typats))
+ (typeKind t_rhs) (Just (family, t_typats))
}}
-- "newtype instance" and "data instance"
= tcTyVarBndrs tvs $ \ tvs' -> do
{ traceTc (text "tcd1" <+> ppr tc_name)
; rhs_ty' <- tcHsKindedType rhs_ty
- ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') Nothing
+ ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty')
+ (typeKind rhs_ty') Nothing
; return (ATyCon tycon)
}
tcSynDecl d = pprPanic "tcSynDecl" (ppr d)
-- Check that we don't use families without -XTypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
- ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing
+ ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) kind Nothing
; return [ATyCon tycon]
}
liftDs $ buildSynTyCon name
tyvars
(SynonymTyCon rhs_ty)
+ (typeKind rhs_ty)
(Just $ mk_fam_inst prepr_tc vect_tc)
where
tyvars = tyConTyVars vect_tc
projects / ghc-hetmet.git / commitdiff