Commit f92591de authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor HsDecls again, to put family instances in InstDecl

This continues the clean up of the front end.  Since they
were first invented, type and data family *instance* decls
have been in the TyClDecl data type, even though they always
treated separately.

This patch takes a step in the right direction
  * The InstDecl type now includes both class instances and
    type/data family instances

  * The hs_tyclds field of HsGroup now never has any family
    instance declarations in it

However a family instance is still a TyClDecl.  It should really
be a separate type, but that's the next step.

All this was provoked by fixing Trac #5792 in the HEAD.
(I did a less invasive fix on the branch.)
parent 97741318
......@@ -129,10 +129,12 @@ repTopDs group
decls <- addBinds ss (do {
val_ds <- rep_val_binds (hs_valds group) ;
tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
inst_ds <- mapM repInstD' (hs_instds group) ;
inst_ds <- mapM repInstD (hs_instds group) ;
for_ds <- mapM repForD (hs_fords group) ;
-- more needed
return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
return (de_loc $ sort_by_loc $
val_ds ++ catMaybes tycl_ds
++ catMaybes inst_ds ++ for_ds) }) ;
decl_ty <- lookupType decQTyConName ;
let { core_list = coreList' decl_ty decls } ;
......@@ -307,8 +309,12 @@ repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD
-- represent instance declarations
--
repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now
repInstD :: LInstDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
repInstD (L loc (FamInstDecl fi_decl))
= repTyClD (L loc fi_decl)
repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now
= do { dec <- addTyVarBinds tvs $ \_ ->
-- We must bring the type variables into scope, so their
-- occurrences don't fail, even though the binders don't
......@@ -327,7 +333,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now
; ats1 <- repLAssocFamInst ats
; decls <- coreList decQTyConName (ats1 ++ binds1)
; repInst cxt1 inst_ty1 decls }
; return (loc, dec) }
; return (Just (loc, dec)) }
where
Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty)
......
......@@ -195,7 +195,7 @@ cvtDec (InstanceD ctxt ty decs)
; ctxt' <- cvtContext ctxt
; L loc ty' <- cvtType ty
; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats') }
; returnL $ InstD (ClsInstDecl inst_ty' binds' sigs' ats') }
cvtDec (ForeignD ford)
= do { ford' <- cvtForD ford
......@@ -213,23 +213,25 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
= do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
, tcdCons = cons', tcdDerivs = derivs' }) }
; returnL $ InstD $ FamInstDecl $
TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
, tcdCons = cons', tcdDerivs = derivs' } }
cvtDec (NewtypeInstD ctxt tc tys constr derivs)
= do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
, tcdCons = [con'], tcdDerivs = derivs' })
}
; returnL $ InstD $ FamInstDecl $
TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
, tcdCons = [con'], tcdDerivs = derivs' } }
cvtDec (TySynInstD tc tys rhs)
= do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
; rhs' <- cvtType rhs
; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') }
; returnL $ InstD $ FamInstDecl $
TySynonym tc' tvs' tys' rhs' }
----------------
cvt_ci_decs :: MsgDoc -> [TH.Dec]
......
......@@ -18,9 +18,11 @@ module HsDecls (
isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
isFamInstDecl, tcdName, tyClDeclTyVars,
countTyClDecls,
-- ** Instance declarations
InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..),
instDeclATs,
FamInstDecl, LFamInstDecl, instDeclFamInsts,
-- ** Standalone deriving declarations
DerivDecl(..), LDerivDecl,
-- ** @RULE@ declarations
......@@ -128,12 +130,15 @@ data HsGroup id
= HsGroup {
hs_valds :: HsValBinds id,
hs_tyclds :: [[LTyClDecl id]],
hs_tyclds :: [[LTyClDecl id]],
-- A list of mutually-recursive groups
-- No family-instances here; they are in hs_instds
-- Parser generates a singleton list;
-- renamer does dependency analysis
hs_instds :: [LInstDecl id],
hs_instds :: [LInstDecl id],
-- Both class and family instance declarations in here
hs_derivds :: [LDerivDecl id],
hs_fixds :: [LFixitySig id],
......@@ -154,7 +159,8 @@ emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [],
hs_derivds = [],
hs_fixds = [], hs_defds = [], hs_annds = [],
hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],
hs_valds = error "emptyGroup hs_valds: Can't happen",
......@@ -430,8 +436,9 @@ Interface file code:
-- In both cases, 'tcdVars' collects all variables we need to quantify over.
type LTyClDecl name = Located (TyClDecl name)
type TyClGroup name = [LTyClDecl name] -- this is used in TcTyClsDecls to represent
type TyClGroup name = [LTyClDecl name] -- This is used in TcTyClsDecls to represent
-- strongly connected components of decls
-- No familiy instances in here
-- | A type or class declaration.
data TyClDecl name
......@@ -504,7 +511,7 @@ data TyClDecl name
tcdMeths :: LHsBinds name, -- ^ Default methods
tcdATs :: [LTyClDecl name], -- ^ Associated types; ie
-- only 'TyFamily'
tcdATDefs :: [LTyClDecl name], -- ^ Associated type defaults; ie
tcdATDefs :: [LFamInstDecl name], -- ^ Associated type defaults; ie
-- only 'TySynonym'
tcdDocs :: [LDocDecl] -- ^ Haddock docs
}
......@@ -602,15 +609,14 @@ tyClDeclTyVars (ForeignType {}) = []
\end{code}
\begin{code}
countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int)
-- class, synonym decls, data, newtype, family decls, family instances
countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int)
-- class, synonym decls, data, newtype, family decls
countTyClDecls decls
= (count isClassDecl decls,
count isSynDecl decls, -- excluding...
count isDataTy decls, -- ...family...
count isNewTy decls, -- ...instances
count isFamilyDecl decls,
count isFamInstDecl decls)
count isFamilyDecl decls)
where
isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True
isDataTy _ = False
......@@ -833,18 +839,25 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG
\begin{code}
type LInstDecl name = Located (InstDecl name)
data InstDecl name
= InstDecl (LHsType name) -- Context => Class Instance-type
-- Using a polytype means that the renamer conveniently
-- figures out the quantified type variables for us.
(LHsBinds name)
[LSig name] -- User-supplied pragmatic info
[LTyClDecl name]-- Associated types (ie, 'TyData' and
-- 'TySynonym' only)
type LFamInstDecl name = Located (FamInstDecl name)
type FamInstDecl name = TyClDecl name -- Type or data family instance
data InstDecl name -- Both class and family instances
= ClsInstDecl
(LHsType name) -- Context => Class Instance-type
-- Using a polytype means that the renamer conveniently
-- figures out the quantified type variables for us.
(LHsBinds name)
[LSig name] -- User-supplied pragmatic info
[LFamInstDecl name] -- Family instances for associated types
| FamInstDecl -- type/data family instance
(FamInstDecl name)
deriving (Data, Typeable)
instance (OutputableBndr name) => Outputable (InstDecl name) where
ppr (InstDecl inst_ty binds sigs ats)
ppr (ClsInstDecl inst_ty binds sigs ats)
| null sigs && null ats && isEmptyBag binds -- No "where" part
= top_matter
......@@ -855,10 +868,16 @@ instance (OutputableBndr name) => Outputable (InstDecl name) where
where
top_matter = ptext (sLit "instance") <+> ppr inst_ty
ppr (FamInstDecl decl) = ppr decl
-- Extract the declarations of associated types from an instance
--
instDeclATs :: [LInstDecl name] -> [LTyClDecl name]
instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats]
instDeclFamInsts :: [LInstDecl name] -> [LTyClDecl name]
instDeclFamInsts inst_decls
= concatMap do_one inst_decls
where
do_one (L _ (ClsInstDecl _ _ _ fam_insts)) = fam_insts
do_one (L loc (FamInstDecl fam_inst)) = [L loc fam_inst]
\end{code}
%************************************************************************
......
......@@ -68,7 +68,7 @@ module HsUtils(
collectLStmtBinders, collectStmtBinders,
collectSigTysFromPats, collectSigTysFromPat,
hsTyClDeclBinders, hsTyClDeclsBinders,
hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders,
hsForeignDeclsBinders, hsGroupBinders,
-- Collecting implicit binders
......@@ -619,29 +619,33 @@ hsForeignDeclsBinders foreign_decls
= [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls]
hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
-- We need to look at instance declarations too,
-- because their associated types may bind data constructors
hsTyClDeclsBinders tycl_decls inst_decls
= [n | d <- instDeclATs inst_decls ++ concat tycl_decls
, L _ n <- hsTyClDeclBinders d]
= [n | d <- instDeclFamInsts inst_decls ++ concat tycl_decls
, L _ n <- hsLTyClDeclBinders d]
hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
-- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
-- The first one is guaranteed to be the name of the decl. For record fields
-- mentioned in multiple constructors, the SrcLoc will be from the first
-- occurence. We use the equality to filter out duplicate field names
hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d
hsTyClDeclBinders (L _ (TyFamily {tcdLName = name})) = [name]
hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name]
hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name]
hsTyClDeclBinders (TyFamily {tcdLName = name}) = [name]
hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name]
hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}))
hsTyClDeclBinders (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
= cls_name :
concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns]
concatMap hsLTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns]
hsTyClDeclBinders (L _ (TySynonym {tcdLName = name, tcdTyPats = mb_pats }))
hsTyClDeclBinders (TySynonym {tcdLName = name, tcdTyPats = mb_pats })
| isJust mb_pats = []
| otherwise = [name]
-- See Note [Binders in family instances]
hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats }))
hsTyClDeclBinders (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats })
| isJust mb_pats = hsConDeclsBinders cons
| otherwise = tc_name : hsConDeclsBinders cons
-- See Note [Binders in family instances]
......
......@@ -52,7 +52,6 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
("DataDecls ", data_ds),
("NewTypeDecls ", newt_ds),
("TypeFamilyDecls ", type_fam_ds),
("FamilyInstDecls ", fam_inst_ds),
("DataConstrs ", data_constrs),
("DataDerivings ", data_derivs),
("ClassDecls ", class_ds),
......@@ -89,7 +88,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
-- in class decls. ToDo
tycl_decls = [d | TyClD d <- decls]
(class_ds, type_ds, data_ds, newt_ds, type_fam_ds, fam_inst_ds) =
(class_ds, type_ds, data_ds, newt_ds, type_fam_ds) =
countTyClDecls tycl_decls
inst_decls = [d | InstD d <- decls]
......@@ -153,7 +152,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
class_info _ = (0,0)
inst_info (InstDecl _ inst_meths inst_sigs ats)
inst_info (FamInstDecl d) = case countATDecl d of
(tyd, dtd) -> (0,0,0,tyd,dtd)
inst_info (ClsInstDecl _ inst_meths inst_sigs ats)
= case count_sigs (map unLoc inst_sigs) of
(_,_,ss,is,_) ->
case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
......@@ -162,9 +163,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(map (count_bind.unLoc) (bagToList inst_meths))),
ss, is, tyDecl, dtDecl)
where
countATDecl (TyData {}) = (0, 1)
countATDecl (TySynonym {}) = (1, 0)
countATDecl d = pprPanic "countATDecl: Unhandled decl"
countATDecl (TyData {}) = (0, 1)
countATDecl (TySynonym {}) = (1, 0)
countATDecl d = pprPanic "countATDecl: Unhandled decl"
(ppr d)
addpr :: (Int,Int) -> Int
......
......@@ -567,10 +567,7 @@ topdecls :: { OrdList (LHsDecl RdrName) }
topdecl :: { OrdList (LHsDecl RdrName) }
: cl_decl { unitOL (L1 (TyClD (unLoc $1))) }
| ty_decl { unitOL (L1 (TyClD (unLoc $1))) }
| 'instance' inst_type where_inst
{ let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
in
unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))}
| inst_decl { unitOL (L1 (InstD (unLoc $1))) }
| stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) }
| 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
| 'foreign' fdecl { unitOL (LL (unLoc $2)) }
......@@ -629,12 +626,6 @@ ty_decl :: { LTyClDecl RdrName }
-- infix type constructors to be declared
{% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) }
-- type instance declarations
| 'type' 'instance' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% mkTySynonym (comb2 $1 $5) True $3 $5 }
-- ordinary data type or newtype declaration
| data_or_newtype tycl_hdr constrs deriving
{% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) False $2
......@@ -655,18 +646,32 @@ ty_decl :: { LTyClDecl RdrName }
| 'data' 'family' type opt_kind_sig
{% mkTyFamily (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) }
inst_decl :: { LInstDecl RdrName }
: 'instance' inst_type where_inst
{ let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
in L (comb3 $1 $2 $3) (ClsInstDecl $2 binds sigs ats) }
-- type instance declarations
| 'type' 'instance' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% do { L loc d <- mkTySynonym (comb2 $1 $5) True $3 $5
; return (L loc (FamInstDecl d)) } }
-- data/newtype instance declaration
| data_or_newtype 'instance' tycl_hdr constrs deriving
{% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3
Nothing (reverse (unLoc $4)) (unLoc $5) }
{% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3
Nothing (reverse (unLoc $4)) (unLoc $5)
; return (L loc (FamInstDecl d)) } }
-- GADT instance declaration
| data_or_newtype 'instance' tycl_hdr opt_kind_sig
gadt_constrlist
deriving
{% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3
(unLoc $4) (unLoc $5) (unLoc $6) }
{% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3
(unLoc $4) (unLoc $5) (unLoc $6)
; return (L loc (FamInstDecl d)) } }
-- Associated type family declarations
--
-- * They have a different syntax than on the toplevel (no family special
......
......@@ -486,12 +486,8 @@ getLocalNonValBinders fixity_env
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_fords = foreign_decls })
= do { -- Separate out the family instance declarations
let (tyinst_decls, tycl_decls_noinsts)
= partition (isFamInstDecl . unLoc) (concat tycl_decls)
-- Process all type/class decls *except* family instances
; tc_avails <- mapM new_tc tycl_decls_noinsts
= do { -- Process all type/class decls *except* family instances
; tc_avails <- mapM new_tc (concat tycl_decls)
; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
; setEnvs envs $ do {
-- Bring these things into scope first
......@@ -499,7 +495,6 @@ getLocalNonValBinders fixity_env
-- Process all family instances
-- to bring new data constructors into scope
; ti_avails <- mapM (new_ti Nothing) tyinst_decls
; nti_avails <- concatMapM new_assoc inst_decls
-- Finish off with value binders:
......@@ -510,7 +505,7 @@ getLocalNonValBinders fixity_env
| otherwise = for_hs_bndrs
; val_avails <- mapM new_simple val_bndrs
; let avails = ti_avails ++ nti_avails ++ val_avails
; let avails = nti_avails ++ val_avails
new_bndrs = availsToNameSet avails `unionNameSets`
availsToNameSet tc_avails
; envs <- extendGlobalRdrEnvRn avails fixity_env
......@@ -529,20 +524,25 @@ getLocalNonValBinders fixity_env
; return (Avail nm) }
new_tc tc_decl -- NOT for type/data instances
= do { names@(main_name : _) <- mapM newTopSrcBinder (hsTyClDeclBinders tc_decl)
= do { let bndrs = hsTyClDeclBinders (unLoc tc_decl)
; names@(main_name : _) <- mapM newTopSrcBinder bndrs
; return (AvailTC main_name names) }
new_ti :: Maybe Name -> LTyClDecl RdrName -> RnM AvailInfo
new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo
new_ti mb_cls ti_decl -- ONLY for type/data instances
= do { main_name <- lookupTcdName mb_cls (unLoc ti_decl)
= ASSERT( isFamInstDecl ti_decl )
do { main_name <- lookupTcdName mb_cls ti_decl
; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl)
; return (AvailTC (unLoc main_name) sub_names) }
-- main_name is not bound here!
new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
new_assoc (L _ (InstDecl inst_ty _ _ ats))
new_assoc (L _ (FamInstDecl d))
= do { avail <- new_ti Nothing d
; return [avail] }
new_assoc (L _ (ClsInstDecl inst_ty _ _ ats))
= do { mb_cls_nm <- get_cls_parent inst_ty
; mapM (new_ti mb_cls_nm) ats }
; mapM (new_ti mb_cls_nm . unLoc) ats }
where
get_cls_parent inst_ty
| Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty
......@@ -551,7 +551,8 @@ getLocalNonValBinders fixity_env
= return Nothing
lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name)
-- Used for TyData and TySynonym only
-- Used for TyData and TySynonym only,
-- both ordinary ones and family instances
-- See Note [Family instance binders]
lookupTcdName mb_cls tc_decl
| not (isFamInstDecl tc_decl) -- The normal case
......
......@@ -424,7 +424,11 @@ patchCCallTarget packageId callTarget
\begin{code}
rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
rnSrcInstDecl (FamInstDecl ty_decl)
= do { (ty_decl', fvs) <- rnTyClDecl Nothing ty_decl
; return (FamInstDecl ty_decl', fvs) }
rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats)
-- Used for both source and interface file decls
= do { inst_ty' <- rnLHsInstType (text "In an instance declaration") inst_ty
; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty'
......@@ -460,7 +464,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
renameSigs (InstDeclCtxt cls) spec_inst_prags
; let uprags' = spec_inst_prags' ++ other_sigs'
; return (InstDecl inst_ty' mbinds' uprags' ats',
; return (ClsInstDecl inst_ty' mbinds' uprags' ats',
meth_fvs `plusFV` more_fvs
`plusFV` hsSigsFVs spec_inst_prags'
`plusFV` extractHsTyNames inst_ty') }
......@@ -764,6 +768,7 @@ rnTyClDecls extra_deps tycl_ds
all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs'
; traceRn (text "rnTycl" <+> (ppr ds_w_fvs $$ ppr sccs))
; return (map flattenSCC sccs, all_fvs) }
......@@ -995,12 +1000,16 @@ depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
depAnalTyClDecls ds_w_fvs
= stronglyConnCompFromEdgedVertices edges
where
edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs))
edges = [ (d, tcdName (unLoc d), map get_parent (nameSetToList fvs))
| (d, fvs) <- ds_w_fvs ]
get_assoc n = lookupNameEnv assoc_env n `orElse` n
-- We also need to consider data constructor names since
-- they may appear in types because of promotion.
get_parent n = lookupNameEnv assoc_env n `orElse` n
assoc_env :: NameEnv Name -- Maps a data constructor back
-- to its parent type constructor
assoc_env = mkNameEnv assoc_env_list
-- We also need to consider data constructor names since they may
-- appear in types because of promotion.
assoc_env_list = do
(L _ d, _) <- ds_w_fvs
case d of
......@@ -1210,7 +1219,7 @@ extendRecordFieldEnv tycl_decls inst_decls
all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
, L _ con <- cons ]
all_tycl_decls = at_tycl_decls ++ concat tycl_decls
at_tycl_decls = instDeclATs inst_decls -- Do not forget associated types!
at_tycl_decls = instDeclFamInsts inst_decls -- Do not forget associated types!
get_con (ConDecl { con_name = con, con_details = RecCon flds })
(RecFields env fld_set)
......
......@@ -459,7 +459,7 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
all_tydata :: [(LHsType Name, LTyClDecl Name)]
-- Derived predicate paired with its data type declaration
all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls)
all_tydata = extractTyDataPreds (instDeclFamInsts inst_decls ++ tycl_decls)
deriv_locs = map (getLoc . snd) all_tydata
++ map getLoc deriv_decls
......
......@@ -371,17 +371,16 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
-- round)
-- (1) Do class and family instance declarations
; fam_insts <- mapAndRecoverM tcTopFamInstDecl $
filter (isFamInstDecl . unLoc) tycl_decls
; inst_decl_stuff <- mapAndRecoverM tcLocalInstDecl1 inst_decls
; inst_decl_stuff <- mapAndRecoverM tcLocalInstDecl1 inst_decls
; let { (local_info, at_fam_insts_s) = unzip inst_decl_stuff
; all_fam_insts = concat at_fam_insts_s ++ fam_insts }
; let { (local_infos_s, fam_insts_s) = unzip inst_decl_stuff
; all_fam_insts = concat fam_insts_s
; local_infos = concat local_infos_s }
-- (2) Next, construct the instance environment so far, consisting of
-- (a) local instance decls
-- (b) local family instance decls
; addClsInsts local_info $
; addClsInsts local_infos $
addFamInsts all_fam_insts $ do
-- (3) Compute instances from "deriving" clauses;
......@@ -403,13 +402,13 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
; when (safeLanguageOn dflags) $
mapM_ (\x -> when (typInstCheck x)
(addErrAt (getSrcSpan $ iSpec x) typInstErr))
local_info
local_infos
-- As above but for Safe Inference mode.
; when (safeInferOn dflags) $
mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_info
mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_infos
; return ( gbl_env
, (bagToList deriv_inst_info) ++ local_info
, bagToList deriv_inst_info ++ local_infos
, deriv_binds)
}}
where
......@@ -437,12 +436,18 @@ addFamInsts fam_insts thing_inside
\begin{code}
tcLocalInstDecl1 :: LInstDecl Name
-> TcM (InstInfo Name, [FamInst])
-> TcM ([InstInfo Name], [FamInst])
-- A source-file instance declaration
-- Type-check all the stuff before the "where"
--
-- We check for respectable instance type, and context
tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
tcLocalInstDecl1 (L loc (FamInstDecl decl))
= setSrcSpan loc $
tcAddDeclCtxt decl $
do { fam_inst <- tcFamInstDecl TopLevel decl
; return ([], [fam_inst]) }
tcLocalInstDecl1 (L loc (ClsInstDecl poly_ty binds uprags ats))
= setSrcSpan loc $
addErrCtxt (instDeclCtxt1 poly_ty) $
......@@ -500,7 +505,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
ispec = mkLocalInstance dfun overlap_flag
inst_info = InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False }
; return ( inst_info, fam_insts0 ++ concat fam_insts1) }
; return ( [inst_info], fam_insts0 ++ concat fam_insts1) }
\end{code}
%************************************************************************
......@@ -515,12 +520,6 @@ lot of kinding and type checking code with ordinary algebraic data types (and
GADTs).
\begin{code}
tcTopFamInstDecl :: LTyClDecl Name -> TcM FamInst
tcTopFamInstDecl (L loc decl)
= setSrcSpan loc $
tcAddDeclCtxt decl $
tcFamInstDecl TopLevel decl
tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM FamInst
tcFamInstDecl top_lvl decl
= do { -- Type family instances require -XTypeFamilies
......
......@@ -101,13 +101,10 @@ tcTyAndClassDecls :: ModDetails
-> TcM TcGblEnv -- Input env extended by types and classes
-- and their implicit Ids,DataCons
-- Fails if there are any errors
tcTyAndClassDecls boot_details decls_s
= checkNoErrs $ do -- The code recovers internally, but if anything gave rise to
tcTyAndClassDecls boot_details tyclds_s
= checkNoErrs $ -- The code recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
{ let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s
-- Remove family instance decls altogether
-- They are dealt with by TcInstDcls
; fold_env tyclds_s } -- type check each group in dependency order folding the global env
fold_env tyclds_s -- type check each group in dependency order folding the global env
where
fold_env :: [TyClGroup Name] -> TcM TcGblEnv
fold_env [] = getGblEnv
......@@ -379,7 +376,7 @@ kcTyClDecl decl@(TyFamily {})
= kcFamilyDecl [] decl -- the empty list signals a toplevel decl
kcTyClDecl decl@(TyData {})
= ASSERT( not . isFamInstDecl $ decl ) -- must not be a family instance
= ASSERT2( not . isFamInstDecl $ decl, ppr decl ) -- must not be a family instance
kcTyClDeclBody decl $ \_ -> kcDataDecl decl
kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
......
......@@ -253,7 +253,7 @@ boundValues mod group =
, bind <- bagToList binds
, x <- boundThings mod bind ]
_other -> error "boundValues"
tys = [ n | ns <- map hsTyClDeclBinders (concat (hs_tyclds group))
tys = [ n | ns <- map hsLTyClDeclBinders (concat (hs_tyclds group))
, n <- map found ns ]
fors = concat $ map forBound (hs_fords group)
where forBound lford = case unLoc lford of
......
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