summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/hsSyn/HsImpExp.hs108
-rw-r--r--compiler/parser/Parser.y25
-rw-r--r--compiler/parser/RdrHsSyn.hs55
-rw-r--r--compiler/rename/RnNames.hs108
-rw-r--r--compiler/typecheck/TcRnExports.hs40
-rw-r--r--testsuite/driver/extra_files.py1
-rw-r--r--testsuite/tests/ghc-api/annotations/Makefile4
-rw-r--r--testsuite/tests/ghc-api/annotations/T13163.stdout78
-rw-r--r--testsuite/tests/ghc-api/annotations/Test13163.hs16
-rw-r--r--testsuite/tests/ghc-api/annotations/all.T1
-rw-r--r--utils/check-ppr/README7
m---------utils/haddock0
12 files changed, 324 insertions, 119 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
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 2b70fb7999..e0e060e053 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -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] }
- | '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) }
@@ -803,13 +803,13 @@ export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
(as ++ [mop $1,mcp $3] ++ fst $2, ie) }
-qcnames :: { ([AddAnn], [Located (Maybe RdrName)]) }
+qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) }
: {- 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
- 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] >>
@@ -822,14 +822,15 @@ qcnames1 :: { ([AddAnn], [Located (Maybe RdrName)]) } -- A reversed list
-- 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
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 64a60c4841..2c63c428b6 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -56,6 +56,7 @@ module RdrHsSyn (
-- Help with processing exports
ImpExpSubSpec(..),
+ ImpExpQcSpec(..),
mkModuleImpExp,
mkTypeImpExp,
mkImpExpSubSpec,
@@ -1436,30 +1437,37 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
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
- | 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
- (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
+ name = ieNameVal specname
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)
- 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)
@@ -1492,15 +1510,18 @@ checkImportSpec ie@(L _ specs) =
$+$ 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 [L l Nothing] =
- return ([\s -> addAnnotation s AnnDotdot l], ImpExpAll)
+mkImpExpSubSpec [L _ ImpExpQcWildcard] =
+ return ([], ImpExpAll)
mkImpExpSubSpec xs =
- if (any (isNothing . unLoc) xs)
+ if (any (isImpExpQcWildcard . unLoc) 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
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 9d2de7439e..2cde294678 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -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
- (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
- (name, avail, mb_parent) <- lookup_name tc
+ (name, avail, mb_parent) <- lookup_name $ ieWrappedName tc
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
- -> [DodgyImport tc]
+ -> [DodgyImport $ ieWrappedName tc]
| 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
-> []
- 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)]
@@ -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
- 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
- -> 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
- names -> return ([mkIEThingAbs l name | name <- names], [])
+ names -> return ([mkIEThingAbs tc' l name | name <- names], [])
| 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
- (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,
@@ -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
+ 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
- -> 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))],
[])
+ where name' = replaceWrappedName rdr_tc name
+ childnames' = map to_ie_post_rn childnames
+ -- childnames' = postrn_ies childnames
-- 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)),
- (IEThingWith (L l name) wc childnames childflds,
+ (IEThingWith (L l name') wc childnames'
+ childflds,
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
- 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])
@@ -995,7 +1008,7 @@ gresFromIE decl_spec (L loc ie, avail)
= 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 })
@@ -1251,15 +1264,19 @@ findImportUsage imports used_gres
_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_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
- IEWildcard _ -> add_unused_all p
+ IEWildcard _ -> add_unused_all (ieWrappedName p)
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)
- = [IEVar (noLoc n)]
+ = [IEVar (to_ie_post_rn $ noLoc n)]
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
- [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
- -> 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
+
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)
+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]
~~~~~~~~~~~~~~~~~~~~~
@@ -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")
- <+> 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" ]
diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs
index 7e47901e42..99ab7474ad 100644
--- a/compiler/typecheck/TcRnExports.hs
+++ b/compiler/typecheck/TcRnExports.hs
@@ -133,7 +133,8 @@ tcRnExports explicit_mod exports
| 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
@@ -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))
- = 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))
- = 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
- (n, avail, flds) <- lookup_ie_all ie n
+ (n, avail, flds) <- lookup_ie_all ie 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 _)
@@ -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
- 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))
@@ -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_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
- = 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)
- 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) =
- do name <- lookupGlobalOccRn rdr
+ do name <- lookupGlobalOccRn $ ieWrappedName rdr
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
@@ -765,8 +770,9 @@ dupExport_ok n ie1 ie2
= 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
diff --git a/testsuite/driver/extra_files.py b/testsuite/driver/extra_files.py
index 3f2cf5cc4b..a6b04dd04d 100644
--- a/testsuite/driver/extra_files.py
+++ b/testsuite/driver/extra_files.py
@@ -44,6 +44,7 @@ extra_src_files = {
'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'],
diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile
index 6a6addae70..2da5fc00a9 100644
--- a/testsuite/tests/ghc-api/annotations/Makefile
+++ b/testsuite/tests/ghc-api/annotations/Makefile
@@ -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: 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
index 0000000000..f216acdf98
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/T13163.stdout
@@ -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
index 0000000000..439d825386
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/Test13163.hs
@@ -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
diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T
index fbe8c3e35f..1028626575 100644
--- a/testsuite/tests/ghc-api/annotations/all.T
+++ b/testsuite/tests/ghc-api/annotations/all.T
@@ -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('T13163', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13163'])
diff --git a/utils/check-ppr/README b/utils/check-ppr/README
index d31442a9e9..f9b502e4a7 100644
--- a/utils/check-ppr/README
+++ b/utils/check-ppr/README
@@ -19,5 +19,8 @@ In a test 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
diff --git a/utils/haddock b/utils/haddock
-Subproject 4349092ef61ca7da7c7cbcd9aa7dcbb97fe59bd
+Subproject 7f1987b35eb7bb15ca2fd93321440af519dd8cd
View Lorry Controller Status