Fix Trac #12051

A minor parser issue, allowing a mal-formed data constructor
through.

5 files changed, 57 insertions, 37 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 4c272a13f0..4502dcae26 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1642,7 +1642,7 @@ btype :: { LHsType RdrName }
 -- Used for parsing Haskell98-style data constructors,
 -- in order to forbid the blasphemous
 -- > data Foo = Int :+ Char :* Bool
--- See also Note [Parsing data constructors is hard].
+-- See also Note [Parsing data constructors is hard] in RdrHsSyn
 btype_no_ops :: { LHsType RdrName }
         : btype_no_ops atype            { sLL $1 $> $ HsAppTy $1 $2 }
         | atype                         { $1 }
@@ -1898,23 +1898,12 @@ forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr RdrName]) }
         | {- empty -}                 { noLoc ([], Nothing) }
 
 constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
-    -- see Note [Parsing data constructors is hard]
+    -- See Note [Parsing data constructors is hard] in RdrHsSyn
         : btype_no_ops                         {% do { c <- splitCon $1
                                                      ; return $ sLL $1 $> c } }
         | btype_no_ops conop btype_no_ops      {% do { ty <- splitTilde $1
                                                      ; return $ sLL $1 $> ($2, InfixCon ty $3) } }
 
-{- Note [Parsing data constructors is hard]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We parse the constructor declaration
-     C t1 t2
-as a btype_no_ops (treating C as a type constructor) and then convert C to be
-a data constructor.  Reason: it might continue like this:
-     C t1 t2 :% D Int
-in which case C really would be a type constructor.  We can't resolve this
-ambiguity till we come across the constructor oprerator :% (or not, more usually)
--}
-
 fielddecls :: { [LConDeclField RdrName] }
         : {- empty -}     { [] }
         | fielddecls1     { $1 }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index d650b0145e..43ff23092a 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -74,6 +74,7 @@ import Name
 import BasicTypes
 import TcEvidence       ( idHsWrapper )
 import Lexer
+import Lexeme           ( isLexCon )
 import Type             ( TyThing(..) )
 import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,
                           nilDataConName, nilDataConKey,
@@ -425,16 +426,34 @@ has_args ((L _ (Match _ args _ _)) : _) = not (null args)
 
   ********************************************************************* -}
 
------------------------------------------------------------------------------
--- splitCon
-
--- When parsing data declarations, we sometimes inadvertently parse
--- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
--- This function splits up the type application, adds any pending
--- arguments, and converts the type constructor back into a data constructor.
+{- Note [Parsing data constructors is hard]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We parse the RHS of the constructor declaration
+     data T = C t1 t2
+as a btype_no_ops (treating C as a type constructor) and then convert C to be
+a data constructor.  Reason: it might continue like this:
+     data T = C t1 t2 :% D Int
+in which case C really /would/ be a type constructor.  We can't resolve this
+ambiguity till we come across the constructor oprerator :% (or not, more usually)
+
+So the plan is:
+
+* Parse the data constructor declration as a type (actually btype_no_ops)
+
+* Use 'splitCon' to rejig it into the data constructor and the args
+
+* In doing so, we use 'tyConToDataCon' to convert the RdrName for
+  the data con, which has been parsed as a tycon, back to a datacon.
+  This is more than just adjusting the name space; for operators we
+  need to check that it begins with a colon.  E.g.
+     data T = (+++)
+  will parse ok (since tycons can be operators), but we should reject
+  it (Trac #12051).
+-}
 
 splitCon :: LHsType RdrName
       -> P (Located RdrName, HsConDeclDetails RdrName)
+-- See Note [Parsing data constructors is hard]
 -- This gets given a "type" that should look like
 --      C Int Bool
 -- or   C { x::Int, y::Bool }
@@ -453,11 +472,23 @@ splitCon ty
    mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
    mk_rest ts                   = PrefixCon ts
 
-recordPatSynErr :: SrcSpan -> LPat RdrName -> P a
-recordPatSynErr loc pat =
-    parseErrorSDoc loc $
-    text "record syntax not supported for pattern synonym declarations:" $$
-    ppr pat
+tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
+-- See Note [Parsing data constructors is hard]
+-- Data constructor RHSs are parsed as types
+tyConToDataCon loc tc
+  | isTcOcc occ
+  , isLexCon (occNameFS occ)
+  = return (L loc (setRdrNameSpace tc srcDataName))
+
+  | otherwise
+  = parseErrorSDoc loc (msg $$ extra)
+  where
+    occ = rdrNameOcc tc
+
+    msg = text "Not a data constructor:" <+> quotes (ppr tc)
+    extra | tc == forall_tv_RDR
+          = text "Perhaps you intended to use ExistentialQuantification"
+          | otherwise = empty
 
 mkPatSynMatchGroup :: Located RdrName
                    -> Located (OrdList (LHsDecl RdrName))
@@ -493,6 +524,12 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
       text "pattern synonym 'where' clause cannot be empty" $$
       text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)
 
+recordPatSynErr :: SrcSpan -> LPat RdrName -> P a
+recordPatSynErr loc pat =
+    parseErrorSDoc loc $
+    text "record syntax not supported for pattern synonym declarations:" $$
+    ppr pat
+
 mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]
                 -> LHsContext RdrName -> HsConDeclDetails RdrName
                 -> ConDecl RdrName
@@ -513,18 +550,6 @@ mkGadtDecl names ty = ConDeclGADT { con_names = names
                                   , con_type  = ty
                                   , con_doc   = Nothing }
 
-tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
-tyConToDataCon loc tc
-  | isTcOcc (rdrNameOcc tc)
-  = return (L loc (setRdrNameSpace tc srcDataName))
-  | otherwise
-  = parseErrorSDoc loc (msg $$ extra)
-  where
-    msg = text "Not a data constructor:" <+> quotes (ppr tc)
-    extra | tc == forall_tv_RDR
-          = text "Perhaps you intended to use ExistentialQuantification"
-          | otherwise = empty
-
 setRdrNameSpace :: RdrName -> NameSpace -> RdrName
 -- ^ This rather gruesome function is used mainly by the parser.
 -- When parsing:
diff --git a/testsuite/tests/parser/should_fail/T12051.hs b/testsuite/tests/parser/should_fail/T12051.hs
new file mode 100644
index 0000000000..3744f77061
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T12051.hs
@@ -0,0 +1,3 @@
+module T12051 where
+
+data T = (+++) Int
diff --git a/testsuite/tests/parser/should_fail/T12051.stderr b/testsuite/tests/parser/should_fail/T12051.stderr
new file mode 100644
index 0000000000..ae65eaea6e
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T12051.stderr
@@ -0,0 +1,2 @@
+
+T12051.hs:3:10: error: Not a data constructor: ‘+++’
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index e6c6f41db7..ca23d3b5b6 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -93,3 +93,4 @@ test('T10196Fail1', normal, compile_fail, [''])
 test('T10196Fail2', normal, compile_fail, [''])
 test('T10498a', normal, compile_fail, [''])
 test('T10498b', normal, compile_fail, [''])
+test('T12051', normal, compile_fail, [''])