Make type import/export API Annotation friendly
authorAlan Zimmerman <alan.zimm@gmail.com>
Mon, 23 Jan 2017 18:23:28 +0000 (20:23 +0200)
committerAlan Zimmerman <alan.zimm@gmail.com>
Thu, 26 Jan 2017 13:20:14 +0000 (15:20 +0200)
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

12 files changed:
compiler/hsSyn/HsImpExp.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnNames.hs
compiler/typecheck/TcRnExports.hs
testsuite/driver/extra_files.py
testsuite/tests/ghc-api/annotations/Makefile
testsuite/tests/ghc-api/annotations/T13163.stdout [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/Test13163.hs [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/all.T
utils/check-ppr/README
utils/haddock

index 8641f1f..3424a08 100644 (file)
@@ -12,7 +12,7 @@ module HsImpExp where
 
 import Module           ( ModuleName )
 import HsDoc            ( HsDocString )
 
 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(..) )
 
 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
 -- | 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
 
 -- | Imported or exported entity.
 data IE name
-  = IEVar       (Located name)
+  = IEVar       (LIEWrappedName name)
         -- ^ Imported or Exported Variable
         -- ^ 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)
         -- ^ 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
 
         -- 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
         -- ^ 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
 
         -- For details on above see note [Api annotations] in ApiAnnotation
         -- See Note [Located RdrNames] in HsExpr
 
-  | IEThingWith (Located name)
+  | IEThingWith (LIEWrappedName name)
                 IEWildcard
                 IEWildcard
-                [Located name]
+                [LIEWrappedName name]
                 [Located (FieldLbl name)]
         -- ^ Imported or exported Thing With given imported or exported
         --
                 [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 :: 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]
 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       _    )     = []
 
 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
 
 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)
     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 ->
                                               (ppWiths ++
                                               map (ppr . flLabel . unLoc) flds)))
       where
         ppWiths =
           case wc of
               NoIEWildcard ->
-                map (pprImpExp . unLoc) withs
+                map (ppr . unLoc) withs
               IEWildcard pos ->
               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 ++ ">")
                 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
index 2b70fb7..e0e060e 100644 (file)
@@ -793,7 +793,7 @@ export  :: { OrdList (LIE RdrName) }
                                           >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) }
         |  'module' modid            {% amsu (sLL $1 $> (IEModuleContents $2))
                                              [mj AnnModule $1] }
                                           >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) }
         |  'module' modid            {% amsu (sLL $1 $> (IEModuleContents $2))
                                              [mj AnnModule $1] }
-        |  'pattern' qcon            {% amsu (sLL $1 $> (IEVar $2))
+        |  'pattern' qcon            {% amsu (sLL $1 $> (IEVar (sLL $1 $> (IEPattern $2))))
                                              [mj AnnPattern $1] }
 
 export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
                                              [mj AnnPattern $1] }
 
 export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
@@ -803,13 +803,13 @@ export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
                                             (as ++ [mop $1,mcp $3] ++ fst $2, ie) }
 
 
                                             (as ++ [mop $1,mcp $3] ++ fst $2, ie) }
 
 
-qcnames :: { ([AddAnn], [Located (Maybe RdrName)]) }
+qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) }
   : {- empty -}                   { ([],[]) }
   | qcnames1                      { $1 }
 
   : {- empty -}                   { ([],[]) }
   | qcnames1                      { $1 }
 
