Support constructor Haddocks in more places

This adds support for adding Haddocks on individual non-record fields
of regular (and GADT) constructors. The following now parses just fine
with `-haddock` enabled:

data Foo
  = Baz             -- ^ doc on the `Baz` constructor
      Int           -- ^ doc on the `Int` field of `Baz`
      String        -- ^ doc on the `String` field of `Baz`

  | Int             -- ^ doc on the `Int` field of the `:*` constructor
      :*            -- ^ doc on the `:*` constructor
    String          -- ^ doc on the `String` field of the `:*`
constructor

  | Boa             -- ^ doc on the `Boa` record constructor
      { y :: () }

The change is backwards compatible: if there is only one doc and it
occurs
on the last field, it is lifted to apply to the whole constructor (as
before).

Reviewers: bgamari, alanz

Subscribers: rwbarton, thomie, mpickering, carter

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

2 files changed, 101 insertions, 31 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index d40b62b0f7..a3bc996c20 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -48,7 +48,7 @@ import PackageConfig
 import OrdList
 import BooleanFormula   ( BooleanFormula(..), LBooleanFormula(..), mkTrue )
 import FastString
-import Maybes           ( orElse )
+import Maybes           ( isJust, orElse )
 import Outputable
 
 -- compiler/basicTypes
@@ -1807,9 +1807,10 @@ context_no_ops :: { LHsContext GhcPs }
 ~~~~~~~~~~~~~~~~~~~~~
 The type production for
 
-    btype `->` btype
+    btype `->`         ctypedoc
+    btype docprev `->` ctypedoc
 
-adds the AnnRarrow annotation twice, in different places.
+add the AnnRarrow annotation twice, in different places.
 
 This is because if the type is processed as usual, it belongs on the annotations
 for the type as a whole.
@@ -1821,17 +1822,18 @@ is connected to the first type too.
 
 type :: { LHsType GhcPs }
         : btype                        { $1 }
-        | btype '->' ctype             {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]
-                                       >> ams (sLL $1 $> $ HsFunTy $1 $3)
+        | btype '->' ctype             {% ams (sLL $1 $> $ HsFunTy $1 $3)
                                               [mu AnnRarrow $2] }
 
 
 typedoc :: { LHsType GhcPs }
         : btype                          { $1 }
         | btype docprev                  { sLL $1 $> $ HsDocTy $1 $2 }
-        | btype '->'     ctypedoc        {% ams (sLL $1 $> $ HsFunTy $1 $3)
+        | btype '->'     ctypedoc        {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]
+                                         >> ams (sLL $1 $> $ HsFunTy $1 $3)
                                                 [mu AnnRarrow $2] }
-        | btype docprev '->' ctypedoc    {% ams (sLL $1 $> $
+        | btype docprev '->' ctypedoc    {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
+                                         >> ams (sLL $1 $> $
                                                  HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2))
                                                          $4)
                                                 [mu AnnRarrow $3] }
@@ -1846,8 +1848,8 @@ btype :: { LHsType GhcPs }
 -- > data Foo = Int :+ Char :* Bool
 -- See also Note [Parsing data constructors is hard] in RdrHsSyn
 btype_no_ops :: { LHsType GhcPs }
-        : btype_no_ops atype            { sLL $1 $> $ HsAppTy $1 $2 }
-        | atype                         { $1 }
+        : btype_no_ops atype_docs       { sLL $1 $> $ HsAppTy $1 $2 }
+        | atype_docs                    { $1 }
 
 tyapps :: { Located [LHsAppType GhcPs] }   -- NB: This list is reversed
         : tyapp                         { sL1 $1 [$1] }
@@ -1863,6 +1865,10 @@ tyapp :: { LHsAppType GhcPs }
         | SIMPLEQUOTE varop             {% ams (sLL $1 $> $ HsAppInfix $2)
                                                [mj AnnSimpleQuote $1] }
 
+atype_docs :: { LHsType GhcPs }
+        : atype docprev                 { sLL $1 $> $ HsDocTy $1 $2 }
+        | atype                         { $1 }
+
 atype :: { LHsType GhcPs }
         : ntgtycon                       { sL1 $1 (HsTyVar NotPromoted $1) }      -- Not including unit tuples
         | tyvar                          { sL1 $1 (HsTyVar NotPromoted $1) }      -- (See Note [Unit tuples])
@@ -2063,7 +2069,7 @@ gadt_constr_with_doc
 gadt_constr :: { LConDecl GhcPs }
     -- see Note [Difference in parsing GADT and data constructors]
     -- Returns a list because of:   C,D :: ty
-        : con_list '::' sigtype
+        : con_list '::' sigtypedoc
                 {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) $3))
                        [mu AnnDcolon $2] }
 
@@ -2090,33 +2096,38 @@ constrs1 :: { Located [LConDecl GhcPs] }
         | constr                                          { sL1 $1 [$1] }
 
 constr :: { LConDecl GhcPs }
-        : maybe_docnext forall context_no_ops '=>' constr_stuff maybe_docprev
-                {% ams (let (con,details) = unLoc $5 in
+        : maybe_docnext forall context_no_ops '=>' constr_stuff
+                {% ams (let (con,details,doc_prev) = unLoc $5 in
                   addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con
                                                        (snd $ unLoc $2)
                                                        (Just $3)
                                                        details))
-                            ($1 `mplus` $6))
+                            ($1 `mplus` doc_prev))
                         (mu AnnDarrow $4:(fst $ unLoc $2)) }
-        | maybe_docnext forall constr_stuff maybe_docprev
-                {% ams ( let (con,details) = unLoc $3 in
+        | maybe_docnext forall constr_stuff
+                {% ams ( let (con,details,doc_prev) = unLoc $3 in
                   addConDoc (L (comb2 $2 $3) (mkConDeclH98 con
                                                       (snd $ unLoc $2)
                                                       Nothing   -- No context
                                                       details))
-                            ($1 `mplus` $4))
+                            ($1 `mplus` doc_prev))
                        (fst $ unLoc $2) }
 
 forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr GhcPs]) }
         : 'forall' tv_bndrs '.'       { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }
         | {- empty -}                 { noLoc ([], Nothing) }
 
-constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs) }
+constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString) }
     -- 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) } }
+        | btype_no_ops conop maybe_docprev btype_no_ops
+            {% do { lhs <- splitTilde $1
+                              ; (_, ds_l) <- checkInfixConstr lhs
+                  ; (rhs, ds_r) <- checkInfixConstr $4
+                  ; return $ if isJust (ds_l `mplus` $3)
+                               then sLL $1 $> ($2, InfixCon lhs $4, $3)
+                               else sLL $1 $> ($2, InfixCon lhs rhs, ds_r) } }
 
 fielddecls :: { [LConDeclField GhcPs] }
         : {- empty -}     { [] }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 0f8e503154..389e7ee782 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -44,6 +44,7 @@ module   RdrHsSyn (
         -- checking and constructing values
         checkPrecP,           -- Int -> P Int
         checkContext,         -- HsType -> P HsContext
+        checkInfixConstr,
         checkPattern,         -- HsExp -> P HsPat
         bang_RDR,
         checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
@@ -454,7 +455,8 @@ 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
+* Use 'splitCon' to rejig it into the data constructor, the args, and possibly
+  extract a docstring for the constructor
 
 * 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.
@@ -466,23 +468,51 @@ So the plan is:
 -}
 
 splitCon :: LHsType GhcPs
-      -> P (Located RdrName, HsConDeclDetails GhcPs)
+      -> P ( Located RdrName         -- constructor name
+           , HsConDeclDetails GhcPs  -- constructor field information
+           , Maybe LHsDocString      -- docstring to go on the constructor
+           )
 -- 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 }
 -- and returns the pieces
 splitCon ty
- = split ty []
+ = split apps' []
  where
    -- This is used somewhere where HsAppsTy is not used
