diff options
Diffstat (limited to 'compiler/hsSyn')
| -rw-r--r-- | compiler/hsSyn/HsImpExp.hs | 108 |
1 files changed, 74 insertions, 34 deletions
diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs index 8641f1ff3f..3424a0816c 100644 --- a/compiler/hsSyn/HsImpExp.hs +++ b/compiler/hsSyn/HsImpExp.hs @@ -12,7 +12,7 @@ module HsImpExp where import Module ( ModuleName ) import HsDoc ( HsDocString ) -import OccName ( HasOccName(..), isTcOcc, isSymOcc, isDataOcc ) +import OccName ( HasOccName(..), isTcOcc, isSymOcc ) import BasicTypes ( SourceText(..), StringLiteral(..), pprWithSourceText ) import FieldLabel ( FieldLbl(..) ) @@ -134,6 +134,22 @@ instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) ************************************************************************ -} +-- | A name in an import or export specfication which may have adornments. Used +-- primarily for accurate pretty printing of ParsedSource, and API Annotation +-- placement. +data IEWrappedName name + = IEName (Located name) -- ^ no extra + | IEPattern (Located name) -- ^ pattern X + | IEType (Located name) -- ^ type (:+:) + deriving (Eq,Data) + +-- | Located name with possible adornment +-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnType', +-- 'ApiAnnotation.AnnPattern' +type LIEWrappedName name = Located (IEWrappedName name) +-- For details on above see note [Api annotations] in ApiAnnotation + + -- | Located Import or Export type LIE name = Located (IE name) -- ^ When in a list this may have @@ -144,15 +160,10 @@ type LIE name = Located (IE name) -- | Imported or exported entity. data IE name - = IEVar (Located name) + = IEVar (LIEWrappedName name) -- ^ Imported or Exported Variable - -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern', - -- 'ApiAnnotation.AnnType' - -- For details on above see note [Api annotations] in ApiAnnotation - -- See Note [Located RdrNames] in HsExpr - | IEThingAbs (Located name) + | IEThingAbs (LIEWrappedName name) -- ^ Imported or exported Thing with Absent list -- -- The thing is a Class/Type (can't tell) @@ -161,7 +172,7 @@ data IE name -- For details on above see note [Api annotations] in ApiAnnotation -- See Note [Located RdrNames] in HsExpr - | IEThingAll (Located name) + | IEThingAll (LIEWrappedName name) -- ^ Imported or exported Thing with All imported or exported -- -- The thing is a Class/Type and the All refers to methods/constructors @@ -173,9 +184,9 @@ data IE name -- For details on above see note [Api annotations] in ApiAnnotation -- See Note [Located RdrNames] in HsExpr - | IEThingWith (Located name) + | IEThingWith (LIEWrappedName name) IEWildcard - [Located name] + [LIEWrappedName name] [Located (FieldLbl name)] -- ^ Imported or exported Thing With given imported or exported -- @@ -221,50 +232,79 @@ See Note [Representing fields in AvailInfo] in Avail for more details. -} ieName :: IE name -> name -ieName (IEVar (L _ n)) = n -ieName (IEThingAbs (L _ n)) = n -ieName (IEThingWith (L _ n) _ _ _) = n -ieName (IEThingAll (L _ n)) = n +ieName (IEVar (L _ n)) = ieWrappedName n +ieName (IEThingAbs (L _ n)) = ieWrappedName n +ieName (IEThingWith (L _ n) _ _ _) = ieWrappedName n +ieName (IEThingAll (L _ n)) = ieWrappedName n ieName _ = panic "ieName failed pattern match!" ieNames :: IE a -> [a] -ieNames (IEVar (L _ n) ) = [n] -ieNames (IEThingAbs (L _ n) ) = [n] -ieNames (IEThingAll (L _ n) ) = [n] -ieNames (IEThingWith (L _ n) _ ns _) = n : map unLoc ns +ieNames (IEVar (L _ n) ) = [ieWrappedName n] +ieNames (IEThingAbs (L _ n) ) = [ieWrappedName n] +ieNames (IEThingAll (L _ n) ) = [ieWrappedName n] +ieNames (IEThingWith (L _ n) _ ns _) = ieWrappedName n + : map (ieWrappedName . unLoc) ns ieNames (IEModuleContents _ ) = [] ieNames (IEGroup _ _ ) = [] ieNames (IEDoc _ ) = [] ieNames (IEDocNamed _ ) = [] -pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc -pprImpExp name = type_pref <+> pprPrefixOcc name - where - occ = occName name - type_pref | isTcOcc occ && isSymOcc occ = text "type" - | otherwise = empty +ieWrappedName :: IEWrappedName name -> name +ieWrappedName (IEName (L _ n)) = n +ieWrappedName (IEPattern (L _ n)) = n +ieWrappedName (IEType (L _ n)) = n + +ieLWrappedName :: LIEWrappedName name -> Located name +ieLWrappedName (L l n) = L l (ieWrappedName n) + +replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2 +replaceWrappedName (IEName (L l _)) n = IEName (L l n) +replaceWrappedName (IEPattern (L l _)) n = IEPattern (L l n) +replaceWrappedName (IEType (L l _)) n = IEType (L l n) + +replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2 +replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where - ppr (IEVar var) - -- This is a messy test, should perhaps create IEPatternVar - = (if isDataOcc $ occName $ unLoc var then text "pattern" else empty) - <+> pprPrefixOcc (unLoc var) - ppr (IEThingAbs thing) = pprImpExp (unLoc thing) - ppr (IEThingAll thing) = hcat [pprImpExp (unLoc thing), text "(..)"] + ppr (IEVar var) = ppr (unLoc var) + ppr (IEThingAbs thing) = ppr (unLoc thing) + ppr (IEThingAll thing) = hcat [ppr (unLoc thing), text "(..)"] ppr (IEThingWith thing wc withs flds) - = pprImpExp (unLoc thing) <> parens (fsep (punctuate comma + = ppr (unLoc thing) <> parens (fsep (punctuate comma (ppWiths ++ map (ppr . flLabel . unLoc) flds))) where ppWiths = case wc of NoIEWildcard -> - map (pprImpExp . unLoc) withs + map (ppr . unLoc) withs IEWildcard pos -> - let (bs, as) = splitAt pos (map (pprImpExp . unLoc) withs) + let (bs, as) = splitAt pos (map (ppr . unLoc) withs) in bs ++ [text ".."] ++ as ppr (IEModuleContents mod') = text "module" <+> ppr mod' ppr (IEGroup n _) = text ("<IEGroup: " ++ show n ++ ">") ppr (IEDoc doc) = ppr doc ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">") + +instance (HasOccName name) => HasOccName (IEWrappedName name) where + occName w = occName (ieWrappedName w) + +instance (OutputableBndr name, HasOccName name) + => OutputableBndr (IEWrappedName name) where + pprBndr bs w = pprBndr bs (ieWrappedName w) + pprPrefixOcc w = pprPrefixOcc (ieWrappedName w) + pprInfixOcc w = pprInfixOcc (ieWrappedName w) + +instance (HasOccName name, OutputableBndr name) + => Outputable (IEWrappedName name) where + ppr (IEName n) = pprPrefixOcc (unLoc n) + ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n) + ppr (IEType n) = text "type" <+> pprPrefixOcc (unLoc n) + +pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc +pprImpExp name = type_pref <+> pprPrefixOcc name + where + occ = occName name + type_pref | isTcOcc occ && isSymOcc occ = text "type" + | otherwise = empty |