-qcnames1 :: { ([AddAnn], [Located (Maybe RdrName)]) }     -- A reversed list
+qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) }     -- A reversed list
         :  qcnames1 ',' qcname_ext_w_wildcard  {% case (head (snd $1)) of
         :  qcnames1 ',' qcname_ext_w_wildcard  {% case (head (snd $1)) of
-                                                    l@(L _ Nothing) ->
+                                                    l@(L _ ImpExpQcWildcard) ->
                                                        return ([mj AnnComma $2, mj AnnDotdot l]
                                                                ,(snd (unLoc $3)  : snd $1))
                                                     l -> (ams (head (snd $1)) [mj AnnComma $2] >>
                                                        return ([mj AnnComma $2, mj AnnDotdot l]
                                                                ,(snd (unLoc $3)  : snd $1))
                                                     l -> (ams (head (snd $1)) [mj AnnComma $2] >>
@@ -822,14 +822,15 @@ qcnames1 :: { ([AddAnn], [Located (Maybe RdrName)]) }     -- A reversed list
 
 -- Variable, data constructor or wildcard
 -- or tagged type constructor
 
 -- Variable, data constructor or wildcard
 -- or tagged type constructor
-qcname_ext_w_wildcard :: { Located ([AddAnn],Located (Maybe RdrName)) }
-        :  qcname_ext               { sL1 $1 ([],Just `fmap` $1) }
-        |  '..'                     { sL1 $1 ([mj AnnDotdot $1], sL1 $1 Nothing) }
-
-qcname_ext :: { Located RdrName }
-        :  qcname                   { $1 }
-        |  'type' oqtycon           {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2)))
-                                            [mj AnnType $1,mj AnnVal $2] }
+qcname_ext_w_wildcard :: { Located ([AddAnn], Located ImpExpQcSpec) }
+        :  qcname_ext               { sL1 $1 ([],$1) }
+        |  '..'                     { sL1 $1 ([mj AnnDotdot $1], sL1 $1 ImpExpQcWildcard)  }
+
+qcname_ext :: { Located ImpExpQcSpec }
+        :  qcname                   { sL1 $1 (ImpExpQcName $1) }
+        |  'type' oqtycon           {% do { n <- mkTypeImpExp $2
+                                          ; ams (sLL $1 $> (ImpExpQcType n))
+                                                [mj AnnType $1] } }
 
 qcname  :: { Located RdrName }  -- Variable or type constructor
         :  qvar                 { $1 } -- Things which look like functions
 
 qcname  :: { Located RdrName }  -- Variable or type constructor
         :  qvar                 { $1 } -- Things which look like functions
index 64a60c4..2c63c42 100644 (file)
@@ -56,6 +56,7 @@ module   RdrHsSyn (
 
         -- Help with processing exports
         ImpExpSubSpec(..),
 
         -- Help with processing exports
         ImpExpSubSpec(..),
+        ImpExpQcSpec(..),
         mkModuleImpExp,
         mkTypeImpExp,
         mkImpExpSubSpec,
         mkModuleImpExp,
         mkTypeImpExp,
         mkImpExpSubSpec,
@@ -1436,30 +1437,37 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
 
 data ImpExpSubSpec = ImpExpAbs
                    | ImpExpAll
 
 data ImpExpSubSpec = ImpExpAbs
                    | ImpExpAll
-                   | ImpExpList [Located RdrName]
-                   | ImpExpAllWith [Located (Maybe RdrName)]
+                   | ImpExpList [Located ImpExpQcSpec]
+                   | ImpExpAllWith [Located ImpExpQcSpec]
 
 
-mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> P (IE RdrName)
-mkModuleImpExp n@(L l name) subs =
+data ImpExpQcSpec = ImpExpQcName (Located RdrName)
+                  | ImpExpQcType (Located RdrName)
+                  | ImpExpQcWildcard
+
+mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE RdrName)
+mkModuleImpExp (L l specname) subs =
   case subs of
     ImpExpAbs
   case subs of
     ImpExpAbs
-      | isVarNameSpace (rdrNameSpace name) -> return $ IEVar  n
-      | otherwise                          -> IEThingAbs . L l <$> nameT
-    ImpExpAll                              -> IEThingAll . L l <$> nameT
-    ImpExpList xs                          ->
-      (\newName -> IEThingWith (L l newName) NoIEWildcard xs []) <$> nameT
+      | isVarNameSpace (rdrNameSpace name)
+                               -> return $ IEVar (L l (ieNameFromSpec specname))
+      | otherwise              -> IEThingAbs . L l <$> nameT
+    ImpExpAll                  -> IEThingAll . L l <$> nameT
+    ImpExpList xs              ->
+      (\newName -> IEThingWith (L l newName) NoIEWildcard (wrapped xs) [])
+        <$> nameT
     ImpExpAllWith xs                       ->
       do allowed <- extension patternSynonymsEnabled
          if allowed
           then
             let withs = map unLoc xs
                 pos   = maybe NoIEWildcard IEWildcard
     ImpExpAllWith xs                       ->
       do allowed <- extension patternSynonymsEnabled
          if allowed
           then
             let withs = map unLoc xs
                 pos   = maybe NoIEWildcard IEWildcard
-                          (findIndex isNothing withs)
-                ies   = [L l n | L l (Just n) <- xs]
+                          (findIndex isImpExpQcWildcard withs)
+                ies   = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
             in (\newName -> IEThingWith (L l newName) pos ies []) <$> nameT
           else parseErrorSDoc l
             (text "Illegal export form (use PatternSynonyms to enable)")
   where
             in (\newName -> IEThingWith (L l newName) pos ies []) <$> nameT
           else parseErrorSDoc l
             (text "Illegal export form (use PatternSynonyms to enable)")
   where
+    name = ieNameVal specname
     nameT =
       if isVarNameSpace (rdrNameSpace name)
         then parseErrorSDoc l
     nameT =
       if isVarNameSpace (rdrNameSpace name)
         then parseErrorSDoc l
@@ -1469,7 +1477,17 @@ mkModuleImpExp n@(L l name) subs =
                    then text "If" <+> quotes (ppr name) <+> text "is a type constructor"
                     <+> text "then enable ExplicitNamespaces and use the 'type' keyword."
                    else empty)
                    then text "If" <+> quotes (ppr name) <+> text "is a type constructor"
                     <+> text "then enable ExplicitNamespaces and use the 'type' keyword."
                    else empty)
-        else return $ name
+        else return $ ieNameFromSpec specname
+
+    ieNameVal (ImpExpQcName ln)  = unLoc ln
+    ieNameVal (ImpExpQcType ln)  = unLoc ln
+    ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard"
+
+    ieNameFromSpec (ImpExpQcName ln)  = IEName ln
+    ieNameFromSpec (ImpExpQcType ln)  = IEType ln
+    ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"
+
+    wrapped = map (\(L l x) -> L l (ieNameFromSpec x))
 
 mkTypeImpExp :: Located RdrName   -- TcCls or Var name space
              -> P (Located RdrName)
 
 mkTypeImpExp :: Located RdrName   -- TcCls or Var name space
              -> P (Located RdrName)
@@ -1492,15 +1510,18 @@ checkImportSpec ie@(L _ specs) =
         $+$ text "pattern synonyms with types in module exports.")
 
 -- In the correct order
         $+$ text "pattern synonyms with types in module exports.")
 
 -- In the correct order
-mkImpExpSubSpec :: [Located (Maybe RdrName)] -> P ([AddAnn], ImpExpSubSpec)
+mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
 mkImpExpSubSpec [] = return ([], ImpExpList [])
 mkImpExpSubSpec [] = return ([], ImpExpList [])
-mkImpExpSubSpec [L l Nothing] =
-  return ([\s -> addAnnotation s AnnDotdot l], ImpExpAll)
+mkImpExpSubSpec [L _ ImpExpQcWildcard] =
+  return ([], ImpExpAll)
 mkImpExpSubSpec xs =
 mkImpExpSubSpec xs =
-  if (any (isNothing . unLoc) xs)
+  if (any (isImpExpQcWildcard . unLoc) xs)
     then return $ ([], ImpExpAllWith xs)
     then return $ ([], ImpExpAllWith xs)
-    else return $ ([], ImpExpList ([L l x | L l (Just x) <- xs]))
+    else return $ ([], ImpExpList xs)
 
 
+isImpExpQcWildcard :: ImpExpQcSpec -> Bool
+isImpExpQcWildcard ImpExpQcWildcard = True
+isImpExpQcWildcard _                = False
 
 -----------------------------------------------------------------------------
 -- Misc utils
 
 -----------------------------------------------------------------------------
 -- Misc utils
index 9d2de74..2cde294 100644 (file)
@@ -873,18 +873,19 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
     lookup_ie ie = handle_bad_import $ do
       case ie of
         IEVar (L l n) -> do
     lookup_ie ie = handle_bad_import $ do
       case ie of
         IEVar (L l n) -> do
-            (name, avail, _) <- lookup_name n
-            return ([(IEVar (L l name), trimAvail avail name)], [])
+            (name, avail, _) <- lookup_name $ ieWrappedName n
+            return ([(IEVar (L l (replaceWrappedName n name)),
+                                                  trimAvail avail name)], [])
 
         IEThingAll (L l tc) -> do
 
         IEThingAll (L l tc) -> do
-            (name, avail, mb_parent) <- lookup_name tc
+            (name, avail, mb_parent) <- lookup_name $ ieWrappedName tc
             let warns = case avail of
                           Avail {}                     -- e.g. f(..)
             let warns = case avail of
                           Avail {}                     -- e.g. f(..)
-                            -> [DodgyImport tc]
+                            -> [DodgyImport $ ieWrappedName tc]
 
                           AvailTC _ subs fs
                             | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym
 
                           AvailTC _ subs fs
                             | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym
-                            -> [DodgyImport tc]
+                            -> [DodgyImport $ ieWrappedName tc]
 
                             | not (is_qual decl_spec)  -- e.g. import M( T(..) )
                             -> [MissingImportList]
 
                             | not (is_qual decl_spec)  -- e.g. import M( T(..) )
                             -> [MissingImportList]
@@ -892,7 +893,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
                             | otherwise
                             -> []
 
                             | otherwise
                             -> []
 
-                renamed_ie = IEThingAll (L l name)
+                renamed_ie = IEThingAll (L l (replaceWrappedName tc name))
                 sub_avails = case avail of
                                Avail {}              -> []
                                AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]
                 sub_avails = case avail of
                                Avail {}              -> []
                                AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]
@@ -902,23 +903,26 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
               Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)
                              -- associated type
 
               Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)
                              -- associated type
 
