Commit 1fa3580c authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Fix Trac #2412: type synonyms and hs-boot recursion

Max Bolingbroke found this awkward bug, which relates to the way in
which hs-boot files are handled.

   --> HEADS UP: interface file format change: recompile everything!

When we import a type synonym, we want to *refrain* from looking at its
RHS until we've "tied the knot" in the module being compiled.  (Reason:
the type synonym might ultimately loop back to the module being compiled.)
To achieve this goal we need to know the *kind* of the synonym without 
looking at its RHS.  And to do that we need its kind recorded in the interface
file.

I slightly refactored the way that the IfaceSyn data constructor
fields work, eliminating the previous tricky re-use of the same field
as either a type or a kind.

See Note [Synonym kind loop] in TcIface
parent 96438b89
......@@ -39,22 +39,23 @@ import Data.List
------------------------------------------------------
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
})
......
......@@ -81,11 +81,10 @@ data IfaceDecl
| 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
......@@ -426,15 +425,15 @@ pprIfaceDecl (IfaceForeign {ifName = tycon})
= 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,
......@@ -668,7 +667,7 @@ freeNamesIfDecl d@IfaceData{} =
freeNamesIfConDecls (ifCons d)
freeNamesIfDecl d@IfaceSyn{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfType (ifSynRhs d) &&&
freeNamesIfSynRhs (ifSynRhs d) &&&
freeNamesIfTcFam (ifFamInst d)
freeNamesIfDecl d@IfaceClass{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
......@@ -677,6 +676,10 @@ freeNamesIfDecl d@IfaceClass{} =
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
......
......@@ -1290,8 +1290,8 @@ tyThingToIfaceDecl (ATyCon tycon)
| 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)
}
......@@ -1312,9 +1312,10 @@ tyThingToIfaceDecl (ATyCon 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)
......
......@@ -356,14 +356,13 @@ tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdI
; 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
......@@ -385,25 +384,30 @@ tcIfaceDecl _
; 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,
......@@ -505,6 +509,23 @@ tcIfaceEqSpec spec
; 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.
%************************************************************************
%* *
......
......@@ -12,7 +12,7 @@ module TcEnv(
InstBindings(..),
-- Global environment
tcExtendGlobalEnv,
tcExtendGlobalEnv, setGlobalTypeEnv,
tcExtendGlobalValEnv,
tcLookupLocatedGlobal, tcLookupGlobal,
tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
......@@ -215,28 +215,37 @@ tcLookupFamInst tycon tys
\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}
......
......@@ -181,10 +181,11 @@ tcRnModule hsc_env hsc_src save_rn_syntax
-- 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 ;
......@@ -400,13 +401,13 @@ tcRnSrcDecls boot_iface decls
(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)
......@@ -501,7 +502,7 @@ tcRnHsBootDecls decls
; 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 _), _)
......@@ -537,15 +538,6 @@ checkHiBootIface
-- 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 " ++
......@@ -554,8 +546,17 @@ checkHiBootIface
-- 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 ()
......@@ -779,10 +780,6 @@ tcTopSrcDecls boot_details
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
......
......@@ -293,7 +293,7 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
-- (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"
......@@ -659,7 +659,8 @@ tcSynDecl
= 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)
......@@ -685,7 +686,7 @@ tcTyClDecl1 _calc_isrec
-- 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]
}
......
......@@ -227,6 +227,7 @@ buildPReprTyCon orig_tc vect_tc
liftDs $ buildSynTyCon name
tyvars
(SynonymTyCon rhs_ty)
(typeKind rhs_ty)
(Just $ mk_fam_inst prepr_tc vect_tc)
where
tyvars = tyConTyVars vect_tc
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment