Split HsConDecl{H98,GADT}Detailswip/T18844

Haskell98 and GADT constructors both use `HsConDeclDetails`, which includes
`InfixCon`. But `InfixCon` is never used for GADT constructors, which results
in an awkward unrepresentable state. This removes the unrepresentable state by:

* Renaming the existing `HsConDeclDetails` synonym to `HsConDeclH98Details`,
  which emphasizes the fact that it is now only used for Haskell98-style data
  constructors, and
* Creating a new `HsConDeclGADTDetails` data type with `PrefixConGADT` and
  `RecConGADT` constructors that closely resemble `PrefixCon` and `InfixCon`
  in `HsConDeclH98Details`. The key difference is that `HsConDeclGADTDetails`
  lacks any way to represent infix constructors.

The rest of the patch is refactoring to accommodate the new structure of
`HsConDecl{H98,GADT}Details`. Some highlights:

* The `getConArgs` and `hsConDeclArgTys` functions have been removed, as
  there is no way to implement these functions uniformly for all
  `ConDecl`s. For the most part, their previous call sites now
  pattern match on the `ConDecl`s directly and do different things for
  `ConDeclH98`s and `ConDeclGADT`s.

  I did introduce one new function to make the transition easier:
  `getRecConArgs_maybe`, which extracts the arguments from a `RecCon(GADT)`.
  This is still possible since `RecCon(GADT)`s still use the same representation
  in both `HsConDeclH98Details` and `HsConDeclGADTDetails`, and since the
  pattern that `getRecConArgs_maybe` implements is used in several places,
  I thought it worthwhile to factor it out into its own function.
* Previously, the `con_args` fields in `ConDeclH98` and `ConDeclGADT` were
  both of type `HsConDeclDetails`. Now, the former is of type
  `HsConDeclH98Details`, and the latter is of type `HsConDeclGADTDetails`,
  which are distinct types. As a result, I had to rename the `con_args` field
  in `ConDeclGADT` to `con_g_args` to make it typecheck.

  A consequence of all this is that the `con_args` field is now partial, so
  using `con_args` as a top-level field selector is dangerous. (Indeed, Haddock
  was using `con_args` at the top-level, which caused it to crash at runtime
  before I noticed what was wrong!) I decided to add a disclaimer in the 9.2.1
  release notes to advertise this pitfall.

Fixes #18844. Bumps the `haddock` submodule.

2 files changed, 62 insertions, 62 deletions

diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
index 2a82c986e3..38162298c4 100644
--- a/compiler/GHC/HsToCore/Docs.hs
+++ b/compiler/GHC/HsToCore/Docs.hs
@@ -189,7 +189,7 @@ subordinates instMap decl = case decl of
                     , conArgDocs c)
                   | c <- cons, cname <- getConNames c ]
         fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
-                  | RecCon flds <- map getConArgs cons
+                  | Just flds <- map getRecConArgs_maybe cons
                   , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
                   , (L _ n) <- ns ]
         derivs  = [ (instName, [unLoc doc], M.empty)
@@ -216,22 +216,30 @@ subordinates instMap decl = case decl of
             _               -> Nothing
 
 -- | Extract constructor argument docs from inside constructor decls.
-conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)
-conArgDocs con = case getConArgs con of
-                   PrefixCon args -> go 0 (map (unLoc . hsScaledThing) args ++ ret)
-                   InfixCon arg1 arg2 -> go 0 ([unLoc (hsScaledThing arg1),
-                                                unLoc (hsScaledThing arg2)] ++ ret)
-                   RecCon _ -> go 1 ret
+conArgDocs :: ConDecl GhcRn -> Map Int HsDocString
+conArgDocs (ConDeclH98{con_args = args}) =
+  h98ConArgDocs args
+conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =
+  gadtConArgDocs args (unLoc res_ty)
+
+h98ConArgDocs :: HsConDeclH98Details GhcRn -> Map Int HsDocString
+h98ConArgDocs con_args = case con_args of
+  PrefixCon args     -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args
+  InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)
+                                       , unLoc (hsScaledThing arg2) ]
+  RecCon _           -> M.empty
+
+gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> Map Int HsDocString
+gadtConArgDocs con_args res_ty = case con_args of
+  PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty]
+  RecConGADT _       -> con_arg_docs 1 [res_ty]
+
+con_arg_docs :: Int -> [HsType GhcRn] -> Map Int HsDocString
+con_arg_docs n = M.fromList . catMaybes . zipWith f [n..]
   where
-    go n = M.fromList . catMaybes . zipWith f [n..]
-      where
-        f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
-        f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)
-        f _ _ = Nothing
-
-    ret = case con of
-            ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
-            _ -> []
+    f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
+    f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)
+    f _ _ = Nothing
 
 isValD :: HsDecl a -> Bool
 isValD (ValD _ _) = True
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index fb2b78141b..b22d45d182 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -877,7 +877,7 @@ repC (L _ (ConDeclH98 { con_name   = con
                       , con_forall = (L _ False)
                       , con_mb_cxt = Nothing
                       , con_args   = args }))
