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

Do SCC on instance declarations (fixes Trac #5715)

The trouble here is that given

    {-# LANGUAGE DataKinds, TypeFamilies #-}
    data instance Foo a = Bar (Bar a)

we want to get a sensible message that we can't use the promoted 'Bar'
constructor until after its definition; it's a staging error.  Bud the
staging mechanism that we use for vanilla data declarations don't work
here.

Solution is to perform strongly-connected component analysis on the
instance declarations. But that in turn means that we need to track
free-variable information on more HsSyn declarations, which is why
so many files are touched.  All the changes are boiler-platey except
the ones in TcInstDcls.
parent 5aa1ae24
......@@ -24,17 +24,47 @@ module NameEnv (
foldNameEnv, filterNameEnv,
plusNameEnv, plusNameEnv_C, alterNameEnv,
lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,
elemNameEnv, mapNameEnv
elemNameEnv, mapNameEnv,
-- ** Dependency analysis
depAnal
) where
#include "HsVersions.h"
import Digraph
import Name
import Unique
import UniqFM
import Maybes
\end{code}
%************************************************************************
%* *
\subsection{Name environment}
%* *
%************************************************************************
\begin{code}
depAnal :: (node -> [Name]) -- Defs
-> (node -> [Name]) -- Uses
-> [node]
-> [SCC node]
-- Peform dependency analysis on a group of definitions,
-- where each definition may define more than one Name
--
-- The get_defs and get_uses functions are called only once per node
depAnal get_defs get_uses nodes
= stronglyConnCompFromEdgedVertices (map mk_node keyed_nodes)
where
keyed_nodes = nodes `zip` [(1::Int)..]
mk_node (node, key) = (node, key, mapCatMaybes (lookupNameEnv key_map) (get_uses node))
key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it
key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node]
\end{code}
%************************************************************************
%* *
\subsection{Name environment}
......
......@@ -78,7 +78,7 @@ module SrcLoc (
-- ** Combining and comparing Located values
eqLocated, cmpLocated, combineLocs, addCLoc,
leftmost_smallest, leftmost_largest, rightmost,
spans, isSubspanOf
spans, isSubspanOf, sortLocated
) where
#include "Typeable.h"
......@@ -181,6 +181,11 @@ instance Ord SrcLoc where
instance Ord RealSrcLoc where
compare = cmpRealSrcLoc
sortLocated :: [Located a] -> [Located a]
sortLocated things = sortLe le things
where
le (L l1 _) (L l2 _) = l1 <= l2
cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
cmpSrcLoc (UnhelpfulLoc _) (RealSrcLoc _) = GT
......
......@@ -165,8 +165,7 @@ cvtDec (TySynD tc tvs rhs)
; rhs' <- cvtType rhs
; returnL $ TyClD (TyDecl { tcdLName = tc'
, tcdTyVars = tvs'
, tcdTyDefn = TySynonym rhs'
, tcdFVs = placeHolderNames }) }
, tcdTyDefn = TySynonym rhs' placeHolderNames }) }
cvtDec (DataD ctxt tc tvs constrs derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
......@@ -175,9 +174,10 @@ cvtDec (DataD ctxt tc tvs constrs derivs)
; let defn = TyData { td_ND = DataType, td_cType = Nothing
, td_ctxt = ctxt'
, td_kindSig = Nothing
, td_cons = cons', td_derivs = derivs' }
, td_cons = cons', td_derivs = derivs'
, td_fvs = placeHolderNames }
; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdTyDefn = defn, tcdFVs = placeHolderNames }) }
, tcdTyDefn = defn }) }
cvtDec (NewtypeD ctxt tc tvs constr derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
......@@ -186,9 +186,10 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs)
; let defn = TyData { td_ND = NewType, td_cType = Nothing
, td_ctxt = ctxt'
, td_kindSig = Nothing
, td_cons = [con'], td_derivs = derivs' }
, td_cons = [con'], td_derivs = derivs'
, td_fvs = placeHolderNames }
; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdTyDefn = defn, tcdFVs = placeHolderNames }) }
, tcdTyDefn = defn }) }
cvtDec (ClassD ctxt cl tvs fds decs)
= do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
......
......@@ -436,9 +436,8 @@ data TyClDecl name
| -- | @type/data declaration
TyDecl { tcdLName :: Located name -- ^ Type constructor
, tcdTyVars :: [LHsTyVarBndr name]
, tcdTyDefn :: HsTyDefn name
, tcdFVs :: NameSet } -- ^ Free tycons of the decl
-- (Used for cycle detection)
, tcdTyDefn :: HsTyDefn name
, tcdFVs :: NameSet }
| ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context...
tcdLName :: Located name, -- ^ Name of the class
......@@ -450,7 +449,8 @@ data TyClDecl name
-- only 'TyFamily'
tcdATDefs :: [LFamInstDecl name], -- ^ Associated type defaults; ie
-- only 'TySynonym'
tcdDocs :: [LDocDecl] -- ^ Haddock docs
tcdDocs :: [LDocDecl], -- ^ Haddock docs
tcdFVs :: NameSet
}
deriving (Data, Typeable)
......@@ -458,7 +458,7 @@ data TyClDecl name
data HsTyDefn name -- The payload of a type synonym or data type defn
-- Used *both* for vanialla type/data declarations,
-- *and* for type/data family instances
= TySynonym { td_synRhs :: LHsType name } -- ^ Synonym expansion
= TySynonym { td_synRhs :: LHsType name } -- ^ Synonym expansion
| -- | Declares a data type or newtype, giving its construcors
-- @
......@@ -645,7 +645,7 @@ pp_ty_defn :: OutputableBndr name
-> HsTyDefn name
-> SDoc
pp_ty_defn pp_hdr (TySynonym rhs)
pp_ty_defn pp_hdr (TySynonym { td_synRhs = rhs })
= hang (ptext (sLit "type") <+> pp_hdr [] <+> equals)
4 (ppr rhs)
......@@ -776,7 +776,7 @@ pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
= sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
where
ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc (unLoc con), ppr t2]
ppr_details (PrefixCon tys) = hsep (pprPrefixOcc (unLoc con) : map ppr tys)
ppr_details (PrefixCon tys) = hsep (pprPrefixOcc (unLoc con) : map (pprParendHsType . unLoc) tys)
ppr_details (RecCon fields) = ppr con <+> pprConDeclFields fields
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
......@@ -820,11 +820,12 @@ data InstDecl name -- Both class and family instances
-- figures out the quantified type variables for us.
, cid_binds :: LHsBinds name
, cid_sigs :: [LSig name] -- User-supplied pragmatic info
, cid_fam_insts :: [LFamInstDecl name] } -- Family instances for associated types
, cid_fam_insts :: [LFamInstDecl name] -- Family instances for associated types
, lid_fvs :: NameSet }
| FamInstD -- type/data family instance
(FamInstDecl name)
{ lid_inst :: FamInstDecl name
, lid_fvs :: NameSet }
deriving (Data, Typeable)
\end{code}
......@@ -855,7 +856,8 @@ instance (OutputableBndr name) => Outputable (FamInstDecl name) where
= pp_ty_defn (pp_fam_inst_head tycon pats) defn
instance (OutputableBndr name) => Outputable (InstDecl name) where
ppr (ClsInstD inst_ty binds sigs ats)
ppr (ClsInstD { cid_poly_ty = inst_ty, cid_binds = binds
, cid_sigs = sigs, cid_fam_insts = ats })
| null sigs && null ats && isEmptyBag binds -- No "where" part
= top_matter
......@@ -866,7 +868,7 @@ instance (OutputableBndr name) => Outputable (InstDecl name) where
where
top_matter = ptext (sLit "instance") <+> ppr inst_ty
ppr (FamInstD decl) = ppr decl
ppr (FamInstD { lid_inst = decl }) = ppr decl
-- Extract the declarations of associated types from an instance
......@@ -874,8 +876,8 @@ instDeclFamInsts :: [LInstDecl name] -> [FamInstDecl name]
instDeclFamInsts inst_decls
= concatMap do_one inst_decls
where
do_one (L _ (ClsInstD _ _ _ fam_insts)) = map unLoc fam_insts
do_one (L _ (FamInstD fam_inst)) = [fam_inst]
do_one (L _ (ClsInstD { cid_fam_insts = fam_insts })) = map unLoc fam_insts
do_one (L _ (FamInstD { lid_inst = fam_inst })) = [fam_inst]
\end{code}
%************************************************************************
......
......@@ -578,7 +578,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
= maybeParen ctxt_prec pREC_FUN $
sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]
ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr ty
ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty pREC_CON ty
ppr_mono_ty _ (HsQuasiQuoteTy qq) = ppr qq
ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds
ppr_mono_ty _ (HsTyVar name) = ppr name
......
......@@ -653,7 +653,7 @@ hsTyClDeclBinders (TyDecl { tcdLName = name, tcdTyDefn = defn })
-------------------
hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
hsInstDeclBinders (ClsInstD { cid_fam_insts = fis }) = concatMap (hsFamInstBinders . unLoc) fis
hsInstDeclBinders (FamInstD fi) = hsFamInstBinders fi
hsInstDeclBinders (FamInstD { lid_inst = fi }) = hsFamInstBinders fi
-------------------
hsFamInstBinders :: Eq name => FamInstDecl name -> [Located name]
......
......@@ -133,9 +133,10 @@ 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 (FamInstD d) = case countATDecl d of
(tyd, dtd) -> (0,0,0,tyd,dtd)
inst_info (ClsInstD _ inst_meths inst_sigs ats)
inst_info (FamInstD { lid_inst = d })
= case countATDecl d of
(tyd, dtd) -> (0,0,0,tyd,dtd)
inst_info (ClsInstD { cid_binds = inst_meths, cid_sigs = inst_sigs, cid_fam_insts = ats })
= case count_sigs (map unLoc inst_sigs) of
(_,_,ss,is,_) ->
case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
......
......@@ -651,20 +651,22 @@ ty_decl :: { LTyClDecl RdrName }
inst_decl :: { LInstDecl RdrName }
: 'instance' inst_type where_inst
{ let (binds, sigs, _, ats, _) = cvBindsAndSigs (unLoc $3)
in L (comb3 $1 $2 $3) (ClsInstD $2 binds sigs ats) }
in L (comb3 $1 $2 $3) (ClsInstD { cid_poly_ty = $2, cid_binds = binds
, cid_sigs = sigs, cid_fam_insts = ats
, lid_fvs = placeHolderNames }) }
-- 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 <- mkFamInstSynonym (comb2 $1 $5) $3 $5
; return (L loc (FamInstD d)) } }
; return (L loc (FamInstD { lid_inst = d, lid_fvs = placeHolderNames })) } }
-- data/newtype instance declaration
| data_or_newtype 'instance' tycl_hdr constrs deriving
{% do { L loc d <- mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) Nothing $3
Nothing (reverse (unLoc $4)) (unLoc $5)
; return (L loc (FamInstD d)) } }
; return (L loc (FamInstD { lid_inst = d, lid_fvs = placeHolderNames })) } }
-- GADT instance declaration
| data_or_newtype 'instance' tycl_hdr opt_kind_sig
......@@ -672,7 +674,7 @@ inst_decl :: { LInstDecl RdrName }
deriving
{% do { L loc d <- mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) Nothing $3
(unLoc $4) (unLoc $5) (unLoc $6)
; return (L loc (FamInstD d)) } }
; return (L loc (FamInstD { lid_inst = d, lid_fvs = placeHolderNames })) } }
-- Associated type family declarations
--
......@@ -700,7 +702,7 @@ at_decl_cls :: { LHsDecl RdrName }
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% do { L loc fid <- mkFamInstSynonym (comb2 $1 $4) $2 $4
; return (L loc (InstD (FamInstD fid))) } }
; return (L loc (InstD (FamInstD { lid_inst = fid, lid_fvs = placeHolderNames }))) } }
-- Associated type instances
--
......@@ -791,7 +793,7 @@ where_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
-- Declarations in instance bodies
--
decl_inst :: { Located (OrdList (LHsDecl RdrName)) }
decl_inst : at_decl_inst { LL (unitOL (L1 (InstD (FamInstD (unLoc $1))))) }
decl_inst : at_decl_inst { LL (unitOL (L1 (InstD (FamInstD { lid_inst = unLoc $1, lid_fvs = placeHolderNames })))) }
| decl { $1 }
decls_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
......
......@@ -115,7 +115,8 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
; tyvars <- checkTyVars tycl_hdr tparams -- Only type vars allowed
; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs })) }
tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs,
tcdFVs = placeHolderNames })) }
mkTyData :: SrcSpan
-> NewOrData
......@@ -130,7 +131,8 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
; tyvars <- checkTyVars tycl_hdr tparams
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (TyDecl { tcdLName = tc, tcdTyVars = tyvars,
tcdTyDefn = defn, tcdFVs = placeHolderNames })) }
tcdTyDefn = defn,
tcdFVs = placeHolderNames })) }
mkFamInstData :: SrcSpan
-> NewOrData
......@@ -170,7 +172,8 @@ mkTySynonym loc lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs
; tyvars <- checkTyVars lhs tparams
; return (L loc (TyDecl { tcdLName = tc, tcdTyVars = tyvars,
tcdTyDefn = TySynonym rhs, tcdFVs = placeHolderNames })) }
tcdTyDefn = TySynonym { td_synRhs = rhs },
tcdFVs = placeHolderNames })) }
mkFamInstSynonym :: SrcSpan
-> LHsType RdrName -- LHS
......@@ -179,7 +182,7 @@ mkFamInstSynonym :: SrcSpan
mkFamInstSynonym loc lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs
; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams
, fid_defn = TySynonym rhs })) }
, fid_defn = TySynonym { td_synRhs = rhs }})) }
mkTyFamily :: SrcSpan
-> FamilyFlavour
......@@ -262,7 +265,7 @@ cvBindsAndSigs fb = go (fromOL fb)
(bs, ss, ts, fis, docs) = go ds'
go (L l (TyClD t@(TyFamily {})) : ds) = (bs, ss, L l t : ts, fis, docs)
where (bs, ss, ts, fis, docs) = go ds
go (L l (InstD (FamInstD fi)) : ds) = (bs, ss, ts, L l fi : fis, docs)
go (L l (InstD (FamInstD { lid_inst = fi })) : ds) = (bs, ss, ts, L l fi : fis, docs)
where (bs, ss, ts, fis, docs) = go ds
go (L l (DocD d) : ds) = (bs, ss, ts, fis, (L l d) : docs)
where (bs, ss, ts, fis, docs) = go ds
......
......@@ -46,7 +46,7 @@ import RdrName ( RdrName, rdrNameOcc )
import SrcLoc
import ListSetOps ( findDupsEq )
import BasicTypes ( RecFlag(..) )
import Digraph ( SCC(..), stronglyConnCompFromEdgedVertices )
import Digraph ( SCC(..) )
import Bag
import Outputable
import FastString
......@@ -506,17 +506,9 @@ depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
depAnalBinds binds_w_dus
= (map get_binds sccs, map get_du sccs)
where
sccs = stronglyConnCompFromEdgedVertices edges
keyd_nodes = bagToList binds_w_dus `zip` [0::Int ..]
edges = [ (node, key, [key | n <- nameSetToList uses,
Just key <- [lookupNameEnv key_map n] ])
| (node@(_,_,uses), key) <- keyd_nodes ]
key_map :: NameEnv Int -- Which binding it comes from
key_map = mkNameEnv [(bndr, key) | ((_, bndrs, _), key) <- keyd_nodes
, bndr <- bndrs ]
sccs = depAnal (\(_, defs, _) -> defs)
(\(_, _, uses) -> nameSetToList uses)
(bagToList binds_w_dus)
get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)
get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])
......@@ -527,7 +519,6 @@ depAnalBinds binds_w_dus
defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]
uses = unionManyNameSets [u | (_,_,u) <- binds_w_dus]
---------------------
-- Bind the top-level forall'd type variables in the sigs.
-- E.g f :: a -> a
......
......@@ -530,7 +530,7 @@ getLocalNonValBinders fixity_env
; return (AvailTC main_name names) }
new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
new_assoc (L _ (FamInstD d))
new_assoc (L _ (FamInstD { lid_inst = d }))
= do { avail <- new_ti Nothing d
; return [avail] }
new_assoc (L _ (ClsInstD { cid_poly_ty = inst_ty, cid_fam_insts = ats }))
......
......@@ -422,9 +422,9 @@ patchCCallTarget packageId callTarget
\begin{code}
rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
rnSrcInstDecl (FamInstD fi)
rnSrcInstDecl (FamInstD { lid_inst = fi })
= do { (fi', fvs) <- rnFamInstDecl Nothing fi
; return (FamInstD fi', fvs) }
; return (FamInstD { lid_inst = fi', lid_fvs = fvs }, fvs) }
rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
, cid_sigs = uprags, cid_fam_insts = ats })
......@@ -432,7 +432,8 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
= do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
; case splitLHsInstDeclTy_maybe inst_ty' of {
Nothing -> return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
, cid_sigs = [], cid_fam_insts = [] }, inst_fvs) ;
, cid_sigs = [], cid_fam_insts = []
, lid_fvs = inst_fvs }, inst_fvs) ;
Just (inst_tyvars, _, L _ cls,_) ->
do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
......@@ -466,11 +467,13 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
<- renameSigs (InstDeclCtxt cls) spec_inst_prags
; let uprags' = spec_inst_prags' ++ other_sigs'
; return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = mbinds'
, cid_sigs = uprags', cid_fam_insts = ats' },
meth_fvs `plusFV` more_fvs
all_fvs = meth_fvs `plusFV` more_fvs
`plusFV` spec_inst_fvs
`plusFV` inst_fvs) } } }
`plusFV` inst_fvs
; return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = mbinds'
, cid_sigs = uprags', cid_fam_insts = ats'
, lid_fvs = all_fvs },
all_fvs) } } }
-- We return the renamed associated data type declarations so
-- that they can be entered into the list of type declarations
-- for the binding group, but we also keep a copy in the instance.
......@@ -908,11 +911,12 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
-- Haddock docs
; docs' <- mapM (wrapLocM rnDocDecl) docs
; let all_fvs = meth_fvs `plusFV` stuff_fvs
; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
tcdDocs = docs'},
meth_fvs `plusFV` stuff_fvs) }
tcdDocs = docs', tcdFVs = all_fvs },
all_fvs ) }
where
cls_doc = ClassDeclCtx lcls
......@@ -939,11 +943,12 @@ rnTyDefn tycon (TyData { td_ND = new_or_data, td_cType = cType
-- No need to check for duplicate constructor decls
-- since that is done by RnNames.extendGlobalRdrEnvRn
; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
con_fvs `plusFV` sig_fvs
; return ( TyData { td_ND = new_or_data, td_cType = cType
, td_ctxt = context', td_kindSig = sig'
, td_cons = condecls', td_derivs = derivs'}
, fvs1 `plusFV` fvs3 `plusFV`
con_fvs `plusFV` sig_fvs )
, td_cons = condecls', td_derivs = derivs' }
, all_fvs )
}
where
h98_style = case condecls of -- Note [Stupid theta]
......@@ -959,7 +964,8 @@ rnTyDefn tycon (TyData { td_ND = new_or_data, td_cType = cType
-- "type" and "type instance" declarations
rnTyDefn tycon (TySynonym { td_synRhs = ty })
= do { (ty', rhs_fvs) <- rnLHsType syn_doc ty
; return (TySynonym { td_synRhs = ty' }, rhs_fvs) }
; return ( TySynonym { td_synRhs = ty' }
, rhs_fvs) }
where
syn_doc = TySynCtx tycon
......@@ -999,9 +1005,9 @@ depAnalTyClDecls ds_w_fvs
(L _ d, _) <- ds_w_fvs
case d of
ClassDecl { tcdLName = L _ cls_name
, tcdATs = ats } -> do
L _ assoc_decl <- ats
return (tcdName assoc_decl, cls_name)
, tcdATs = ats }
-> do L _ assoc_decl <- ats
return (tcdName assoc_decl, cls_name)
TyDecl { tcdLName = L _ data_name
, tcdTyDefn = TyData { td_cons = cons } }
-> do L _ dc <- cons
......
......@@ -477,7 +477,7 @@ deriveTyDecl _ = return []
------------------------------------------------------------------
deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec]
deriveInstDecl (L _ (FamInstD fam_inst))
deriveInstDecl (L _ (FamInstD { lid_inst = fam_inst }))
= deriveFamInst fam_inst
deriveInstDecl (L _ (ClsInstD { cid_fam_insts = fam_insts }))
= concatMapM (deriveFamInst . unLoc) fam_insts
......
......@@ -56,8 +56,10 @@ import Id
import MkId
import Name
import NameSet
import NameEnv
import Outputable
import SrcLoc
import Digraph( SCC(..) )
import Util
import Control.Monad
......@@ -370,25 +372,16 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
-- (they recover, so that we get more than one error each
-- round)
-- (1) Do class and family instance declarations
; inst_decl_stuff <- mapAndRecoverM tcLocalInstDecl1 inst_decls
-- Do class and family instance declarations
; (gbl_env, local_infos) <- tcLocalInstDecls (calcInstDeclCycles inst_decls)
; setGblEnv gbl_env $
; 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_infos $
addFamInsts all_fam_insts $ do
-- (3) Compute instances from "deriving" clauses;
do { -- Compute instances from "deriving" clauses;
-- This stuff computes a context for the derived instance
-- decl, so it needs to know about all the instances possible
-- NB: class instance declarations can contain derivings as
-- part of associated data type declarations
{ failIfErrsM -- If the addInsts stuff gave any errors, don't
failIfErrsM -- If the addInsts stuff gave any errors, don't
-- try the deriving stuff, because that may give
-- more errors still
......@@ -417,6 +410,20 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
++ " Haskell! Can only derive them"
tcLocalInstDecls :: [SCC (LInstDecl Name)] -> TcM (TcGblEnv, [InstInfo Name])
tcLocalInstDecls []
= do { gbl_env <- getGblEnv
; return (gbl_env, []) }
tcLocalInstDecls (AcyclicSCC inst_decl : sccs)
= do { (inst_infos, fam_insts) <- recoverM (return ([], [])) $
tcLocalInstDecl inst_decl
; (gbl_env, more_infos) <- addClsInsts inst_infos $
addFamInsts fam_insts $
tcLocalInstDecls sccs
; return (gbl_env, inst_infos ++ more_infos) }
tcLocalInstDecls (CyclicSCC inst_decls : _)
= do { cyclicDeclErr inst_decls; failM }
addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
addClsInsts infos thing_inside
= tcExtendLocalInstEnv (map iSpec infos) thing_inside
......@@ -436,21 +443,72 @@ addFamInsts fam_insts thing_inside
things = map ATyCon tycons ++ map ACoAxiom axioms
\end{code}
Note [Instance declaration cycles]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
With -XDataKinds we can get this
data instance Foo [a] = MkFoo (MkFoo a)
where the constructor MkFoo is used in a type before it is
defined. Here is a more complicated situation, involving an
associated type and mutual recursion
data instance T [a] = MkT (MkS a)
instance C [a] where
data S [a] = MkS (MkT a)
When type checking ordinary data type decls we detect this staging
problem in the kind-inference phase, but there *is* no kind inference
phase here.
So intead we extract the strongly connected components and look for
cycles.
\begin{code}
calcInstDeclCycles :: [LInstDecl Name] -> [SCC (LInstDecl Name)]
-- see Note [Instance declaration cycles]
calcInstDeclCycles decls
= depAnal get_defs get_uses decls
where
-- get_defs extracts the *constructor* bindings of the declaration
get_defs :: LInstDecl Name -> [Name]
get_defs (L _ (FamInstD { lid_inst = fid })) = get_fi_defs fid
get_defs (L _ (ClsInstD { cid_fam_insts = fids })) = concatMap (get_fi_defs . unLoc) fids
get_fi_defs :: FamInstDecl Name -> [Name]
get_fi_defs (FamInstDecl { fid_defn = TyData { td_cons = cons } })
= map (unLoc . con_name . unLoc) cons
get_fi_defs (FamInstDecl {}) = []
-- get_uses extracts the *tycon or constructor* uses of the declaration
get_uses :: LInstDecl Name -> [Name]
get_uses decl = nameSetToList (lid_fvs (unLoc decl))
cyclicDeclErr :: Outputable d => [Located d] -> TcRn ()
cyclicDeclErr inst_decls
= setSrcSpan (getLoc (head sorted_decls)) $
addErr (sep [ptext (sLit "Cycle in type declarations: data constructor used (in a type) before it is defined"),
nest 2 (vcat (map ppr_decl sorted_decls))])
where
sorted_decls = sortLocated inst_decls
ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
\end{code}
\begin{code}
tcLocalInstDecl1 :: LInstDecl Name
-> TcM ([InstInfo Name], [FamInst])
tcLocalInstDecl :: LInstDecl Name
-> 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 (FamInstD decl))
tcLocalInstDecl (L loc (FamInstD { lid_inst = decl }))
= setSrcSpan loc $
tcAddFamInstCtxt decl $
do { fam_inst <- tcFamInstDecl TopLevel decl
; return ([], [fam_inst]) }
tcLocalInstDecl1 (L loc (ClsInstD { cid_poly_ty = poly_ty, cid_binds = binds
, cid_sigs = uprags, cid_fam_insts = ats }))
tcLocalInstDecl (L loc (ClsInstD { cid_poly_ty = poly_ty, cid_binds = binds
, cid_sigs = uprags, cid_fam_insts = ats }))
= setSrcSpan loc $
addErrCtxt (instDeclCtxt1 poly_ty) $
......
......@@ -700,7 +700,8 @@ tcDefaultAssocDecl fam_tc (L loc decl)
tcSynFamInstDecl :: TyCon -> FamInstDecl Name -> TcM ([TyVar], [Type], Type)
-- Placed here because type family instances appear as
-- default decls in class declarations
tcSynFamInstDecl fam_tc (FamInstDecl { fid_pats = pats, fid_defn = defn@(TySynonym hs_ty) })
tcSynFamInstDecl fam_tc
(FamInstDecl { fid_pats = pats, fid_defn = defn@(TySynonym { td_synRhs = hs_ty }) })
= do { checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
; tcFamTyPats fam_tc pats (kcTyDefn defn) $ \tvs' pats' res_kind ->
......@@ -1720,11 +1721,6 @@ recClsErr cycles
= addErr (sep [ptext (sLit "Cycle in class declaration (via superclasses):"),
nest 2 (hsep (intersperse (text "->") (map ppr cycles)))])
sortLocated :: [Located a] -> [Located a]
sortLocated things = sortLe le things
where
le (L l1 _) (L l2 _) = l1 <= l2
badDataConTyCon :: DataCon -> Type -> Type -> SDoc
badDataConTyCon data_con res_ty_tmpl actual_res_ty
= hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) <+>
......@@ -1793,12 +1789,7 @@ wrongATArgErr ty instTy =
, ptext (sLit "Found") <+> quotes (ppr ty)
<+> ptext (sLit "but expected") <+> quotes (ppr instTy)
]
{-
tooManyParmsErr :: Name -> SDoc
tooManyParmsErr tc_name
= ptext (sLit "Family instance has too many parameters:") <+>
quotes (ppr tc_name)
-}
wrongNumberOfParmsErr :: Arity -> SDoc
wrongNumberOfParmsErr exp_arity
= ptext (sLit "Number of parameters must match family declaration; expected")
......
......@@ -109,9 +109,9 @@ synTyConsOfType ty
\begin{code}
mkSynEdges :: [LTyClDecl Name] -> [(LTyClDecl Name, Name, [Name])]
mkSynEdges syn_decls = [ (ldecl, unLoc (tcdLName decl),
nameSetToList (tcdFVs decl))
| ldecl@(L _ decl) <- syn_decls ]
mkSynEdges syn_decls = [ (ldecl, name, nameSetToList fvs)
| ldecl@(L _ (TyDecl { tcdLName = L _ name
, tcdFVs = fvs })) <- syn_decls ]
calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
calcSynCycles = stronglyConnCompFromEdgedVertices . mkSynEdges
......