-        IEThingAbs (L l tc)
+        IEThingAbs (L l tc')
             | want_hiding   -- hiding ( C )
                        -- Here the 'C' can be a data constructor
                        --  *or* a type/class, or even both
             | want_hiding   -- hiding ( C )
                        -- Here the 'C' can be a data constructor
                        --  *or* a type/class, or even both
-            -> let tc_name = lookup_name tc
+            -> let tc = ieWrappedName tc'
+                   tc_name = lookup_name tc
                    dc_name = lookup_name (setRdrNameSpace tc srcDataName)
                in
                case catIELookupM [ tc_name, dc_name ] of
                  []    -> failLookupWith BadImport
                    dc_name = lookup_name (setRdrNameSpace tc srcDataName)
                in
                case catIELookupM [ tc_name, dc_name ] of
                  []    -> failLookupWith BadImport
-                 names -> return ([mkIEThingAbs l name | name <- names], [])
+                 names -> return ([mkIEThingAbs tc' l name | name <- names], [])
             | otherwise
             | otherwise
-            -> do nameAvail <- lookup_name tc
-                  return ([mkIEThingAbs l nameAvail], [])
+            -> do nameAvail <- lookup_name (ieWrappedName tc')
+                  return ([mkIEThingAbs tc' l nameAvail]
+                         , [])
 
 
-        IEThingWith (L l rdr_tc) wc rdr_ns rdr_fs ->
+        IEThingWith (L l rdr_tc) wc rdr_ns' rdr_fs ->
           ASSERT2(null rdr_fs, ppr rdr_fs) do
           ASSERT2(null rdr_fs, ppr rdr_fs) do
-           (name, AvailTC _ ns subflds, mb_parent) <- lookup_name rdr_tc
+           (name, AvailTC _ ns subflds, mb_parent)
+                                         <- lookup_name (ieWrappedName rdr_tc)
 
            -- Look up the children in the sub-names of the parent
            let subnames = case ns of   -- The tc is first in ns,
 
            -- Look up the children in the sub-names of the parent
            let subnames = case ns of   -- The tc is first in ns,
@@ -926,32 +930,41 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
                                        -- See the AvailTC Invariant in Avail.hs
                             (n1:ns1) | n1 == name -> ns1
                                      | otherwise  -> ns
                                        -- See the AvailTC Invariant in Avail.hs
                             (n1:ns1) | n1 == name -> ns1
                                      | otherwise  -> ns
+               rdr_ns = map ieLWrappedName rdr_ns'
            case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of
              Nothing                      -> failLookupWith BadImport
              Just (childnames, childflds) ->
                case mb_parent of
                  -- non-associated ty/cls
                  Nothing
            case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of
              Nothing                      -> failLookupWith BadImport
              Just (childnames, childflds) ->
                case mb_parent of
                  -- non-associated ty/cls
                  Nothing
-                   -> return ([(IEThingWith (L l name) wc childnames childflds,
+                   -> return ([(IEThingWith (L l name') wc childnames'
+                                                           childflds,
                                AvailTC name (name:map unLoc childnames) (map unLoc childflds))],
                               [])
                                AvailTC name (name:map unLoc childnames) (map unLoc childflds))],
                               [])
+                   where name' = replaceWrappedName rdr_tc name
+                         childnames' = map to_ie_post_rn childnames
+                         -- childnames' = postrn_ies childnames
                  -- associated ty
                  Just parent
                  -- associated ty
                  Just parent
-                   -> return ([(IEThingWith (L l name) wc childnames childflds,
+                   -> return ([(IEThingWith (L l name') wc childnames'
+                                                           childflds,
                                 AvailTC name (map unLoc childnames) (map unLoc childflds)),
                                 AvailTC name (map unLoc childnames) (map unLoc childflds)),
-                               (IEThingWith (L l name) wc childnames childflds,
+                               (IEThingWith (L l name') wc childnames'
+                                                           childflds,
                                 AvailTC parent [name] [])],
                               [])
                                 AvailTC parent [name] [])],
                               [])
+                   where name' = replaceWrappedName rdr_tc name
+                         childnames' = map to_ie_post_rn childnames
 
         _other -> failLookupWith IllegalImport
         -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed
         -- all errors.
 
       where
 
         _other -> failLookupWith IllegalImport
         -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed
         -- all errors.
 
       where
-        mkIEThingAbs l (n, av, Nothing    ) = (IEThingAbs (L l n),
-                                               trimAvail av n)
-        mkIEThingAbs l (n, _,  Just parent) = (IEThingAbs (L l n),
-                                               AvailTC parent [n] [])
+        mkIEThingAbs tc l (n, av, Nothing    )
+          = (IEThingAbs (L l (replaceWrappedName tc n)), trimAvail av n)
+        mkIEThingAbs tc l (n, _,  Just parent)
+          = (IEThingAbs (L l (replaceWrappedName tc n)), AvailTC parent [n] [])
 
         handle_bad_import m = catchIELookup m $ \err -> case err of
           BadImport | want_hiding -> return ([], [BadImportW])
 
         handle_bad_import m = catchIELookup m $ \err -> case err of
           BadImport | want_hiding -> return ([], [BadImportW])
@@ -995,7 +1008,7 @@ gresFromIE decl_spec (L loc ie, avail)
   = gresFromAvail prov_fn avail
   where
     is_explicit = case ie of
   = gresFromAvail prov_fn avail
   where
     is_explicit = case ie of
-                    IEThingAll (L _ name) -> \n -> n == name
+                    IEThingAll (L _ name) -> \n -> n == ieWrappedName name
                     _                     -> \_ -> True
     prov_fn name
       = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })
                     _                     -> \_ -> True
     prov_fn name
       = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })
@@ -1251,15 +1264,19 @@ findImportUsage imports used_gres
               _other -> emptyNameSet -- No explicit import list => no unused-name list
 
         add_unused :: IE Name -> NameSet -> NameSet
               _other -> emptyNameSet -- No explicit import list => no unused-name list
 
         add_unused :: IE Name -> NameSet -> NameSet
-        add_unused (IEVar (L _ n))      acc = add_unused_name n acc
-        add_unused (IEThingAbs (L _ n)) acc = add_unused_name n acc
-        add_unused (IEThingAll (L _ n)) acc = add_unused_all  n acc
+        add_unused (IEVar (L _ n))      acc
+                                       = add_unused_name (ieWrappedName n) acc
+        add_unused (IEThingAbs (L _ n)) acc
+                                       = add_unused_name (ieWrappedName n) acc
+        add_unused (IEThingAll (L _ n)) acc
+                                       = add_unused_all  (ieWrappedName n) acc
         add_unused (IEThingWith (L _ p) wc ns fs) acc =
         add_unused (IEThingWith (L _ p) wc ns fs) acc =
-          add_wc_all (add_unused_with p xs acc)
-          where xs = map unLoc ns ++ map (flSelector . unLoc) fs
+          add_wc_all (add_unused_with (ieWrappedName p) xs acc)
+          where xs = map (ieWrappedName . unLoc) ns
+                          ++ map (flSelector . unLoc) fs
                 add_wc_all = case wc of
                             NoIEWildcard -> id
                 add_wc_all = case wc of
                             NoIEWildcard -> id
-                            IEWildcard _ -> add_unused_all p
+                            IEWildcard _ -> add_unused_all (ieWrappedName p)
         add_unused _ acc = acc
 
         add_unused_name n acc
         add_unused _ acc = acc
 
         add_unused_name n acc
@@ -1394,24 +1411,29 @@ printMinimalImports imports_w_usage
     -- we want to say "T(..)", but if we're importing only a subset we want
     -- to say "T(A,B,C)".  So we have to find out what the module exports.
     to_ie _ (Avail n)
     -- we want to say "T(..)", but if we're importing only a subset we want
     -- to say "T(A,B,C)".  So we have to find out what the module exports.
     to_ie _ (Avail n)
-       = [IEVar (noLoc n)]
+       = [IEVar (to_ie_post_rn $ noLoc n)]
     to_ie _ (AvailTC n [m] [])
     to_ie _ (AvailTC n [m] [])
-       | n==m = [IEThingAbs (noLoc n)]
+       | n==m = [IEThingAbs (to_ie_post_rn $ noLoc n)]
     to_ie iface (AvailTC n ns fs)
       = case [(xs,gs) |  AvailTC x xs gs <- mi_exports iface
                  , x == n
                  , x `elem` xs    -- Note [Partial export]
                  ] of
     to_ie iface (AvailTC n ns fs)
       = case [(xs,gs) |  AvailTC x xs gs <- mi_exports iface
                  , x == n
                  , x `elem` xs    -- Note [Partial export]
                  ] of
-           [xs] | all_used xs -> [IEThingAll (noLoc n)]
-                | otherwise   -> [IEThingWith (noLoc n) NoIEWildcard
-                                              (map noLoc (filter (/= n) ns))
-                                              (map noLoc fs)]
+           [xs] | all_used xs -> [IEThingAll (to_ie_post_rn $ noLoc n)]
+                | otherwise   ->
+                   [IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard
+                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))
+                                (map noLoc fs)]
                                           -- Note [Overloaded field import]
            _other | all_non_overloaded fs
                                           -- Note [Overloaded field import]
            _other | all_non_overloaded fs
-                              -> map (IEVar . noLoc) $ ns ++ map flSelector fs
-                  | otherwise -> [IEThingWith (noLoc n) NoIEWildcard
-                                              (map noLoc (filter (/= n) ns)) (map noLoc fs)]
+                              -> map (IEVar . to_ie_post_rn_var . noLoc) $ ns
+                                 ++ map flSelector fs
+                  | otherwise ->
+                      [IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard
+                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))
+                                (map noLoc fs)]
         where
         where