-  = repDataCon con args
+  = repH98DataCon con args
 
 repC (L _ (ConDeclH98 { con_name = con
                       , con_forall = L _ is_existential
@@ -885,7 +885,7 @@ repC (L _ (ConDeclH98 { con_name = con
                       , con_mb_cxt = mcxt
                       , con_args = args }))
   = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
-         do { c'    <- repDataCon con args
+         do { c'    <- repH98DataCon con args
             ; ctxt' <- repMbContext mcxt
             ; if not is_existential && isNothing mcxt
               then return c'
@@ -897,7 +897,7 @@ repC (L _ (ConDeclGADT { con_g_ext  = imp_tvs
                        , con_names  = cons
                        , con_qvars  = exp_tvs
                        , con_mb_cxt = mcxt
-                       , con_args   = args
+                       , con_g_args = args
                        , con_res_ty = res_ty }))
   | null imp_tvs && null exp_tvs -- No implicit or explicit variables
   , Nothing <- mcxt              -- No context
@@ -2589,49 +2589,51 @@ repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
 repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt))
 repCtxt (MkC tys) = rep2 cxtName [tys]
 
-repDataCon :: Located Name
-           -> HsConDeclDetails GhcRn
-           -> MetaM (Core (M TH.Con))
-repDataCon con details
+repH98DataCon :: Located Name
+              -> HsConDeclH98Details GhcRn
+              -> MetaM (Core (M TH.Con))
+repH98DataCon con details
     = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
-         repConstr details Nothing [con']
+         case details of
+           PrefixCon ps -> do
+             arg_tys <- repPrefixConArgs ps
+             rep2 normalCName [unC con', unC arg_tys]
+           InfixCon st1 st2 -> do
+             arg1 <- repBangTy (hsScaledThing st1)
+             arg2 <- repBangTy (hsScaledThing st2)
+             rep2 infixCName [unC arg1, unC con', unC arg2]
+           RecCon ips -> do
+             arg_vtys <- repRecConArgs ips
+             rep2 recCName [unC con', unC arg_vtys]
 
 repGadtDataCons :: [Located Name]
-                -> HsConDeclDetails GhcRn
+                -> HsConDeclGADTDetails GhcRn
                 -> LHsType GhcRn
                 -> MetaM (Core (M TH.Con))
 repGadtDataCons cons details res_ty
     = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
-         repConstr details (Just res_ty) cons'
-
--- Invariant:
---   * for plain H98 data constructors second argument is Nothing and third
---     argument is a singleton list
---   * for GADTs data constructors second argument is (Just return_type) and
---     third argument is a non-empty list
-repConstr :: HsConDeclDetails GhcRn
-          -> Maybe (LHsType GhcRn)
-          -> [Core TH.Name]
-          -> MetaM (Core (M TH.Con))
-repConstr (PrefixCon ps) Nothing [con]
-    = do arg_tys  <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
-         rep2 normalCName [unC con, unC arg_tys]
-
-repConstr (PrefixCon ps) (Just res_ty) cons
-    = do arg_tys     <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
-         res_ty' <- repLTy res_ty
-         rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
-
-repConstr (RecCon ips) resTy cons
-    = do args     <- concatMapM rep_ip (unLoc ips)
-         arg_vtys <- coreListM varBangTypeTyConName args
-         case resTy of
-           Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
-           Just res_ty -> do
+         case details of
+           PrefixConGADT ps -> do
+             arg_tys <- repPrefixConArgs ps
              res_ty' <- repLTy res_ty
-             rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
+             rep2 gadtCName [ unC (nonEmptyCoreList cons'), unC arg_tys, unC res_ty']
+           RecConGADT ips -> do
+             arg_vtys <- repRecConArgs ips
+             res_ty'  <- repLTy res_ty
+             rep2 recGadtCName [unC (nonEmptyCoreList cons'), unC arg_vtys,
                                 unC res_ty']
 
+-- Desugar the arguments in a data constructor declared with prefix syntax.
+repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)]
+                 -> MetaM (Core [M TH.BangType])
+repPrefixConArgs ps = repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
+
+-- Desugar the arguments in a data constructor declared with record syntax.
+repRecConArgs :: Located [LConDeclField GhcRn]
+              -> MetaM (Core [M TH.VarBangType])
+repRecConArgs ips = do
+  args     <- concatMapM rep_ip (unLoc ips)
+  coreListM varBangTypeTyConName args
     where
       rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
 
@@ -2640,16 +2642,6 @@ repConstr (RecCon ips) resTy cons
                           ; MkC ty <- repBangTy  t
                           ; rep2 varBangTypeName [v,ty] }
 
-repConstr (InfixCon st1 st2) Nothing [con]
-    = do arg1 <- repBangTy (hsScaledThing st1)
-         arg2 <- repBangTy (hsScaledThing st2)
-         rep2 infixCName [unC arg1, unC con, unC arg2]
-
-repConstr (InfixCon {}) (Just _) _ =
-    panic "repConstr: infix GADT constructor should be in a PrefixCon"
-repConstr _ _ _ =
-    panic "repConstr: invariant violated"
-
 ------------ Types -------------------
 
 repTForall :: Core [(M (TH.TyVarBndr TH.Specificity))] -> Core (M TH.Cxt) -> Core (M TH.Type)