Adapt to HsConDecl{H98,GADT}Details split

Needed for GHC#18844.

8 files changed, 124 insertions, 93 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index c9aad6ed..8939664d 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -236,9 +236,9 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
   _ -> []
 
 ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String]
-ppCtor dflags dat subdocs con@ConDeclH98 {}
+ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
   -- AZ:TODO get rid of the concatMap
-   = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con)
+   = concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args'
     where
         f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
         f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index a90d9a6e..d0528322 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -796,20 +796,22 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
                             , ppLType unicode (getGADTConType con)
                             ]
 
-    fieldPart = case (con, getConArgsI con) of
-        -- Record style GADTs
-        (ConDeclGADT{}, RecCon _)            -> doConstrArgsWithDocs []
-
-        -- Regular record declarations
-        (_, RecCon (L _ fields))             -> doRecordFields fields
-
-        -- Any GADT or a regular H98 prefix data constructor
-        (_, PrefixCon args)     | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
-
-        -- An infix H98 data constructor
-        (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])
-
-        _ -> empty
+    fieldPart = case con of
+        ConDeclGADT{con_g_args = con_args'} -> case con_args' of
+          -- GADT record declarations
+          RecConGADT _                    -> doConstrArgsWithDocs []
+          -- GADT prefix data constructors
+          PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
+          _                               -> empty
+
+        ConDeclH98{con_args = con_args'} -> case con_args' of
+          -- H98 record declarations
+          RecCon (L _ fields)             -> doRecordFields fields
+          -- H98 prefix data constructors
+          PrefixCon args | hasArgDocs     -> doConstrArgsWithDocs (map hsScaledThing args)
+          -- H98 infix data constructor
+          InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])
+          _                               -> empty
 
     doRecordFields fields =
       vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 20e099ee..d80f8e95 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -937,20 +937,22 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
                               , fixity
                               ]
 
-    fieldPart = case (con, getConArgsI con) of
-        -- Record style GADTs
-        (ConDeclGADT{}, RecCon _)            -> [ doConstrArgsWithDocs [] ]
-
-        -- Regular record declarations
-        (_, RecCon (L _ fields))             -> [ doRecordFields fields ]
-
-        -- Any GADT or a regular H98 prefix data constructor
-        (_, PrefixCon args)     | hasArgDocs -> [ doConstrArgsWithDocs args ]
-
-        -- An infix H98 data constructor
-        (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]
-
-        _ -> []
+    fieldPart = case con of
+        ConDeclGADT{con_g_args = con_args'} -> case con_args' of
+          -- GADT record declarations
+          RecConGADT _                    -> [ doConstrArgsWithDocs [] ]
+          -- GADT prefix data constructors
+          PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ]
+          _                               -> []
+
+        ConDeclH98{con_args = con_args'} -> case con_args' of
+          -- H98 record declarations
+          RecCon (L _ fields)             -> [ doRecordFields fields ]
+          -- H98 prefix data constructors
+          PrefixCon args | hasArgDocs     -> [ doConstrArgsWithDocs args ]
+          -- H98 infix data constructor
+          InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]
+          _                               -> []
 
     doRecordFields fields = subFields pkg qual
       (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index b7faf6cd..c0347e56 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -387,34 +387,44 @@ synifyDataCon use_gadt_syntax dc =
   con_decl_field fl synTy = noLoc $
     ConDeclField noExtField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy
                  Nothing
-  hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
-          (True,True) -> Left "synifyDataCon: contradiction!"
-          (True,False) -> return $ RecCon (noLoc field_tys)
-          (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys)
-          (False,True) -> case linear_tys of
-                           [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)
-                           _ -> Left "synifyDataCon: infix with non-2 args?"
+
+  mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn)
+  mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
+    (True,True) -> Left "synifyDataCon: contradiction!"
+    (True,False) -> return $ RecCon (noLoc field_tys)
+    (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys)
+    (False,True) -> case linear_tys of
+                     [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)
+                     _ -> Left "synifyDataCon: infix with non-2 args?"
+
+  mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn
+  mk_gadt_arg_tys
+    | use_named_field_syntax = RecConGADT (noLoc field_tys)
+    | otherwise              = PrefixConGADT (map hsUnrestricted linear_tys)
+
  -- finally we get synifyDataCon's result!