+
           fld_lbls = map flLabel fs
 
           all_used (avail_occs, avail_flds)
           fld_lbls = map flLabel fs
 
           all_used (avail_occs, avail_flds)
@@ -1420,6 +1442,18 @@ printMinimalImports imports_w_usage
 
           all_non_overloaded = all (not . flIsOverloaded)
 
 
           all_non_overloaded = all (not . flIsOverloaded)
 
+to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name
+to_ie_post_rn_var (L l n)
+  | isDataOcc $ occName n = L l (IEPattern (L l n))
+  | otherwise             = L l (IEName    (L l n))
+
+
+to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name
+to_ie_post_rn (L l n)
+  | isTcOcc occ && isSymOcc occ = L l (IEType (L l n))
+  | otherwise                   = L l (IEName (L l n))
+  where occ = occName n
+
 {-
 Note [Partial export]
 ~~~~~~~~~~~~~~~~~~~~~
 {-
 Note [Partial export]
 ~~~~~~~~~~~~~~~~~~~~~
@@ -1528,7 +1562,7 @@ dodgyImportWarn item = dodgyMsg (text "import") item
 dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc
 dodgyMsg kind tc
   = sep [ text "The" <+> kind <+> ptext (sLit "item")
 dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc
 dodgyMsg kind tc
   = sep [ text "The" <+> kind <+> ptext (sLit "item")
-                             <+> quotes (ppr (IEThingAll (noLoc tc)))
+                     <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc))))
                 <+> text "suggests that",
           quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",
           text "but it has none" ]
                 <+> text "suggests that",
           quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",
           text "but it has none" ]
index 7e47901..99ab747 100644 (file)
@@ -133,7 +133,8 @@ tcRnExports explicit_mod exports
                  | explicit_mod = exports
                  | ghcLink dflags == LinkInMemory = Nothing
                  | otherwise
                  | explicit_mod = exports
                  | ghcLink dflags == LinkInMemory = Nothing
                  | otherwise
-                          = Just (noLoc [noLoc (IEVar (noLoc main_RDR_Unqual))])
+                          = Just (noLoc [noLoc
+                              (IEVar (noLoc (IEName $ noLoc main_RDR_Unqual)))])
                         -- ToDo: the 'noLoc' here is unhelpful if 'main'
                         --       turns out to be out of scope
 
                         -- ToDo: the 'noLoc' here is unhelpful if 'main'
                         --       turns out to be out of scope
 
