From 3cce1bdee8c61bb6daa089059e12435178f50770 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Sat, 24 Oct 2020 10:38:55 -0400
Subject: Adapt to HsConDecl{H98,GADT}Details split

Needed for GHC#18844.
---
 haddock-api/src/Haddock/Convert.hs | 64 ++++++++++++++++++++++----------------
 1 file changed, 37 insertions(+), 27 deletions(-)

(limited to 'haddock-api/src/Haddock/Convert.hs')

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)
-- 
cgit v1.2.3