[commit: ghc] wip/std-hdr-llf: Dot/bang operators in export lists (Trac #16339) (2f4af71)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/std-hdr-llf
Link       : http://ghc.haskell.org/trac/ghc/changeset/2f4af71e73ac3b59f4faba5bf1b25774b1008898/ghc

>---------------------------------------------------------------

commit 2f4af71e73ac3b59f4faba5bf1b25774b1008898
Author: Vladislav Zavialov <vlad.z.4096 at gmail.com>
Date:   Tue Feb 19 18:27:09 2019 +0300

    Dot/bang operators in export lists (Trac #16339)
    
    The dot type operator was handled in the 'tyvarop' parser production, and the
    bang type operator in 'tyapp'. However, export lists and role annotations use
    'oqtycon', so these type operators could not be exported or assigned roles.
    
    The fix is to handle them in a lower level production, 'tyconsym'.


>---------------------------------------------------------------

2f4af71e73ac3b59f4faba5bf1b25774b1008898
 compiler/parser/Parser.y                        | 10 +++++-----
 compiler/parser/RdrHsSyn.hs                     |  5 +++++
 testsuite/tests/parser/should_compile/T16339.hs | 18 ++++++++++++++++++
 testsuite/tests/parser/should_compile/all.T     |  1 +
 4 files changed, 29 insertions(+), 5 deletions(-)

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 78f1013..544d9d7 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1989,14 +1989,15 @@ tyapps :: { [Located TyEl] } -- NB: This list is reversed
 tyapp :: { Located TyEl }
         : atype                         { sL1 $1 $ TyElOpd (unLoc $1) }
         | TYPEAPP atype                 { sLL $1 $> $ (TyElKindApp (comb2 $1 $2) $2) }
-        | qtyconop                      { sL1 $1 $ TyElOpr (unLoc $1) }
+        | qtyconop                      { sL1 $1 $ if isBangRdr (unLoc $1)
+                                                   then TyElBang
+                                                   else TyElOpr (unLoc $1) }
         | tyvarop                       { sL1 $1 $ TyElOpr (unLoc $1) }
         | SIMPLEQUOTE qconop            {% ams (sLL $1 $> $ TyElOpr (unLoc $2))
                                                [mj AnnSimpleQuote $1,mj AnnVal $2] }
         | SIMPLEQUOTE varop             {% ams (sLL $1 $> $ TyElOpr (unLoc $2))
                                                [mj AnnSimpleQuote $1,mj AnnVal $2] }
         | '~'                           { sL1 $1 TyElTilde }
-        | '!'                           { sL1 $1 TyElBang }
         | unpackedness                  { sL1 $1 $ TyElUnpackedness (unLoc $1) }
 
 atype :: { LHsType GhcPs }
@@ -3310,13 +3311,13 @@ qtyconsym :: { Located RdrName }
         | QVARSYM            { sL1 $1 $! mkQual tcClsName (getQVARSYM $1) }
         | tyconsym           { $1 }
 
--- Does not include "!", because that is used for strictness marks
---               or ".", because that separates the quantified type vars from the rest
 tyconsym :: { Located RdrName }
         : CONSYM                { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) }
         | VARSYM                { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) }
         | ':'                   { sL1 $1 $! consDataCon_RDR }
         | '-'                   { sL1 $1 $! mkUnqual tcClsName (fsLit "-") }
+        | '!'                   { sL1 $1 $! mkUnqual tcClsName (fsLit "!") }
+        | '.'                   { sL1 $1 $! mkUnqual tcClsName (fsLit ".") }
 
 
 -----------------------------------------------------------------------------
@@ -3371,7 +3372,6 @@ tyvarop :: { Located RdrName }
 tyvarop : '`' tyvarid '`'       {% ams (sLL $1 $> (unLoc $2))
                                        [mj AnnBackquote $1,mj AnnVal $2
                                        ,mj AnnBackquote $3] }
-        | '.'                   { sL1 $1 $ mkUnqual tcClsName (fsLit ".") }
 
 tyvarid :: { Located RdrName }
         : VARID            { sL1 $1 $! mkUnqual tvName (getVARID $1) }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 606e2e7..c65b814 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -49,6 +49,7 @@ module   RdrHsSyn (
         checkContext,         -- HsType -> P HsContext
         checkPattern,         -- HsExp -> P HsPat
         bang_RDR,
+        isBangRdr,
         checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
         checkMonadComp,       -- P (HsStmtContext RdrName)
         checkCommand,         -- LHsExpr RdrName -> P (LHsCmd RdrName)
@@ -1162,6 +1163,10 @@ plus_RDR = mkUnqual varName (fsLit "+") -- Hack
 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
 pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
 
+isBangRdr :: RdrName -> Bool
+isBangRdr (Unqual occ) = occNameFS occ == fsLit "!"
+isBangRdr _ = False
+
 checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs)
               -> P (LHsRecField GhcPs (LPat GhcPs))
 checkPatField msg (dL->L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
diff --git a/testsuite/tests/parser/should_compile/T16339.hs b/testsuite/tests/parser/should_compile/T16339.hs
new file mode 100644
index 0000000..9bb8349
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T16339.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE ExplicitNamespaces, TypeOperators, RoleAnnotations #-}
+{-# OPTIONS -Wno-duplicate-exports #-}
+
+module T16339
+  (
+    type (!),
+    type (!)(Bang),
+    type (!)(..),
+    type (.),
+    type (.)(Dot),
+    type (.)(..),
+  ) where
+
+data a ! b = Bang
+data f . g = Dot
+
+type role (!) phantom phantom
+type role (.) phantom phantom
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index b3f693d..1c5c225 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -141,3 +141,4 @@ test('T15279', normalise_errmsg_fun(only_MG_loc), compile, [''])
 test('T15457', normal, compile, [''])
 test('T15675', normal, compile, [''])
 test('T15781', normal, compile, [''])
+test('T16339', normal, compile, [''])