-   split (L _ (HsAppTy t u)) ts       = split t (u : ts)
-   split (L l (HsTyVar _ (L _ tc)))  ts = do data_con <- tyConToDataCon l tc
-                                             return (data_con, mk_rest ts)
-   split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) []
-      = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts)
-   split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
-
+   unrollApps (L _ (HsAppTy t u)) = u : unrollApps t
+   unrollApps t = [t]
+
+   apps = unrollApps ty
+   oneDoc = [ () | L _ (HsDocTy _ _) <- apps ] `lengthIs` 1
+
+   -- the trailing doc, if any, can be extracted first
+   (apps', trailing_doc)
+     = case apps of
+         L _ (HsDocTy t ds) : ts | oneDoc -> (t : ts, Just ds)
+         ts -> (ts, Nothing)
+
+   -- A comment on the constructor is handled a bit differently - it doesn't
+   -- remain an 'HsDocTy', but gets lifted out and returned as the third
+   -- element of the tuple.
+   split [ L _ (HsDocTy con con_doc) ] ts = do
+     (data_con, con_details, con_doc') <- split [con] ts
+     return (data_con, con_details, con_doc' `mplus` Just con_doc)
+   split [ L l (HsTyVar _ (L _ tc)) ] ts = do
+     data_con <- tyConToDataCon l tc
+     return (data_con, mk_rest ts, trailing_doc)
+   split [ L l (HsTupleTy HsBoxedOrConstraintTuple ts) ] []
+     = return ( L l (getRdrName (tupleDataCon Boxed (length ts)))
+              , PrefixCon ts
+              , trailing_doc
+              )
+   split [ L l _ ] _ = parseErrorSDoc l (text msg <+> ppr ty)
+     where msg = "Cannot parse data constructor in a data/newtype declaration:"
+   split (u : us) ts = split us (u : ts)
+   split _ _ = panic "RdrHsSyn:splitCon"
+
+   mk_rest [L _ (HsDocTy t@(L _ HsRecTy{}) _)] = mk_rest [t]
    mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
    mk_rest ts                   = PrefixCon ts
 
@@ -504,6 +534,22 @@ tyConToDataCon loc tc
           = text "Perhaps you intended to use ExistentialQuantification"
           | otherwise = empty
 
+-- | Split a type to extract the trailing doc string (if there is one) from a
+-- type produced by the 'btype_no_ops' production.
+splitDocTy :: LHsType GhcPs -> (LHsType GhcPs, Maybe LHsDocString)
+splitDocTy (L l (HsAppTy t1 t2)) = (L l (HsAppTy t1 t2'), ds)
+  where ~(t2', ds) = splitDocTy t2
+splitDocTy (L _ (HsDocTy ty ds)) = (ty, Just ds)
+splitDocTy ty = (ty, Nothing)
+
+-- | Given a type that is a field to an infix data constructor, try to split
+-- off a trailing docstring on the type, and check that there are no other
+-- docstrings.
+checkInfixConstr :: LHsType GhcPs -> P (LHsType GhcPs, Maybe LHsDocString)
+checkInfixConstr ty = checkNoDocs msg ty' *> pure (ty', doc_string)
+  where (ty', doc_string) = splitDocTy ty
+        msg = text "infix constructor field"
+
 mkPatSynMatchGroup :: Located RdrName
                    -> Located (OrdList (LHsDecl GhcPs))
                    -> P (MatchGroup GhcPs (LHsExpr GhcPs))
@@ -795,8 +841,21 @@ checkContext (L l orig_t)
          where anns' = if l == lp1 then anns
                                    else (anns ++ mkParensApiAnn lp1)
 
-  check _anns _
-    = return ([],L l [L l orig_t]) -- no need for anns, returning original
+  -- no need for anns, returning original
+  check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t])
+
+  msg = text "data constructor context"
+
+-- | Check recursively if there are any 'HsDocTy's in the given type.
+-- This only works on a subset of types produced by 'btype_no_ops'
+checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
+checkNoDocs msg ty = go ty
+  where
+    go (L _ (HsAppTy t1 t2)) = go t1 *> go t2
+    go (L l (HsDocTy t ds)) = parseErrorSDoc l $ hsep
+                                [ text "Unexpected haddock", quotes (ppr ds)
+                                , text "on", msg, quotes (ppr t) ]
+    go _ = pure ()
 
 -- -------------------------------------------------------------------------
 -- Checking Patterns.