aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs30
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs30
-rw-r--r--haddock-api/src/Haddock/Convert.hs64
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs17
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs18
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs26
-rw-r--r--haddock-api/src/Haddock/Utils.hs28
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-20 22:43:50 +0000