@@ -267,18 +268,19 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
     -------------
     lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo)
     lookup_ie (IEVar (L l rdr))
     -------------
     lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo)
     lookup_ie (IEVar (L l rdr))
-        = do (name, avail) <- lookupGreAvailRn rdr
-             return (IEVar (L l name), avail)
+        = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
+             return (IEVar (L l (replaceWrappedName rdr name)), avail)
 
     lookup_ie (IEThingAbs (L l rdr))
 
     lookup_ie (IEThingAbs (L l rdr))
-        = do (name, avail) <- lookupGreAvailRn rdr
-             return (IEThingAbs (L l name), avail)
+        = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
+             return (IEThingAbs (L l (replaceWrappedName rdr name)), avail)
 
 
-    lookup_ie ie@(IEThingAll n)
+    lookup_ie ie@(IEThingAll n')
         = do
         = do
-            (n, avail, flds) <- lookup_ie_all ie n
+            (n, avail, flds) <- lookup_ie_all ie n'
             let name = unLoc n
             let name = unLoc n
-            return (IEThingAll n, AvailTC name (name:avail) flds)
+            return (IEThingAll (replaceLWrappedName n' (unLoc n))
+                   , AvailTC name (name:avail) flds)
 
 
     lookup_ie ie@(IEThingWith l wc sub_rdrs _)
 
 
     lookup_ie ie@(IEThingWith l wc sub_rdrs _)
@@ -290,7 +292,9 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
                 NoIEWildcard -> return (lname, [], [])
                 IEWildcard _ -> lookup_ie_all ie l
             let name = unLoc lname
                 NoIEWildcard -> return (lname, [], [])
                 IEWildcard _ -> lookup_ie_all ie l
             let name = unLoc lname
-            return (IEThingWith lname wc subs (map noLoc (flds ++ all_flds)),
+                subs' = map (replaceLWrappedName l . unLoc) subs
+            return (IEThingWith (replaceLWrappedName l name) wc subs'
+                                (map noLoc (flds ++ all_flds)),
                     AvailTC name (name : avails ++ all_avail)
                                  (flds ++ all_flds))
 
                     AvailTC name (name : avails ++ all_avail)
                                  (flds ++ all_flds))
 
@@ -299,23 +303,24 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
 
     lookup_ie _ = panic "lookup_ie"    -- Other cases covered earlier
 
 
     lookup_ie _ = panic "lookup_ie"    -- Other cases covered earlier
 
-    lookup_ie_with :: Located RdrName -> [Located RdrName]
+    lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName]
                    -> RnM (Located Name, [Located Name], [Name], [FieldLabel])
     lookup_ie_with (L l rdr) sub_rdrs
                    -> RnM (Located Name, [Located Name], [Name], [FieldLabel])
     lookup_ie_with (L l rdr) sub_rdrs
-        = do name <- lookupGlobalOccRn rdr
-             (non_flds, flds) <- lookupChildrenExport name sub_rdrs
+        = do name <- lookupGlobalOccRn $ ieWrappedName rdr
+             (non_flds, flds) <- lookupChildrenExport name
+                                                  (map ieLWrappedName sub_rdrs)
              if isUnboundName name
                 then return (L l name, [], [name], [])
                 else return (L l name, non_flds
                             , map unLoc non_flds
                             , map unLoc flds)
              if isUnboundName name
                 then return (L l name, [], [name], [])
                 else return (L l name, non_flds
                             , map unLoc non_flds
                             , map unLoc flds)
-    lookup_ie_all :: IE RdrName -> Located RdrName
+    lookup_ie_all :: IE RdrName -> LIEWrappedName RdrName
                   -> RnM (Located Name, [Name], [FieldLabel])
     lookup_ie_all ie (L l rdr) =
                   -> RnM (Located Name, [Name], [FieldLabel])
     lookup_ie_all ie (L l rdr) =
-          do name <- lookupGlobalOccRn rdr
+          do name <- lookupGlobalOccRn $ ieWrappedName rdr
              let gres = findChildren kids_env name
                  (non_flds, flds) = classifyGREs gres
              let gres = findChildren kids_env name
                  (non_flds, flds) = classifyGREs gres
-             addUsedKids rdr gres
+             addUsedKids (ieWrappedName rdr) gres
              warnDodgyExports <- woptM Opt_WarnDodgyExports
              when (null gres) $
                   if isTyConName name
              warnDodgyExports <- woptM Opt_WarnDodgyExports
              when (null gres) $
                   if isTyConName name
@@ -765,8 +770,9 @@ dupExport_ok n ie1 ie2
   = not (  single ie1 || single ie2
         || (explicit_in ie1 && explicit_in ie2) )
   where
   = not (  single ie1 || single ie2
         || (explicit_in ie1 && explicit_in ie2) )
   where
-    explicit_in (IEModuleContents _) = False                -- module M
-    explicit_in (IEThingAll r) = nameOccName n == rdrNameOcc (unLoc r)  -- T(..)
+    explicit_in (IEModuleContents _) = False                   -- module M
+    explicit_in (IEThingAll r)
+      = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r)  -- T(..)
     explicit_in _              = True
 
     single IEVar {}      = True
     explicit_in _              = True
 
     single IEVar {}      = True