- in hs_arg_tys >>=
-      \hat ->
-        if use_gadt_syntax
-           then return $ noLoc $
-              ConDeclGADT { con_g_ext  = []
-                          , con_names  = [name]
-                          , con_forall = noLoc $ not $ null user_tvbndrs
-                          , con_qvars  = map synifyTyVarBndr user_tvbndrs
-                          , con_mb_cxt = ctx
-                          , con_args   = hat
-                          , con_res_ty = synifyType WithinType [] res_ty
-                          , con_doc    = Nothing }
-           else return $ noLoc $
-              ConDeclH98 { con_ext    = noExtField
-                         , con_name   = name
-                         , con_forall = noLoc False
-                         , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs
-                         , con_mb_cxt = ctx
-                         , con_args   = hat
-                         , con_doc    = Nothing }
+ in if use_gadt_syntax
+       then do
+         let hat = mk_gadt_arg_tys
+         return $ noLoc $ ConDeclGADT
+           { con_g_ext  = []
+           , con_names  = [name]
+           , con_forall = noLoc $ not $ null user_tvbndrs
+           , con_qvars  = map synifyTyVarBndr user_tvbndrs
+           , con_mb_cxt = ctx
+           , con_g_args = hat
+           , con_res_ty = synifyType WithinType [] res_ty
+           , con_doc    = Nothing }
+       else do
+         hat <- mk_h98_arg_tys
+         return $ noLoc $ ConDeclH98
+           { con_ext    = noExtField
+           , con_name   = name
+           , con_forall = noLoc False
+           , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs
+           , con_mb_cxt = ctx
+           , con_args   = hat
+           , con_doc    = Nothing }
 
 synifyName :: NamedThing n => n -> Located Name
 synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n)
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 8d0b382b..d6d12e4e 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -134,9 +134,6 @@ mkHsForAllInvisTeleI ::
 mkHsForAllInvisTeleI invis_bndrs =
   HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs }
 
-getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI
-getConArgsI d = con_args d
-
 getGADTConType :: ConDecl DocNameI -> LHsType DocNameI
 -- The full type of a GADT data constructor We really only get this in
 -- order to pretty-print it, and currently only in Haddock's code.  So
@@ -144,7 +141,7 @@ getGADTConType :: ConDecl DocNameI -> LHsType DocNameI
 -- 'undefined's
 getGADTConType (ConDeclGADT { con_forall = L _ has_forall
                             , con_qvars = qtvs
-                            , con_mb_cxt = mcxt, con_args = args
+                            , con_mb_cxt = mcxt, con_g_args = args
                             , con_res_ty = res_ty })
  | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
                                   , hst_tele = mkHsForAllInvisTeleI qtvs
@@ -158,9 +155,8 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall
 
 --  tau_ty :: LHsType DocNameI
    tau_ty = case args of
-              RecCon flds ->  mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
-              PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
-              InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty)
+              RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
+              PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
 
    mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
 
@@ -199,7 +195,7 @@ getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn
 -- 'undefined's
 getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall
                             , con_qvars = qtvs
-                            , con_mb_cxt = mcxt, con_args = args
+                            , con_mb_cxt = mcxt, con_g_args = args
                             , con_res_ty = res_ty })
  | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
                                   , hst_tele = mkHsForAllInvisTele qtvs
@@ -213,9 +209,8 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall
 
 --   tau_ty :: LHsType DocNameI
    tau_ty = case args of
-              RecCon flds ->  mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
-              PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
-              InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty)
+              RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
+              PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
 
    -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
    mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 59809e89..ecaf1a5d 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -926,7 +926,7 @@ extractDecl declMap name decl
             let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
                                    <- insts
                                  -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)
-                               , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d))
+                               , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d))
                                , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
                                , L _ n <- ns
                                , extFieldOcc n == name
@@ -949,10 +949,14 @@ extractPatternSyn nm t tvs cons =
   extract :: ConDecl GhcRn -> Sig GhcRn
   extract con =
     let args =
-          case getConArgs con of
-            PrefixCon args' -> (map hsScaledThing args')
-            RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
-            InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
+          case con of
+            ConDeclH98 { con_args = con_args' } -> case con_args' of
+              PrefixCon args' -> map hsScaledThing args'
+              RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
+              InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
+            ConDeclGADT { con_g_args = con_args' } -> case con_args' of
+              PrefixConGADT args' -> map hsScaledThing args'
+              RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields
         typ = longArrow args (data_ty con)
         typ' =
           case con of
@@ -977,8 +981,8 @@ extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]
 extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
 
 extractRecSel nm t tvs (L _ con : rest) =
-  case getConArgs con of
-    RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
+  case getRecConArgs_maybe con of
+    Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
       L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))
     _ -> extractRecSel nm t tvs rest
  where
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 67439383..e7d19dfe 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -479,7 +479,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
       lname'    <- renameL lname
       ltyvars'  <- mapM renameLTyVarBndr ltyvars
       lcontext' <- traverse renameLContext lcontext
