diff options
Diffstat (limited to 'compiler/hsSyn')
| -rw-r--r-- | compiler/hsSyn/Convert.lhs | 23 | ||||
| -rw-r--r-- | compiler/hsSyn/HsDecls.lhs | 6 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.lhs | 5 | ||||
| -rw-r--r-- | compiler/hsSyn/HsImpExp.lhs | 33 | ||||
| -rw-r--r-- | compiler/hsSyn/HsPat.lhs | 39 | ||||
| -rw-r--r-- | compiler/hsSyn/HsTypes.lhs | 51 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.lhs | 80 |
7 files changed, 169 insertions, 68 deletions
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index bcea29bea2..f42375926e 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -238,8 +238,11 @@ cvtDec (DataInstD ctxt tc tys constrs derivs) , dd_cons = cons', dd_derivs = derivs' } ; returnL $ InstD $ DataFamInstD - { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' - , dfid_defn = defn, dfid_fvs = placeHolderNames } }} + { dfid_inst = DataFamInstDecl { dfid_tycon = tc' + , dfid_rep_tycon = placeHolderRepTyCon + , dfid_pats = typats' + , dfid_defn = defn + , dfid_fvs = placeHolderNames} }} cvtDec (NewtypeInstD ctxt tc tys constr derivs) = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys @@ -250,8 +253,11 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs) , dd_kindSig = Nothing , dd_cons = [con'], dd_derivs = derivs' } ; returnL $ InstD $ DataFamInstD - { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' - , dfid_defn = defn, dfid_fvs = placeHolderNames } }} + { dfid_inst = DataFamInstDecl { dfid_tycon = tc' + , dfid_rep_tycon = placeHolderRepTyCon + , dfid_pats = typats' + , dfid_defn = defn + , dfid_fvs = placeHolderNames } }} cvtDec (TySynInstD tc eqn) = do { tc' <- tconNameL tc @@ -396,7 +402,8 @@ cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName) cvt_id_arg (i, str, ty) = do { i' <- vNameL i ; ty' <- cvt_arg (str,ty) - ; return (ConDeclField { cd_fld_name = i', cd_fld_type = ty', cd_fld_doc = Nothing}) } + ; return (ConDeclField { cd_fld_lbl = i', cd_fld_sel = error "cvt_id_arg" + , cd_fld_type = ty', cd_fld_doc = Nothing}) } cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName]) cvtDerivs [] = return Nothing @@ -642,7 +649,8 @@ which we don't want. cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName)) cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e - ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) } + ; return (HsRecField { hsRecFieldLbl = v', hsRecFieldSel = hsRecFieldSelMissing + , hsRecFieldArg = e', hsRecPun = False}) } cvtDD :: Range -> CvtM (ArithSeqInfo RdrName) cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } @@ -852,7 +860,8 @@ cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName)) cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p - ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) } + ; return (HsRecField { hsRecFieldLbl = s', hsRecFieldSel = hsRecFieldSelMissing + , hsRecFieldArg = p', hsRecPun = False}) } {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. The produced tree of infix patterns will be left-biased, provided @x@ is. diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index bae804eb07..932810708d 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -31,6 +31,7 @@ module HsDecls ( DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, TyFamInstEqn(..), LTyFamInstEqn, LClsInstDecl, ClsInstDecl(..), + placeHolderRepTyCon, -- ** Standalone deriving declarations DerivDecl(..), LDerivDecl, @@ -921,6 +922,7 @@ type LDataFamInstDecl name = Located (DataFamInstDecl name) data DataFamInstDecl name = DataFamInstDecl { dfid_tycon :: Located name + , dfid_rep_tycon :: Name -- error thunk until renamer , dfid_pats :: HsWithBndrs [LHsType name] -- lhs -- ^ Type patterns (with kind and type bndrs) -- See Note [Family instance declaration binders] @@ -928,6 +930,10 @@ data DataFamInstDecl name , dfid_fvs :: NameSet } -- free vars for dependency analysis deriving( Typeable, Data ) +placeHolderRepTyCon :: Name +-- Used for the Name in DataFamInstDecl prior to the renamer +placeHolderRepTyCon = panic "placeHolderRepTyCon" + ----------------- Class instances ------------- diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index f5ba1903ee..9e85818f8d 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -331,6 +331,8 @@ data HsExpr id | HsWrap HsWrapper -- TRANSLATION (HsExpr id) | HsUnboundVar RdrName + | HsOverloadedRecFld FieldLabelString + | HsSingleRecFld RdrName id -- Used to attach a selector id to non-overloaded fields deriving (Data, Typeable) -- | HsTupArg is used for tuple sections @@ -645,7 +647,8 @@ ppr_expr (HsArrForm op _ args) 4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)")) ppr_expr (HsUnboundVar nm) = ppr nm - +ppr_expr (HsOverloadedRecFld f) = ppr f +ppr_expr (HsSingleRecFld f _) = ppr f \end{code} HsSyn records exactly where the user put parens, with HsPar. diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index 7163cbfe10..8192f51c2d 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -13,6 +13,7 @@ module HsImpExp where import Module ( ModuleName ) import HsDoc ( HsDocString ) import OccName ( HasOccName(..), isTcOcc, isSymOcc ) +import Avail import Outputable import FastString @@ -107,7 +108,7 @@ data IE name = IEVar name | IEThingAbs name -- ^ Class/Type (can't tell) | IEThingAll name -- ^ Class/Type plus all methods/constructors - | IEThingWith name [name] -- ^ Class/Type plus some methods/constructors + | IEThingWith name [name] (AvailFlds name) -- ^ Class/Type plus some methods/constructors and record fields | IEModuleContents ModuleName -- ^ (Export Only) | IEGroup Int HsDocString -- ^ Doc section heading | IEDoc HsDocString -- ^ Some documentation @@ -117,21 +118,21 @@ data IE name \begin{code} ieName :: IE name -> name -ieName (IEVar n) = n -ieName (IEThingAbs n) = n -ieName (IEThingWith n _) = n -ieName (IEThingAll n) = n +ieName (IEVar n) = n +ieName (IEThingAbs n) = n +ieName (IEThingWith n _ _) = n +ieName (IEThingAll n) = n ieName _ = panic "ieName failed pattern match!" ieNames :: IE a -> [a] -ieNames (IEVar n ) = [n] -ieNames (IEThingAbs n ) = [n] -ieNames (IEThingAll n ) = [n] -ieNames (IEThingWith n ns) = n : ns -ieNames (IEModuleContents _ ) = [] -ieNames (IEGroup _ _ ) = [] -ieNames (IEDoc _ ) = [] -ieNames (IEDocNamed _ ) = [] +ieNames (IEVar n ) = [n] +ieNames (IEThingAbs n ) = [n] +ieNames (IEThingAll n ) = [n] +ieNames (IEThingWith n ns fs) = n : ns ++ availFieldsNames fs +ieNames (IEModuleContents _ ) = [] +ieNames (IEGroup _ _ ) = [] +ieNames (IEDoc _ ) = [] +ieNames (IEDocNamed _ ) = [] \end{code} \begin{code} @@ -147,8 +148,10 @@ instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where ppr (IEVar var) = pprPrefixOcc var ppr (IEThingAbs thing) = pprImpExp thing ppr (IEThingAll thing) = hcat [pprImpExp thing, text "(..)"] - ppr (IEThingWith thing withs) - = pprImpExp thing <> parens (fsep (punctuate comma (map pprImpExp withs))) + ppr (IEThingWith thing withs flds) + = pprImpExp thing <> parens (fsep (punctuate comma + (map pprImpExp withs ++ + map pprAvailField flds))) ppr (IEModuleContents mod') = ptext (sLit "module") <+> ppr mod' ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">") diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index ef888fe5a8..37272f0293 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -12,7 +12,10 @@ module HsPat ( HsConDetails(..), HsConPatDetails, hsConPatArgs, - HsRecFields(..), HsRecField(..), hsRecFields, + HsRecFields(..), HsRecField(..), + hsRecFieldSelMissing, + hsRecFieldId, hsRecFieldId_maybe, + hsRecFields, hsRecFieldsUnambiguous, mkPrefixConPat, mkCharLitPat, mkNilPat, @@ -40,11 +43,13 @@ import DataCon import TyCon import Outputable import Type +import RdrName +import OccName import SrcLoc import FastString +import Maybes -- libraries: import Data.Data hiding (TyCon) -import Data.Maybe \end{code} @@ -199,7 +204,8 @@ data HsRecFields id arg -- A bunch of record fields -- and the remainder being 'filled in' implicitly data HsRecField id arg = HsRecField { - hsRecFieldId :: Located id, + hsRecFieldLbl :: Located RdrName, + hsRecFieldSel :: Either id [(id, id)], hsRecFieldArg :: arg, -- Filled in by renamer hsRecPun :: Bool -- Note [Punning] } deriving (Data, Typeable) @@ -207,8 +213,8 @@ data HsRecField id arg = HsRecField { -- Note [Punning] -- ~~~~~~~~~~~~~~ -- If you write T { x, y = v+1 }, the HsRecFields will be --- HsRecField x x True ... --- HsRecField y (v+1) False ... +-- HsRecField x x x True ... +-- HsRecField y y (v+1) False ... -- That is, for "punned" field x is expanded (in the renamer) -- to x=x; but with a punning flag so we can detect it later -- (e.g. when pretty printing) @@ -216,8 +222,25 @@ data HsRecField id arg = HsRecField { -- If the original field was qualified, we un-qualify it, thus -- T { A.x } means T { A.x = x } -hsRecFields :: HsRecFields id arg -> [id] -hsRecFields rbinds = map (unLoc . hsRecFieldId) (rec_flds rbinds) +hsRecFieldSelMissing :: Either id [(id, id)] +hsRecFieldSelMissing = error "hsRecFieldSelMissing" + +hsRecFields :: HsRecFields id arg -> [(FieldLabelString, Either id [(id, id)])] +hsRecFields rbinds = map toFld (rec_flds rbinds) + where + toFld x = ( occNameFS . rdrNameOcc . unLoc . hsRecFieldLbl $ x + , hsRecFieldSel x) + +hsRecFieldsUnambiguous :: HsRecFields id arg -> [(FieldLabelString, id)] +hsRecFieldsUnambiguous = map outOfLeftField . hsRecFields + where outOfLeftField (l, Left x) = (l, x) + outOfLeftField (_, Right _) = error "hsRecFieldsUnambigous" + +hsRecFieldId_maybe :: HsRecField id arg -> Maybe (Located id) +hsRecFieldId_maybe x = either (Just . L (getLoc (hsRecFieldLbl x))) (const Nothing) (hsRecFieldSel x) + +hsRecFieldId :: HsRecField id arg -> Located id +hsRecFieldId = expectJust "hsRecFieldId" . hsRecFieldId_maybe \end{code} %************************************************************************ @@ -300,7 +323,7 @@ instance (OutputableBndr id, Outputable arg) instance (OutputableBndr id, Outputable arg) => Outputable (HsRecField id arg) where - ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg, + ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg, hsRecPun = pun }) = ppr f <+> (ppUnless pun $ equals <+> ppr arg) \end{code} diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 28c6a2b89c..4ae141bc83 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -23,7 +23,7 @@ module HsTypes ( LBangType, BangType, HsBang(..), getBangType, getBangStrictness, - ConDeclField(..), pprConDeclFields, + ConDeclField(..), pprConDeclFields, cd_fld_name, mkHsQTvs, hsQTvBndrs, mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, @@ -34,6 +34,8 @@ module HsTypes ( splitHsFunType, splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy, + getDFunHsTypeKey, + -- Printing pprParendHsType, pprHsForAll, pprHsContext, pprHsContextNoArrow, ppr_hs_context, ) where @@ -42,10 +44,12 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice ) import HsLit -import Name( Name ) -import RdrName( RdrName ) +import Name( Name, getOccName, occNameString ) +import RdrName( RdrName, rdrNameOcc ) import DataCon( HsBang(..) ) import Type +import TysWiredIn +import PrelNames import HsDoc import BasicTypes import SrcLoc @@ -367,11 +371,15 @@ data HsTupleSort = HsUnboxedTuple data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable) data ConDeclField name -- Record fields have Haddoc docs on them - = ConDeclField { cd_fld_name :: Located name, + = ConDeclField { cd_fld_lbl :: Located RdrName, + cd_fld_sel :: name, -- error thunk until after renaming cd_fld_type :: LBangType name, cd_fld_doc :: Maybe LHsDocString } deriving (Data, Typeable) +cd_fld_name :: ConDeclField name -> Located name +cd_fld_name x = L (getLoc (cd_fld_lbl x)) $ cd_fld_sel x + ----------------------- -- Combine adjacent for-alls. -- The following awkward situation can happen otherwise: @@ -518,6 +526,39 @@ splitHsFunType other = ([], other) \end{code} +\begin{code} +-- Get some string from a type, to be used to construct a dictionary +-- function name (like getDFunTyKey in TcType, but for HsTypes) +getDFunHsTypeKey :: HsType RdrName -> String +getDFunHsTypeKey (HsForAllTy _ _ _ t) = getDFunHsTypeKey (unLoc t) +getDFunHsTypeKey (HsTyVar tv) = occNameString (rdrNameOcc tv) +getDFunHsTypeKey (HsAppTy fun _) = getDFunHsTypeKey (unLoc fun) +getDFunHsTypeKey (HsFunTy {}) = occNameString (getOccName funTyCon) +getDFunHsTypeKey (HsListTy _) = occNameString (getOccName listTyCon) +getDFunHsTypeKey (HsPArrTy _) = occNameString (getOccName parrTyCon) +getDFunHsTypeKey (HsTupleTy {}) = occNameString (getOccName unitTyCon) +getDFunHsTypeKey (HsOpTy _ (_, op) _) = occNameString (rdrNameOcc (unLoc op)) +getDFunHsTypeKey (HsParTy ty) = getDFunHsTypeKey (unLoc ty) +getDFunHsTypeKey (HsIParamTy {}) = occNameString (getOccName ipClassName) +getDFunHsTypeKey (HsEqTy {}) = occNameString (getOccName eqTyCon) +getDFunHsTypeKey (HsKindSig ty _) = getDFunHsTypeKey (unLoc ty) +getDFunHsTypeKey (HsQuasiQuoteTy {}) = "quasiQuote" +getDFunHsTypeKey (HsSpliceTy {}) = "splice" +getDFunHsTypeKey (HsDocTy ty _) = getDFunHsTypeKey (unLoc ty) +getDFunHsTypeKey (HsBangTy _ ty) = getDFunHsTypeKey (unLoc ty) +getDFunHsTypeKey (HsRecTy {}) = "record" +getDFunHsTypeKey (HsCoreTy {}) = "core" +getDFunHsTypeKey (HsExplicitListTy {}) = occNameString (getOccName listTyCon) +getDFunHsTypeKey (HsExplicitTupleTy {}) = occNameString (getOccName unitTyCon) +getDFunHsTypeKey (HsTyLit x) = getDFunHsTyLitKey x +getDFunHsTypeKey (HsWrapTy _ ty) = getDFunHsTypeKey ty + +getDFunHsTyLitKey :: HsTyLit -> String +getDFunHsTyLitKey (HsNumTy n) = show n +getDFunHsTyLitKey (HsStrTy n) = show n +\end{code} + + %************************************************************************ %* * \subsection{Pretty printing} @@ -568,7 +609,7 @@ ppr_hs_context cxt = parens (interpp'SP cxt) pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where - ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty, + ppr_fld (ConDeclField { cd_fld_lbl = n, cd_fld_type = ty, cd_fld_doc = doc }) = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc \end{code} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index eff67df3cf..b0bf427c73 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -100,6 +100,8 @@ import Util import Bag import Outputable import Data.Either +import Data.Foldable (foldMap) +import Data.Monoid \end{code} @@ -677,31 +679,37 @@ variables bound by the lazy pattern are n,m, *not* the dictionary d. So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound. \begin{code} -hsGroupBinders :: HsGroup Name -> [Name] +hsGroupBinders :: HsGroup Name -> ([Name], [(RdrName, Name, Name)]) hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fords = foreign_decls }) -- Collect the binders of a Group - = collectHsValBinders val_decls - ++ hsTyClDeclsBinders tycl_decls inst_decls - ++ hsForeignDeclsBinders foreign_decls + = (collectHsValBinders val_decls, []) + `mappend` hsTyClDeclsBinders tycl_decls inst_decls + `mappend` (hsForeignDeclsBinders foreign_decls, []) hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name] hsForeignDeclsBinders foreign_decls = [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls] -hsTyClDeclsBinders :: [TyClGroup Name] -> [Located (InstDecl Name)] -> [Name] +hsTyClDeclsBinders :: [TyClGroup Name] -> [Located (InstDecl Name)] -> + ([Name], [(RdrName, Name, Name)]) -- We need to look at instance declarations too, -- because their associated types may bind data constructors hsTyClDeclsBinders tycl_decls inst_decls - = map unLoc (concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++ - concatMap (hsInstDeclBinders . unLoc) inst_decls) + = unLocs (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls `mappend` + foldMap (hsInstDeclBinders . unLoc) inst_decls) + where unLocs (xs, ys) = (map unLoc xs, map (\ (x, y, z) -> (unLoc x, y, unLoc z)) ys) ------------------- -hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name] +hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> + ([Located name], [(Located RdrName, name, Located name)]) -- ^ Returns all the /binding/ names of the decl. --- The first one is guaranteed to be the name of the decl. For record fields +-- The first one is guaranteed to be the name of the decl. The first component +-- represents all binding names except fields; the second represents fields as +-- (label, selector name, tycon name) triples. For record fields -- mentioned in multiple constructors, the SrcLoc will be from the first -- occurrence. We use the equality to filter out duplicate field names. +-- Note that the selector name will be an error thunk until after the renamer. -- -- Each returned (Located name) is wrapped in a @SrcSpan@ of the whole -- /declaration/, not just the name itself (which is how it appears in @@ -710,56 +718,64 @@ hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name] -- error messages. (See Trac #8607.) hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } })) - = [L loc name] -hsLTyClDeclBinders (L loc (ForeignType { tcdLName = L _ name })) = [L loc name] -hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = [L loc name] + = ([L loc name], []) +hsLTyClDeclBinders (L loc (ForeignType { tcdLName = L _ name })) = ([L loc name], []) +hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = ([L loc name], []) hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name , tcdSigs = sigs, tcdATs = ats })) - = L loc cls_name : - [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++ - [ L mem_loc mem_name | L mem_loc (TypeSig ns _) <- sigs, L _ mem_name <- ns ] + = (L loc cls_name : + [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++ + [ L mem_loc mem_name | L mem_loc (TypeSig ns _) <- sigs, L _ mem_name <- ns ] + , []) hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })) - = L loc name : hsDataDefnBinders defn + = (\ (xs, ys) -> (L loc name : xs, ys)) $ withTyCon (L loc name) $ hsDataDefnBinders defn ------------------- -hsInstDeclBinders :: Eq name => InstDecl name -> [Located name] +hsInstDeclBinders :: Eq name => InstDecl name -> + ([Located name], [(Located RdrName, name, Located name)]) hsInstDeclBinders (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }) - = concatMap (hsDataFamInstBinders . unLoc) dfis + = foldMap (hsDataFamInstBinders . unLoc) dfis hsInstDeclBinders (DataFamInstD { dfid_inst = fi }) = hsDataFamInstBinders fi -hsInstDeclBinders (TyFamInstD {}) = [] +hsInstDeclBinders (TyFamInstD {}) = mempty ------------------- -- the SrcLoc returned are for the whole declarations, not just the names -hsDataFamInstBinders :: Eq name => DataFamInstDecl name -> [Located name] -hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn }) - = hsDataDefnBinders defn +hsDataFamInstBinders :: Eq name => DataFamInstDecl name -> + ([Located name], [(Located RdrName, name, Located name)]) +hsDataFamInstBinders (DataFamInstDecl { dfid_tycon = tycon_name, dfid_defn = defn }) + = withTyCon tycon_name (hsDataDefnBinders defn) -- There can't be repeated symbols because only data instances have binders ------------------- -- the SrcLoc returned are for the whole declarations, not just the names -hsDataDefnBinders :: Eq name => HsDataDefn name -> [Located name] +hsDataDefnBinders :: Eq name => HsDataDefn name -> + ([Located name], [(Located RdrName, name)]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] ------------------- -hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name] +hsConDeclsBinders :: (Eq name) => [LConDecl name] -> + ([Located name], [(Located RdrName, name)]) -- See hsLTyClDeclBinders for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful hsConDeclsBinders cons - = snd (foldl do_one ([], []) cons) + = foldl do_one ([], []) cons where - do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name + do_one (acc, flds_seen) (L loc (ConDecl { con_name = L _ name , con_details = RecCon flds })) - = (map unLoc new_flds ++ flds_seen, L loc name : new_flds ++ acc) - where + = (L loc name : acc, map cd_fld_lfld new_flds ++ flds_seen) + where -- don't re-mangle the location of field names, because we don't -- have a record of the full location of the field declaration anyway - new_flds = filterOut (\f -> unLoc f `elem` flds_seen) - (map cd_fld_name flds) + new_flds = filterOut (\ x -> unLoc (cd_fld_lbl x) `elem` map (unLoc . fst) flds_seen) flds + cd_fld_lfld x = (cd_fld_lbl x, cd_fld_sel x) + + do_one (acc, flds_seen) (L loc (ConDecl { con_name = L _ name })) + = (L loc name : acc, flds_seen) - do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name })) - = (flds_seen, L loc name : acc) +withTyCon :: name' -> (a, [(r, name)]) -> (a, [(r, name, name')]) +withTyCon tycon_name (xs, ys) = (xs, map (\ (r, n) -> (r, n, tycon_name)) ys) \end{code} Note [Binders in family instances] |