index 3f2cf5c..a6b04dd 100644 (file)
@@ -44,6 +44,7 @@ extra_src_files = {
   'T10396': ['Test10396.hs'],
   'T10399': ['Test10399.hs'],
   'T12417': ['Test12417.hs'],
   'T10396': ['Test10396.hs'],
   'T10399': ['Test10399.hs'],
   'T12417': ['Test12417.hs'],
+  'T13163': ['Test13163.hs'],
   'T10420': ['rule-defining-plugin/'],
   'T10458': ['A.c'],
   'T10529a': ['hpc_sample_non_existing_module.tix'],
   'T10420': ['rule-defining-plugin/'],
   'T10458': ['A.c'],
   'T10529a': ['hpc_sample_non_existing_module.tix'],
index 6a6adda..2da5fc0 100644 (file)
@@ -137,3 +137,7 @@ load-main:
 .PHONY: T12417
 T12417:
        $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test12417.hs
 .PHONY: T12417
 T12417:
        $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test12417.hs
+
+.PHONY: T13163
+T13163:
+       $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test13163.hs
diff --git a/testsuite/tests/ghc-api/annotations/T13163.stdout b/testsuite/tests/ghc-api/annotations/T13163.stdout
new file mode 100644 (file)
index 0000000..f216acd
--- /dev/null
@@ -0,0 +1,78 @@
+---Problems (should be empty list)---
+[]
+---Annotations-----------------------
+-- SrcSpan the annotation is attached to, AnnKeywordId,
+--    list of locations the keyword item appears in
+[
+((Test13163.hs:1:1,AnnModule), [Test13163.hs:4:1-6]),
+((Test13163.hs:1:1,AnnWhere), [Test13163.hs:8:5-9]),
+((Test13163.hs:(5,3)-(8,3),AnnCloseP), [Test13163.hs:8:3]),
+((Test13163.hs:(5,3)-(8,3),AnnOpenP), [Test13163.hs:5:3]),
+((Test13163.hs:5:5-14,AnnCloseP), [Test13163.hs:5:14]),
+((Test13163.hs:5:5-14,AnnComma), [Test13163.hs:6:3]),
+((Test13163.hs:5:5-14,AnnDotdot), [Test13163.hs:5:12-13]),
+((Test13163.hs:5:5-14,AnnOpenP), [Test13163.hs:5:11]),
+((Test13163.hs:6:5-12,AnnType), [Test13163.hs:6:5-8]),
+((Test13163.hs:6:5-16,AnnCloseP), [Test13163.hs:6:16]),
+((Test13163.hs:6:5-16,AnnComma), [Test13163.hs:7:3]),
+((Test13163.hs:6:5-16,AnnDotdot), [Test13163.hs:6:14-15]),
+((Test13163.hs:6:5-16,AnnOpenP), [Test13163.hs:6:13]),
+((Test13163.hs:6:10-12,AnnCloseP), [Test13163.hs:6:12]),
+((Test13163.hs:6:10-12,AnnOpenP), [Test13163.hs:6:10]),
+((Test13163.hs:6:10-12,AnnVal), [Test13163.hs:6:11]),
+((Test13163.hs:7:5,AnnComma), [Test13163.hs:7:6]),
+((Test13163.hs:7:8-15,AnnComma), [Test13163.hs:7:16]),
+((Test13163.hs:7:8-15,AnnType), [Test13163.hs:7:8-11]),
+((Test13163.hs:7:13-15,AnnCloseP), [Test13163.hs:7:15]),
+((Test13163.hs:7:13-15,AnnOpenP), [Test13163.hs:7:13]),
+((Test13163.hs:7:13-15,AnnVal), [Test13163.hs:7:14]),
+((Test13163.hs:7:18-31,AnnPattern), [Test13163.hs:7:18-24]),
+((Test13163.hs:10:1-78,AnnImport), [Test13163.hs:10:1-6]),
+((Test13163.hs:10:1-78,AnnSemi), [Test13163.hs:11:1]),
+((Test13163.hs:10:31-78,AnnCloseP), [Test13163.hs:10:78]),
+((Test13163.hs:10:31-78,AnnOpenP), [Test13163.hs:10:31]),
+((Test13163.hs:10:32-41,AnnComma), [Test13163.hs:10:42]),
+((Test13163.hs:10:32-41,AnnType), [Test13163.hs:10:32-35]),
+((Test13163.hs:10:37-41,AnnCloseP), [Test13163.hs:10:41]),
+((Test13163.hs:10:37-41,AnnOpenP), [Test13163.hs:10:37]),
+((Test13163.hs:10:37-41,AnnVal), [Test13163.hs:10:38-40]),
+((Test13163.hs:10:44-53,AnnComma), [Test13163.hs:10:54]),
+((Test13163.hs:10:44-53,AnnType), [Test13163.hs:10:44-47]),
+((Test13163.hs:10:49-53,AnnCloseP), [Test13163.hs:10:53]),
+((Test13163.hs:10:49-53,AnnOpenP), [Test13163.hs:10:49]),
+((Test13163.hs:10:49-53,AnnVal), [Test13163.hs:10:50-52]),
+((Test13163.hs:10:56-65,AnnComma), [Test13163.hs:10:66]),
+((Test13163.hs:10:56-65,AnnType), [Test13163.hs:10:56-59]),
+((Test13163.hs:10:61-65,AnnCloseP), [Test13163.hs:10:65]),
+((Test13163.hs:10:61-65,AnnOpenP), [Test13163.hs:10:61]),
+((Test13163.hs:10:61-65,AnnVal), [Test13163.hs:10:62-64]),
+((Test13163.hs:10:68-77,AnnType), [Test13163.hs:10:68-71]),
+((Test13163.hs:10:73-77,AnnCloseP), [Test13163.hs:10:77]),
+((Test13163.hs:10:73-77,AnnOpenP), [Test13163.hs:10:73]),
+((Test13163.hs:10:73-77,AnnVal), [Test13163.hs:10:74-76]),
+((Test13163.hs:11:1-61,AnnImport), [Test13163.hs:11:1-6]),
+((Test13163.hs:11:1-61,AnnSemi), [Test13163.hs:12:1]),
+((Test13163.hs:11:24-61,AnnCloseP), [Test13163.hs:11:61]),
+((Test13163.hs:11:24-61,AnnOpenP), [Test13163.hs:11:24]),
+((Test13163.hs:11:25-31,AnnComma), [Test13163.hs:11:32]),
+((Test13163.hs:11:34-44,AnnComma), [Test13163.hs:11:45]),
+((Test13163.hs:11:47-56,AnnType), [Test13163.hs:11:47-50]),
+((Test13163.hs:11:47-60,AnnCloseP), [Test13163.hs:11:60]),
+((Test13163.hs:11:47-60,AnnDotdot), [Test13163.hs:11:58-59]),
+((Test13163.hs:11:47-60,AnnOpenP), [Test13163.hs:11:57]),
+((Test13163.hs:11:52-56,AnnCloseP), [Test13163.hs:11:56]),
+((Test13163.hs:11:52-56,AnnOpenP), [Test13163.hs:11:52]),
+((Test13163.hs:11:52-56,AnnVal), [Test13163.hs:11:53-55]),
+((Test13163.hs:12:1-19,AnnImport), [Test13163.hs:12:1-6]),
+((Test13163.hs:12:1-19,AnnSemi), [Test13163.hs:14:1]),
+((Test13163.hs:14:1-22,AnnEqual), [Test13163.hs:14:18]),
+((Test13163.hs:14:1-22,AnnPattern), [Test13163.hs:14:1-7]),
+((Test13163.hs:14:1-22,AnnSemi), [Test13163.hs:16:1]),
+((Test13163.hs:14:20-22,AnnCloseS), [Test13163.hs:14:22]),
+((Test13163.hs:14:20-22,AnnOpenS), [Test13163.hs:14:20]),
+((Test13163.hs:16:1-13,AnnEqual), [Test13163.hs:16:3]),
+((Test13163.hs:16:1-13,AnnFunId), [Test13163.hs:16:1]),
+((Test13163.hs:16:1-13,AnnSemi), [Test13163.hs:17:1]),
+((<no location info>,AnnEofPos), [Test13163.hs:17:1])
+]
+
diff --git a/testsuite/tests/ghc-api/annotations/Test13163.hs b/testsuite/tests/ghc-api/annotations/Test13163.hs
new file mode 100644 (file)
index 0000000..439d825
--- /dev/null
@@ -0,0 +1,16 @@
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+module T13163
+  ( Record(..)
+  , type (?)(..)
+  , f, type (+), pattern Single
+  ) where
+
+import Data.Promotion.Prelude (type (:+$), type (:*$), type (:^$), type (:-$))
+import Options.Generic (Generic, ParseRecord, type (<?>)(..))
+import GHC.TypeLits
+
+pattern Single x = [x]
+
+f = undefined
index fbe8c3e..1028626 100644 (file)
@@ -27,3 +27,4 @@ test('T11332',      ignore_stderr, run_command, ['$MAKE -s --no-print-directory
 test('T11430',      ignore_stderr, run_command, ['$MAKE -s --no-print-directory T11430'])
 test('load-main',   ignore_stderr, run_command, ['$MAKE -s --no-print-directory load-main'])
 test('T12417',      ignore_stderr, run_command, ['$MAKE -s --no-print-directory T12417'])
 test('T11430',      ignore_stderr, run_command, ['$MAKE -s --no-print-directory T11430'])
 test('load-main',   ignore_stderr, run_command, ['$MAKE -s --no-print-directory load-main'])
 test('T12417',      ignore_stderr, run_command, ['$MAKE -s --no-print-directory T12417'])
+test('T13163',      ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13163'])
index d31442a..f9b502e 100644 (file)
@@ -19,5 +19,8 @@ In a test Makefile
 
 See examples in (REPO_HOME)/testsuite/tests/printer/Makefile
 
 
 See examples in (REPO_HOME)/testsuite/tests/printer/Makefile
 
-If passed the --dump flag check-ppr will produce .new and .old files containing
-the ASTs before and after round-tripping to aid debugging.
+The utility generates the following files for ToBeTested.hs
+
+  - ToBeTested.ppr.hs      : the ppr result
+  - ToBeTested.hs.ast      : the AST of the original source
+  - ToBeTested.hs.ast.new  : the AST of the re-parsed ppr source
index 4349092..7f1987b 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 4349092ef61ca7da7c7cbcd9aa7dcbb97fe59bdf
+Subproject commit 7f1987b35eb7bb15ca2fd93321440af519dd8cd5