Make type import/export API Annotation friendly

Summary:
At the moment an export of the form

   type C(..)

is parsed by the rule

```
  |  'type' oqtycon           {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2)))
                                     [mj AnnType $1,mj AnnVal $2] }
```

This means that the origiinal oqtycon loses its location which is then retained
in the AnnVal annotation.

The problem is if the oqtycon has its own annotations, these get lost.

e.g. in

  type (?)(..)

the parens annotations for (?) get lost.

This patch adds a wrapper around the name in the IE type to

(a) provide a distinct location for the adornment annotation and

(b) identify the specific adornment, for use in the pretty printer rather than
occName magic.

Updates haddock submodule

Test Plan: ./validate

Reviewers: mpickering, dfeuer, bgamari, austin

Reviewed By: dfeuer

Subscribers: dfeuer, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D3016

GHC Trac Issues: #13163

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