diff options
| author | Ryan Scott <ryan.gl.scott@gmail.com> | 2020-10-24 10:38:55 -0400 |
|---|---|---|
| committer | Ryan Scott <ryan.gl.scott@gmail.com> | 2020-10-30 04:53:05 -0400 |
| commit | 3cce1bdee8c61bb6daa089059e12435178f50770 (patch) | |
| tree | 32cb09fe0afa9753bf82fd90bd7016336439fc7b /haddock-api/src/Haddock/GhcUtils.hs | |
| parent | 87a9f86d1ad7de67ff011311905ecf76578b26e9 (diff) | |
Adapt to HsConDecl{H98,GADT}Details split
Needed for GHC#18844.
Diffstat (limited to 'haddock-api/src/Haddock/GhcUtils.hs')
| -rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 17 |
1 files changed, 6 insertions, 11 deletions
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) |