-      details'  <- renameDetails details
+      details'  <- renameH98Details details
       mbldoc'   <- mapM renameLDocHsSyn mbldoc
       return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars'
                    , con_mb_cxt = lcontext'
@@ -487,18 +487,18 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
                    , con_args = details', con_doc = mbldoc' })
 
 renameCon ConDeclGADT { con_names = lnames, con_qvars = ltyvars
-                            , con_mb_cxt = lcontext, con_args = details
+                            , con_mb_cxt = lcontext, con_g_args = details
                             , con_res_ty = res_ty, con_forall = forall
                             , con_doc = mbldoc } = do
       lnames'   <- mapM renameL lnames
       ltyvars'  <- mapM renameLTyVarBndr ltyvars
       lcontext' <- traverse renameLContext lcontext
-      details'  <- renameDetails details
+      details'  <- renameGADTDetails details
       res_ty'   <- renameLType res_ty
       mbldoc'   <- mapM renameLDocHsSyn mbldoc
       return (ConDeclGADT
                    { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars'
-                   , con_mb_cxt = lcontext', con_args = details'
+                   , con_mb_cxt = lcontext', con_g_args = details'
                    , con_res_ty = res_ty', con_doc = mbldoc'
                    , con_forall = forall}) -- Remove when #18311 is fixed
 
@@ -506,18 +506,24 @@ renameHsScaled :: HsScaled GhcRn (LHsType GhcRn)
                -> RnM (HsScaled DocNameI (LHsType DocNameI))
 renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty
 
-renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI)
-renameDetails (RecCon (L l fields)) = do
+renameH98Details :: HsConDeclH98Details GhcRn
+                 -> RnM (HsConDeclH98Details DocNameI)
+renameH98Details (RecCon (L l fields)) = do
   fields' <- mapM renameConDeclFieldField fields
   return (RecCon (L l fields'))
-                               -- This causes an assertion failure
---renameDetails (PrefixCon ps) = -- return . PrefixCon =<< mapM (_renameLType) ps
-renameDetails (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps
-renameDetails (InfixCon a b) = do
+renameH98Details (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps
+renameH98Details (InfixCon a b) = do
   a' <- renameHsScaled a
   b' <- renameHsScaled b
   return (InfixCon a' b')
 
+renameGADTDetails :: HsConDeclGADTDetails GhcRn
+                  -> RnM (HsConDeclGADTDetails DocNameI)
+renameGADTDetails (RecConGADT (L l fields)) = do
+  fields' <- mapM renameConDeclFieldField fields
+  return (RecConGADT (L l fields'))
+renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps
+
 renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
 renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
   names' <- mapM renameLFieldOcc names
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 33fbd000..1177fb18 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -187,21 +187,33 @@ restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
 restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
   where
     keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
-      case con_args d of
-        PrefixCon _ -> Just d
-        RecCon fields
-          | all field_avail (unL fields) -> Just d
-          | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) })
+      case d of
+        ConDeclH98 { con_args = args }    -> restrict_h98_args args
+        ConDeclGADT { con_g_args = args } -> restrict_gadt_args args
+      where
+        restrict_h98_args :: HsConDeclH98Details GhcRn -> Maybe (ConDecl GhcRn)
+        restrict_h98_args (PrefixCon _) = Just d
+        restrict_h98_args (RecCon (L _ fields))
+          | all field_avail fields = Just d
+          | otherwise = Just (d { con_args = PrefixCon (field_types fields) })
           -- if we have *all* the field names available, then
           -- keep the record declaration.  Otherwise degrade to
           -- a constructor declaration.  This isn't quite right, but
           -- it's the best we can do.
-        InfixCon _ _ -> Just d
-      where
+
+        restrict_h98_args (InfixCon _ _) = Just d
+
+        restrict_gadt_args :: HsConDeclGADTDetails GhcRn -> Maybe (ConDecl GhcRn)
+        restrict_gadt_args (PrefixConGADT _) = Just d
+        restrict_gadt_args (RecConGADT (L _ fields))
+          | all field_avail fields = Just d
+          | otherwise = Just (d { con_g_args = PrefixConGADT (field_types fields) })
+          -- see the comments for the RecCon case of `restrict_h98_args` above
+
         field_avail :: LConDeclField GhcRn -> Bool
         field_avail (L _ (ConDeclField _ fs _ _))
             = all (\f -> extFieldOcc (unLoc f) `elem` names) fs
-        field_types flds = [ hsUnrestricted t | ConDeclField _ _ t _ <- flds ]
+        field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ]
 
     keep _ = Nothing