diff options
Diffstat (limited to 'compiler/hsSyn')
| -rw-r--r-- | compiler/hsSyn/Convert.hs | 82 | ||||
| -rw-r--r-- | compiler/hsSyn/HsBinds.hs | 23 | ||||
| -rw-r--r-- | compiler/hsSyn/HsDecls.hs | 35 | ||||
| -rw-r--r-- | compiler/hsSyn/HsEmbellished.hs | 63 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.hs | 14 | ||||
| -rw-r--r-- | compiler/hsSyn/HsPat.hs | 5 | ||||
| -rw-r--r-- | compiler/hsSyn/HsSyn.hs | 2 | ||||
| -rw-r--r-- | compiler/hsSyn/HsTypes.hs | 28 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.hs | 54 |
9 files changed, 196 insertions, 110 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 7e786bd2e6..1d672b2bc2 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -165,14 +165,14 @@ cvtDec (TH.FunD nm cls) cvtDec (TH.SigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) } + ; returnJustL $ Hs.SigD (TypeSig [lEmb nm'] (mkLHsSigWcType ty')) } cvtDec (TH.InfixD fx nm) -- Fixity signatures are allowed for variables, constructors, and types -- the renamer automatically looks for types during renaming, even when -- the RdrName says it's a variable or a constructor. So, just assume -- it's a variable or constructor and proceed. - = do { nm' <- vcNameL nm + = do { nm' <- vcNameLE nm ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) } cvtDec (PragmaD prag) @@ -341,7 +341,7 @@ cvtDec (ClosedTypeFamilyD head eqns) cvtDec (TH.RoleAnnotD tc roles) = do { tc' <- tconNameL tc ; let roles' = map (noLoc . cvtRole) roles - ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') } + ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl (lEmb tc') roles') } cvtDec (TH.StandaloneDerivD ds cxt ty) = do { cxt' <- cvtContext cxt @@ -355,7 +355,7 @@ cvtDec (TH.StandaloneDerivD ds cxt ty) cvtDec (TH.DefaultSigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') } + ; returnJustL $ Hs.SigD $ ClassOpSig True [lEmb nm'] (mkLHsSigType ty') } cvtDec (TH.PatSynD nm args dir pat) = do { nm' <- cNameL nm @@ -363,7 +363,7 @@ cvtDec (TH.PatSynD nm args dir pat) ; dir' <- cvtDir nm' dir ; pat' <- cvtPat pat ; returnJustL $ Hs.ValD $ PatSynBind $ - PSB nm' placeHolderType args' pat' dir' } + PSB (lEmb nm') placeHolderType args' pat' dir' } where cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixPatSyn <$> mapM vNameL args cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixPatSyn <$> vNameL a1 <*> vNameL a2 @@ -379,7 +379,7 @@ cvtDec (TH.PatSynD nm args dir pat) ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms } cvtDec (TH.PatSynSigD nm ty) - = do { nm' <- cNameL nm + = do { nm' <- cNameLE nm ; ty' <- cvtPatSynSigTy ty ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') } @@ -485,20 +485,20 @@ mkBadDecMsg doc bads cvtConstr :: TH.Con -> CvtM (LConDecl RdrName) cvtConstr (NormalC c strtys) - = do { c' <- cNameL c + = do { c' <- cNameLE c ; cxt' <- returnL [] ; tys' <- mapM cvt_arg strtys ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') } cvtConstr (RecC c varstrtys) - = do { c' <- cNameL c + = do { c' <- cNameLE c ; cxt' <- returnL [] ; args' <- mapM cvt_id_arg varstrtys ; returnL $ mkConDeclH98 c' Nothing cxt' (RecCon (noLoc args')) } cvtConstr (InfixC st1 c st2) - = do { c' <- cNameL c + = do { c' <- cNameLE c ; cxt' <- returnL [] ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 @@ -527,14 +527,14 @@ cvtConstr (ForallC tvs ctxt con) (con_cxt con'))) } } cvtConstr (GadtC c strtys ty) - = do { c' <- mapM cNameL c + = do { c' <- mapM cNameLE c ; args <- mapM cvt_arg strtys ; L _ ty' <- cvtType ty ; c_ty <- mk_arr_apps args ty' ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)} cvtConstr (RecGadtC c varstrtys ty) - = do { c' <- mapM cNameL c + = do { c' <- mapM cNameLE c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty') @@ -563,7 +563,7 @@ cvt_id_arg (i, str, ty) ; ty' <- cvt_arg (str,ty) ; return $ noLoc (ConDeclField { cd_fld_names - = [L li $ FieldOcc (L li i') PlaceHolder] + = [L li $ FieldOcc (L li $ EName i') PlaceHolder] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } @@ -646,7 +646,7 @@ cvtPragmaD (InlineP nm inline rm phases) , inl_rule = cvtRuleMatch rm , inl_act = cvtPhases phases dflt , inl_sat = Nothing } - ; returnJustL $ Hs.SigD $ InlineSig nm' ip } + ; returnJustL $ Hs.SigD $ InlineSig (lEmb nm') ip } cvtPragmaD (SpecialiseP nm ty inline phases) = do { nm' <- vNameL nm @@ -664,7 +664,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases) , inl_rule = Hs.FunLike , inl_act = cvtPhases phases dflt , inl_sat = Nothing } - ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip } + ; returnJustL $ Hs.SigD $ SpecSig (lEmb nm') [mkLHsSigType ty'] ip } cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtType ty @@ -693,7 +693,7 @@ cvtPragmaD (AnnP target exp) return (TypeAnnProvenance (noLoc n')) ValueAnnotation n -> do n' <- vcName n - return (ValueAnnProvenance (noLoc n')) + return (ValueAnnProvenance (noEmb n')) ; returnJustL $ Hs.AnnD $ HsAnnotation (SourceText "{-# ANN") target' exp' } @@ -703,8 +703,8 @@ cvtPragmaD (LineP line file) ; return Nothing } cvtPragmaD (CompleteP cls mty) - = do { cls' <- noLoc <$> mapM cNameL cls - ; mty' <- traverse tconNameL mty + = do { cls' <- noLoc <$> mapM cNameLE cls + ; mty' <- traverse tconNameLE mty ; returnJustL $ Hs.SigD $ CompleteMatchSig NoSourceText cls' mty' } @@ -768,8 +768,8 @@ cvtClause ctxt (Clause ps body wheres) cvtl :: TH.Exp -> CvtM (LHsExpr RdrName) cvtl e = wrapL (cvt e) where - cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } - cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') } + cvt (VarE s) = do { s' <- vName s; return $ HsVar (noEmb s') } + cvt (ConE s) = do { s' <- cName s; return $ HsVar (noEmb s') } cvt (LitE l) | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' } | otherwise = do { l' <- cvtLit l; return $ HsLit l' } @@ -848,7 +848,7 @@ cvtl e = wrapL (cvt e) cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t ; return $ ExprWithTySig e' (mkLHsSigWcType t') } cvt (RecConE c flds) = do { c' <- cNameL c - ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds + ; flds' <- mapM (cvtFld (mkFieldOcc . noEmb)) flds ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) } cvt (RecUpdE e flds) = do { e' <- cvtl e ; flds' @@ -856,7 +856,7 @@ cvtl e = wrapL (cvt e) flds ; return $ mkRdrRecordUpd e' flds' } cvt (StaticE e) = fmap (HsStatic placeHolderNames) $ cvtl e - cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } + cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noEmb s') } {- Note [Dropping constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1095,7 +1095,8 @@ cvtp (ParensP p) = do { p' <- cvtPat p; _ -> return $ ParPat p' } cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' } cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' } -cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } +cvtp (TH.AsP s p) = do { s' <- vNameL s + ; p' <- cvtPat p; return $ AsPat (lEmb s') p' } cvtp TH.WildP = return $ WildPat placeHolderType cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ; return $ ConPatIn c' @@ -1111,7 +1112,7 @@ cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName)) cvtPatFld (s,p) = do { L ls s' <- vNameL s; p' <- cvtPat p ; return (noLoc $ HsRecField { hsRecFieldLbl - = L ls $ mkFieldOcc (L ls s') + = L ls $ mkFieldOcc (L ls $ EName s') , hsRecFieldArg = p' , hsRecPun = False}) } @@ -1190,13 +1191,13 @@ cvtTypeKind ty_str ty -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) | otherwise -> mk_apps (HsTyVar NotPromoted - (noLoc (getRdrName (tupleTyCon Boxed n)))) tys' + (noEmb (getRdrName (tupleTyCon Boxed n)))) tys' UnboxedTupleT n | length tys' == n -- Saturated -> returnL (HsTupleTy HsUnboxedTuple tys') | otherwise -> mk_apps (HsTyVar NotPromoted - (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys' + (noEmb (getRdrName (tupleTyCon Unboxed n)))) tys' UnboxedSumT n | n < 2 -> failWith $ @@ -1206,22 +1207,22 @@ cvtTypeKind ty_str ty | length tys' == n -- Saturated -> returnL (HsSumTy tys') | otherwise - -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n)))) + -> mk_apps (HsTyVar NotPromoted (noEmb (getRdrName (sumTyCon n)))) tys' ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y') | otherwise -> - mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon))) + mk_apps (HsTyVar NotPromoted (noEmb (getRdrName funTyCon))) tys' ListT | [x'] <- tys' -> returnL (HsListTy x') | otherwise -> - mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon))) + mk_apps (HsTyVar NotPromoted (noEmb (getRdrName listTyCon))) tys' VarT nm -> do { nm' <- tNameL nm - ; mk_apps (HsTyVar NotPromoted nm') tys' } + ; mk_apps (HsTyVar NotPromoted (lEmb nm')) tys' } ConT nm -> do { nm' <- tconName nm - ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' } + ; mk_apps (HsTyVar NotPromoted (noEmb nm')) tys' } ForallT tvs cxt ty | null tys' @@ -1250,7 +1251,7 @@ cvtTypeKind ty_str ty -> do { s' <- tconName s ; t1' <- cvtType t1 ; t2' <- cvtType t2 - ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2'] + ; mk_apps (HsTyVar NotPromoted (noEmb s')) [t1', t2'] } UInfixT t1 s t2 @@ -1266,7 +1267,7 @@ cvtTypeKind ty_str ty } PromotedT nm -> do { nm' <- cName nm - ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' } + ; mk_apps (HsTyVar NotPromoted (noEmb nm')) tys' } -- Promoted data constructor; hence cName PromotedTupleT n @@ -1287,22 +1288,22 @@ cvtTypeKind ty_str ty | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys' -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2)) | otherwise - -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon))) + -> mk_apps (HsTyVar NotPromoted (noEmb (getRdrName consDataCon))) tys' StarT - -> returnL (HsTyVar NotPromoted (noLoc + -> returnL (HsTyVar NotPromoted (noEmb (getRdrName liftedTypeKindTyCon))) ConstraintT -> returnL (HsTyVar NotPromoted - (noLoc (getRdrName constraintKindTyCon))) + (noEmb (getRdrName constraintKindTyCon))) EqualityT | [x',y'] <- tys' -> returnL (HsEqTy x' y') | otherwise -> mk_apps (HsTyVar NotPromoted - (noLoc (getRdrName eqPrimTyCon))) tys' + (noEmb (getRdrName eqPrimTyCon))) tys' _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) } @@ -1345,7 +1346,7 @@ cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _) = L (combineSrcSpans loc1 loc2) $ - HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2') + HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noEmb op)] ++ t2') where t1' | L _ (HsAppsTy t1s) <- t1 = t1s @@ -1492,7 +1493,8 @@ mkHsQualTy ctxt loc ctxt' ty -------------------------------------------------------------------- -- variable names -vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) +cNameLE, vcNameLE, tconNameLE :: TH.Name -> CvtM (LEmbellished RdrName) +vNameL, cNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName -- Variable names @@ -1500,11 +1502,12 @@ vNameL n = wrapL (vName n) vName n = cvtName OccName.varName n -- Constructor function names; this is Haskell source, hence srcDataName +cNameLE n = wrapL (cName n >>= \nn -> return $ EName nn) cNameL n = wrapL (cName n) cName n = cvtName OccName.dataName n -- Variable *or* constructor names; check by looking at the first char -vcNameL n = wrapL (vcName n) +vcNameLE n = wrapL (vcName n >>= \nn -> return $ EName nn) vcName n = if isVarName n then vName n else cName n -- Type variable names @@ -1512,6 +1515,7 @@ tNameL n = wrapL (tName n) tName n = cvtName OccName.tvName n -- Type Constructor names +tconNameLE n = wrapL (tconName n >>= \nn -> return $ EName nn) tconNameL n = wrapL (tconName n) tconName n = cvtName OccName.tcClsName n diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 1f38c387df..60a460aa81 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -24,6 +24,7 @@ import {-# SOURCE #-} HsPat ( LPat ) import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId ) import HsTypes +import HsEmbellished import PprCore () import CoreSyn import TcEvidence @@ -292,7 +293,7 @@ data ABExport id -- | Pattern Synonym binding data PatSynBind idL idR - = PSB { psb_id :: Located idL, -- ^ Name of the pattern synonym + = PSB { psb_id :: LEmbellished idL, -- ^ Name of the pattern synonym psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars] psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names psb_def :: LPat idR, -- ^ Right-hand side @@ -739,7 +740,7 @@ data Sig name -- For details on above see note [Api annotations] in ApiAnnotation TypeSig - [Located name] -- LHS of the signature; e.g. f,g,h :: blah + [LEmbellished name] -- LHS of the signature; e.g. f,g,h :: blah (LHsSigWcType name) -- RHS of the signature; can have wildcards -- | A pattern synonym type signature @@ -751,7 +752,7 @@ data Sig name -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | PatSynSig [Located name] (LHsSigType name) + | PatSynSig [LEmbellished name] (LHsSigType name) -- P :: forall a b. Req => Prov => ty -- | A signature for a class method @@ -764,7 +765,7 @@ data Sig name -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', -- 'ApiAnnotation.AnnDcolon' - | ClassOpSig Bool [Located name] (LHsSigType name) + | ClassOpSig Bool [LEmbellished name] (LHsSigType name) -- | A type signature in generated code, notably the code -- generated for record selectors. We simply record @@ -795,7 +796,7 @@ data Sig name -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | InlineSig (Located name) -- Function name + | InlineSig (LEmbellished name) -- Function name InlinePragma -- Never defaultInlinePragma -- | A specialisation pragma @@ -810,7 +811,7 @@ data Sig name -- 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation - | SpecSig (Located name) -- Specialise a function or datatype ... + | SpecSig (LEmbellished name) -- Specialise a function or datatype ... [LHsSigType name] -- ... to these types InlinePragma -- The pragma on SPECIALISE_INLINE form. -- If it's just defaultInlinePragma, then we said @@ -839,7 +840,7 @@ data Sig name -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | MinimalSig SourceText (LBooleanFormula (Located name)) + | MinimalSig SourceText (LBooleanFormula (LEmbellished name)) -- Note [Pragma source text] in BasicTypes -- | A "set cost centre" pragma for declarations @@ -851,9 +852,11 @@ data Sig name -- > {-# SCC funName "cost_centre_name" #-} | SCCFunSig SourceText -- Note [Pragma source text] in BasicTypes - (Located name) -- Function name + (LEmbellished name) -- Function name (Maybe StringLiteral) - | CompleteMatchSig SourceText (Located [Located name]) (Maybe (Located name)) + | CompleteMatchSig SourceText + (Located [LEmbellished name]) + (Maybe (LEmbellished name)) deriving instance (DataId name) => Data (Sig name) @@ -861,7 +864,7 @@ deriving instance (DataId name) => Data (Sig name) type LFixitySig name = Located (FixitySig name) -- | Fixity Signature -data FixitySig name = FixitySig [Located name] Fixity +data FixitySig name = FixitySig [LEmbellished name] Fixity deriving Data -- | Type checker Specialisation Pragmas diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index e3029a23f5..4c29f2331b 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -100,6 +100,7 @@ import Coercion import ForeignCall import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId ) import NameSet +import HsEmbellished -- others: import InstEnv @@ -1131,7 +1132,7 @@ type LConDecl name = Located (ConDecl name) -- | data Constructor Declaration data ConDecl name = ConDeclGADT - { con_names :: [Located name] + { con_names :: [LEmbellished name] , con_type :: LHsSigType name -- ^ The type after the ‘::’ , con_doc :: Maybe LHsDocString @@ -1139,7 +1140,7 @@ data ConDecl name } | ConDeclH98 - { con_name :: Located name + { con_name :: LEmbellished name , con_qvars :: Maybe (LHsQTyVars name) -- User-written forall (if any), and its implicit @@ -1163,7 +1164,7 @@ deriving instance (DataId name) => Data (ConDecl name) type HsConDeclDetails name = HsConDetails (LBangType name) (Located [LConDeclField name]) -getConNames :: ConDecl name -> [Located name] +getConNames :: ConDecl name -> [LEmbellished name] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names @@ -1865,7 +1866,7 @@ type LVectDecl name = Located (VectDecl name) data VectDecl name = HsVect SourceText -- Note [Pragma source text] in BasicTypes - (Located name) + (LEmbellished name) (LHsExpr name) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose' @@ -1873,7 +1874,7 @@ data VectDecl name -- For details on above see note [Api annotations] in ApiAnnotation | HsNoVect SourceText -- Note [Pragma source text] in BasicTypes - (Located name) + (LEmbellished name) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose' @@ -1881,8 +1882,8 @@ data VectDecl name | HsVectTypeIn -- pre type-checking SourceText -- Note [Pragma source text] in BasicTypes Bool -- 'TRUE' => SCALAR declaration - (Located name) - (Maybe (Located name)) -- 'Nothing' => no right-hand side + (LEmbellished name) + (Maybe (LEmbellished name)) -- 'Nothing' => no right-hand side -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnClose', -- 'ApiAnnotation.AnnEqual' @@ -1894,7 +1895,7 @@ data VectDecl name (Maybe TyCon) -- 'Nothing' => no right-hand side | HsVectClassIn -- pre type-checking SourceText -- Note [Pragma source text] in BasicTypes - (Located name) + (LEmbellished name) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose', @@ -1908,11 +1909,11 @@ data VectDecl name deriving instance (DataId name) => Data (VectDecl name) lvectDeclName :: NamedThing name => LVectDecl name -> Name -lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name -lvectDeclName (L _ (HsNoVect _ (L _ name))) = getName name -lvectDeclName (L _ (HsVectTypeIn _ _ (L _ name) _)) = getName name +lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName $ unEmb name +lvectDeclName (L _ (HsNoVect _ (L _ name))) = getName $ unEmb name +lvectDeclName (L _ (HsVectTypeIn _ _ (L _ name) _)) = getName $ unEmb name lvectDeclName (L _ (HsVectTypeOut _ tycon _)) = getName tycon -lvectDeclName (L _ (HsVectClassIn _ (L _ name))) = getName name +lvectDeclName (L _ (HsVectClassIn _ (L _ name))) = getName $ unEmb name lvectDeclName (L _ (HsVectClassOut cls)) = getName cls lvectDeclName (L _ (HsVectInstIn _)) = panic "HsDecls.lvectDeclName: HsVectInstIn" @@ -2009,7 +2010,7 @@ data WarnDecls name = Warnings { wd_src :: SourceText type LWarnDecl name = Located (WarnDecl name) -- | Warning pragma Declaration -data WarnDecl name = Warning [Located name] WarningTxt +data WarnDecl name = Warning [LEmbellished name] WarningTxt deriving Data instance OutputableBndr name => Outputable (WarnDecls name) where @@ -2050,7 +2051,7 @@ instance (OutputableBndrId name) => Outputable (AnnDecl name) where = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] -- | Annotation Provenance -data AnnProvenance name = ValueAnnProvenance (Located name) +data AnnProvenance name = ValueAnnProvenance (LEmbellished name) | TypeAnnProvenance (Located name) | ModuleAnnProvenance deriving (Data, Functor) @@ -2058,7 +2059,7 @@ deriving instance Foldable AnnProvenance deriving instance Traversable AnnProvenance annProvenanceName_maybe :: AnnProvenance name -> Maybe name -annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name +annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just $ unEmb name annProvenanceName_maybe (TypeAnnProvenance (L _ name)) = Just name annProvenanceName_maybe ModuleAnnProvenance = Nothing @@ -2084,7 +2085,7 @@ type LRoleAnnotDecl name = Located (RoleAnnotDecl name) -- top-level declarations -- | Role Annotation Declaration data RoleAnnotDecl name - = RoleAnnotDecl (Located name) -- type constructor + = RoleAnnotDecl (LEmbellished name) -- type constructor [Located (Maybe Role)] -- optional annotations -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnRole' @@ -2101,4 +2102,4 @@ instance OutputableBndr name => Outputable (RoleAnnotDecl name) where pp_role (Just r) = ppr r roleAnnotDeclName :: RoleAnnotDecl name -> name -roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name +roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = unEmb name diff --git a/compiler/hsSyn/HsEmbellished.hs b/compiler/hsSyn/HsEmbellished.hs new file mode 100644 index 0000000000..9f6c8b39f9 --- /dev/null +++ b/compiler/hsSyn/HsEmbellished.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +module HsEmbellished ( + Embellished(..), + LEmbellished, + noEmb, + unEmb, + unLEmb, + unLocEmb, + lEmb, + reEmb, + reLEmb + ) where + +import SrcLoc +import Outputable + +import Data.Data + +-- | An embellished name +-- +-- The parser can read a RdrName with either parens or backquotes around them. +-- This type wraps the name and captures whichever embellishment is present. +data Embellished name + = EName name + | EParens (Located name) + | EBackquotes (Located name) + deriving (Data, Ord, Eq, Functor, Foldable, Traversable) + +type LEmbellished name = Located (Embellished name) + +noEmb :: name -> LEmbellished name +noEmb n = noLoc $ EName n + +unEmb :: Embellished name -> name +unEmb (EName n) = n +unEmb (EParens (L _ n)) = n +unEmb (EBackquotes (L _ n)) = n + +unLEmb :: LEmbellished name -> Located name +unLEmb (L l en) = L l (unEmb en) + +unLocEmb :: LEmbellished name -> name +unLocEmb (L _ en) = unEmb en + +lEmb :: Located name -> LEmbellished name +lEmb (L l n) = L l $ EName n + +reEmb :: Embellished name1 -> name2 -> Embellished name2 +reEmb (EName _) n = EName n +reEmb (EParens (L l _)) n = EParens (L l n) +reEmb (EBackquotes (L l _)) n = EBackquotes (L l n) + +reLEmb :: LEmbellished name1 -> name2 -> LEmbellished name2 +reLEmb (L l e) n = L l (reEmb e n) + +instance (Outputable name) => Outputable (Embellished name) where + pprPrec n en = pprPrec n (unEmb en) + +instance (OutputableBndr name) => OutputableBndr (Embellished name) where + pprPrefixOcc en = pprPrefixOcc (unEmb en) + pprInfixOcc en = pprInfixOcc (unEmb en) diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 71c408984b..0008827080 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -41,6 +41,7 @@ import Util import Outputable import FastString import Type +import HsEmbellished -- libraries: import Data.Data hiding (Fixity(..)) @@ -125,7 +126,7 @@ noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString NoSourceText -- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the -- renamer), missing its HsWrappers. mkRnSyntaxExpr :: Name -> SyntaxExpr Name -mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name +mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc $ EName name , syn_arg_wraps = [] , syn_res_wrap = WpHole } -- don't care about filling in syn_arg_wraps because we're clearly @@ -274,7 +275,7 @@ information to use is the GlobalRdrEnv itself. -- | A Haskell expression. data HsExpr id - = HsVar (Located id) -- ^ Variable + = HsVar (LEmbellished id) -- ^ Variable -- See Note [Located RdrNames] @@ -667,12 +668,13 @@ data HsExpr id -- These constructors only appear temporarily in the parser. -- The renamer translates them into the Right Thing. + -- AZ: TODO: Needs to be embellished too, for backquotes | EWildPat -- wildcard -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' -- For details on above see note [Api annotations] in ApiAnnotation - | EAsPat (Located id) -- as pattern + | EAsPat (LEmbellished id) -- as pattern (LHsExpr id) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' @@ -2242,7 +2244,7 @@ data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] | DecBrL [LHsDecl id] -- [d| decls |]; result of parser | DecBrG (HsGroup id) -- [d| decls |]; result of renamer | TypBr (LHsType id) -- [t| type |] - | VarBr Bool id -- True: 'x, False: ''T + | VarBr Bool (LEmbellished id) -- True: 'x, False: ''T -- (The Bool flag is used only in pprHsBracket) | TExpBr (LHsExpr id) -- [|| expr ||] deriving instance (DataId id) => Data (HsBracket id) @@ -2261,9 +2263,9 @@ pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp) pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds)) pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) -pprHsBracket (VarBr True n) +pprHsBracket (VarBr True (L _ n)) = char '\'' <> pprPrefixOcc n -pprHsBracket (VarBr False n) +pprHsBracket (VarBr False (L _ n)) = text "''" <> pprPrefixOcc n pprHsBracket (TExpBr e) = thTyBrackets (ppr e) diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 174e83702e..e3c647a80a 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -45,6 +45,7 @@ import HsBinds import HsLit import PlaceHolder import HsTypes +import HsEmbellished import TcEvidence import BasicTypes -- others: @@ -88,7 +89,7 @@ data Pat id -- For details on above see note [Api annotations] in ApiAnnotation - | AsPat (Located id) (LPat id) -- ^ As pattern + | AsPat (LEmbellished id) (LPat id) -- ^ As pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' -- For details on above see note [Api annotations] in ApiAnnotation @@ -391,7 +392,7 @@ hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl hsRecFieldId :: HsRecField Id arg -> Located Id hsRecFieldId = hsRecFieldSel -hsRecUpdFieldRdr :: HsRecUpdField id -> Located RdrName +hsRecUpdFieldRdr :: HsRecUpdField id -> LEmbellished RdrName hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc Id) arg -> Located Id diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs index e7cae91572..4da8cd3b43 100644 --- a/compiler/hsSyn/HsSyn.hs +++ b/compiler/hsSyn/HsSyn.hs @@ -27,6 +27,7 @@ module HsSyn ( module HsUtils, module HsDoc, module PlaceHolder, + module HsEmbellished, Fixity, HsModule(..) @@ -39,6 +40,7 @@ import HsExpr import HsImpExp import HsLit import PlaceHolder +import HsEmbellished import HsPat import HsTypes import BasicTypes ( Fixity, WarningTxt ) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 998f8bdedd..0df26582bd 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -86,6 +86,7 @@ import BasicTypes import SrcLoc import Outputable import FastString +import HsEmbellished import Maybes( isJust ) import Data.Data hiding ( Fixity, Prefix, Infix ) @@ -434,7 +435,7 @@ data HsType name | HsTyVar Promoted -- whether explicitly promoted, for the pretty -- printer - (Located name) + (LEmbellished name) -- Type variable, type constructor, or data constructor -- see Note [Promotions (HsTyVar)] -- See Note [Located RdrNames] in HsExpr @@ -605,7 +606,7 @@ type LHsAppType name = Located (HsAppType name) -- | Haskell Application Type data HsAppType name - = HsAppInfix (Located name) -- either a symbol or an id in backticks + = HsAppInfix (LEmbellished name) -- either a symbol or an id in backticks | HsAppPrefix (LHsType name) -- anything else, including things like (+) deriving instance (DataId name) => Data (HsAppType name) @@ -884,9 +885,10 @@ hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) -- | Convert a LHsTyVarBndr to an equivalent LHsType. hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name hsLTyVarBndrToType = fmap cvt - where cvt (UserTyVar n) = HsTyVar NotPromoted n + where cvt (UserTyVar n) = HsTyVar NotPromoted (lEmb n) cvt (KindedTyVar (L name_loc n) kind) - = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc n))) kind + = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc $ EName n))) + kind -- | Convert a LHsTyVarBndrs to a list of types. -- Works on *type* variable only, no kind vars. @@ -953,7 +955,7 @@ splitHsFunType (L _ (HsFunTy x y)) splitHsFunType orig_ty@(L _ (HsAppTy t1 t2)) = go t1 [t2] where -- Look for (->) t1 t2, possibly with parenthesisation - go (L _ (HsTyVar _ (L _ fn))) tys | fn == funTyConName + go (L _ (HsTyVar _ (L _ fn))) tys | unEmb fn == funTyConName , [t1,t2] <- tys , (args, res) <- splitHsFunType t2 = (t1:args, res) @@ -983,7 +985,7 @@ getAppsTyHead_maybe tys = case splitHsAppsTy tys of -- element of @non_syms@ followed by the first element of @syms@ followed by -- the next element of @non_syms@, etc. It is guaranteed that the non_syms list -- has one more element than the syms list. -splitHsAppsTy :: [LHsAppType name] -> ([[LHsType name]], [Located name]) +splitHsAppsTy :: [LHsAppType name] -> ([[LHsType name]], [LEmbellished name]) splitHsAppsTy = go [] [] [] where go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym) @@ -999,7 +1001,7 @@ splitHsAppsTy = go [] [] [] hsTyGetAppHead_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) hsTyGetAppHead_maybe = go [] where - go tys (L _ (HsTyVar _ ln)) = Just (ln, tys) + go tys (L _ (HsTyVar _ ln)) = Just (unLEmb ln, tys) go tys (L _ (HsAppsTy apps)) | Just (head, args, _) <- getAppsTyHead_maybe apps = go (args ++ tys) head @@ -1081,7 +1083,7 @@ type LFieldOcc name = Located (FieldOcc name) -- Represents an *occurrence* of an unambiguous field. We store -- both the 'RdrName' the user originally wrote, and after the -- renamer, the selector function. -data FieldOcc name = FieldOcc { rdrNameFieldOcc :: Located RdrName +data FieldOcc name = FieldOcc { rdrNameFieldOcc :: LEmbellished RdrName -- ^ See Note [Located RdrNames] in HsExpr , selectorFieldOcc :: PostRn name name } @@ -1092,7 +1094,7 @@ deriving instance (Data name, Data (PostRn name name)) => Data (FieldOcc name) instance Outputable (FieldOcc name) where ppr = ppr . rdrNameFieldOcc -mkFieldOcc :: Located RdrName -> FieldOcc RdrName +mkFieldOcc :: LEmbellished RdrName -> FieldOcc RdrName mkFieldOcc rdr = FieldOcc rdr PlaceHolder @@ -1109,8 +1111,8 @@ mkFieldOcc rdr = FieldOcc rdr PlaceHolder -- Note [Disambiguating record fields] in TcExpr. -- See Note [Located RdrNames] in HsExpr data AmbiguousFieldOcc name - = Unambiguous (Located RdrName) (PostRn name name) - | Ambiguous (Located RdrName) (PostTc name name) + = Unambiguous (LEmbellished RdrName) (PostRn name name) + | Ambiguous (LEmbellished RdrName) (PostTc name name) deriving instance ( Data name , Data (PostRn name name) , Data (PostTc name name)) @@ -1124,9 +1126,9 @@ instance OutputableBndr (AmbiguousFieldOcc name) where pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc RdrName -mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder +mkAmbiguousFieldOcc rdr = Unambiguous (lEmb rdr) PlaceHolder -rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc name -> RdrName +rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc name -> Embellished RdrName rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr rdrNameAmbiguousFieldOcc (Ambiguous (L _ rdr) _) = rdr diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 8001a15d8d..e067d93719 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -120,6 +120,7 @@ import Util import Bag import Outputable import Constants +import HsEmbellished import Data.Either import Data.Function @@ -196,7 +197,7 @@ mkHsCaseAlt pat expr = mkSimpleMatch CaseAlt [pat] expr nlHsTyApp :: name -> [Type] -> LHsExpr name -nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id))) +nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noEmb fun_id))) nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs @@ -315,7 +316,7 @@ mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } --- A useful function for building @OpApps@. The operator is always a -- variable, and we don't know the fixity yet. mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id -mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op))) +mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noEmb op))) (error "mkOpApp:fixity") e2 unqualSplice :: RdrName @@ -368,7 +369,7 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ] -} nlHsVar :: id -> LHsExpr id -nlHsVar n = noLoc (HsVar (noLoc n)) +nlHsVar n = noLoc (HsVar (noEmb n)) -- NB: Only for LHsExpr **Id** nlHsDataCon :: DataCon -> LHsExpr Id @@ -405,7 +406,7 @@ nlHsApps :: id -> [LHsExpr id] -> LHsExpr id nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs nlHsVarApps :: id -> [id] -> LHsExpr id -nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs)) +nlHsVarApps f xs = noLoc (foldl mk (HsVar (noEmb f)) (map (HsVar . noEmb) xs)) where mk f a = HsApp (noLoc f) (noLoc a) @@ -472,7 +473,7 @@ nlHsFunTy :: LHsType name -> LHsType name -> LHsType name nlHsParTy :: LHsType name -> LHsType name nlHsAppTy f t = noLoc (HsAppTy f t) -nlHsTyVar x = noLoc (HsTyVar NotPromoted (noLoc x)) +nlHsTyVar x = noLoc (HsTyVar NotPromoted (noEmb x)) nlHsFunTy a b = noLoc (HsFunTy a b) nlHsParTy t = noLoc (HsParTy t) @@ -722,7 +723,7 @@ mkVarBind :: id -> LHsExpr id -> LHsBind id mkVarBind var rhs = L (getLoc rhs) $ VarBind { var_id = var, var_rhs = rhs, var_inline = False } -mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) +mkPatSynBind :: LEmbellished RdrName -> HsPatSynDetails (Located RdrName) -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName mkPatSynBind name details lpat dir = PatSynBind psb where @@ -891,7 +892,7 @@ collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc | omitPatSyn = acc - | otherwise = ps : acc + | otherwise = unEmb ps : acc collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName] -- Used exclusively for the bindings of an instance decl which are all FunBinds @@ -940,7 +941,7 @@ collect_lpat (L _ pat) bndrs go (WildPat _) = bndrs go (LazyPat pat) = collect_lpat pat bndrs go (BangPat pat) = collect_lpat pat bndrs - go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs + go (AsPat (L _ a) pat) = unEmb a : collect_lpat pat bndrs go (ViewPat _ pat _) = collect_lpat pat bndrs go (ParPat pat) = collect_lpat pat bndrs @@ -1007,11 +1008,13 @@ hsTyClForeignBinders tycl_decls foreign_decls `mappend` foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) where - getSelectorNames :: ([Located Name], [LFieldOcc Name]) -> [Name] - getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs + getSelectorNames :: ([LEmbellished Name], [LFieldOcc Name]) -> [Name] + getSelectorNames (ns, fs) + = map unLocEmb ns ++ map (selectorFieldOcc.unLoc) fs ------------------- -hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc name]) +hsLTyClDeclBinders :: Located (TyClDecl name) + -> ([LEmbellished name], [LFieldOcc name]) -- ^ Returns all the /binding/ names of the decl. The first one is -- guaranteed to be the name of the decl. The first component @@ -1023,16 +1026,19 @@ hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc nam -- See Note [SrcSpan for binders] hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } })) - = ([L loc name], []) -hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = ([L loc name], []) + = ([L loc $ EName name], []) +hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) + = ([L loc (EName 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 (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ] + = (L loc (EName cls_name) : + [ L fam_loc (EName fam_name) | + L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++ + [ L mem_loc (EName mem_name) | L mem_loc (ClassOpSig False ns _) <- sigs + , L _ mem_name <- (map unLEmb ns) ] , []) hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })) - = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn + = (\ (xs, ys) -> (L loc (EName name) : xs, ys)) $ hsDataDefnBinders defn ------------------- hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name] @@ -1062,7 +1068,7 @@ getPatSynBinds binds , L _ (PatSynBind psb) <- bagToList lbinds ] ------------------- -hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name]) +hsLInstDeclBinders :: LInstDecl name -> ([LEmbellished name], [LFieldOcc name]) hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })) = foldMap (hsDataFamInstBinders . unLoc) dfis hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi })) @@ -1071,26 +1077,27 @@ hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty ------------------- -- the SrcLoc returned are for the whole declarations, not just the names -hsDataFamInstBinders :: DataFamInstDecl name -> ([Located name], [LFieldOcc name]) +hsDataFamInstBinders :: DataFamInstDecl name + -> ([LEmbellished name], [LFieldOcc name]) hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn }) = 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 :: HsDataDefn name -> ([Located name], [LFieldOcc name]) +hsDataDefnBinders :: HsDataDefn name -> ([LEmbellished name], [LFieldOcc name]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] ------------------- -hsConDeclsBinders :: [LConDecl name] -> ([Located name], [LFieldOcc name]) +hsConDeclsBinders :: [LConDecl name] -> ([LEmbellished name], [LFieldOcc 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 = go id cons where go :: ([LFieldOcc name] -> [LFieldOcc name]) - -> [LConDecl name] -> ([Located name], [LFieldOcc name]) + -> [LConDecl name] -> ([LEmbellished name], [LFieldOcc name]) go _ [] = ([], []) go remSeen (r:rs) = -- don't re-mangle the location of field names, because we don't @@ -1112,7 +1119,8 @@ hsConDeclsBinders cons = go id cons where (ns, fs) = go remSeen rs where (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty - record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs) + record_gadt flds = (map (L loc . unLoc) names ++ ns + , r' ++ fs) where r' = remSeen (concatMap (cd_fld_names . unLoc) flds) remSeen' = foldr (.) remSeen [deleteBy ((==) `on` |