aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/GhcUtils.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/GhcUtils.hs')
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs265
1 files changed, 128 insertions, 137 deletions
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 10725ee5..546e2941 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,5 +1,8 @@
{-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -26,14 +29,14 @@ import Data.Maybe ( mapMaybe )
import Haddock.Types( DocName, DocNameI )
import GHC.Utils.FV as FV
-import GHC.Utils.Outputable ( Outputable, panic, showPpr )
-import GHC.Types.Basic (PromotionFlag(..))
+import GHC.Utils.Outputable ( Outputable )
+import GHC.Utils.Panic ( panic )
+import GHC.Driver.Ppr (showPpr )
import GHC.Types.Name
import GHC.Unit.Module
-import GHC.Driver.Types
import GHC
-import GHC.Core.Class
import GHC.Driver.Session
+import GHC.Types.Basic
import GHC.Types.SrcLoc ( advanceSrcLoc )
import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder
, tyVarKind, updateTyVarKind, isInvisibleArgFlag )
@@ -51,6 +54,8 @@ import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
+import GHC.HsToCore.Docs
+
moduleString :: Module -> String
moduleString = moduleNameString . moduleName
@@ -90,25 +95,12 @@ ifTrueJust :: Bool -> name -> Maybe name
ifTrueJust True = Just
ifTrueJust False = const Nothing
-sigName :: LSig name -> [IdP name]
+sigName :: LSig GhcRn -> [IdP GhcRn]
sigName (L _ sig) = sigNameNoLoc sig
-sigNameNoLoc :: Sig name -> [IdP name]
-sigNameNoLoc (TypeSig _ ns _) = map unLoc ns
-sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns
-sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns
-sigNameNoLoc (SpecSig _ n _ _) = [unLoc n]
-sigNameNoLoc (InlineSig _ n _) = [unLoc n]
-sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
-sigNameNoLoc _ = []
-
-- | Was this signature given by the user?
-isUserLSig :: LSig name -> Bool
-isUserLSig (L _ (TypeSig {})) = True
-isUserLSig (L _ (ClassOpSig {})) = True
-isUserLSig (L _ (PatSynSig {})) = True
-isUserLSig _ = False
-
+isUserLSig :: forall p. UnXRec p => LSig p -> Bool
+isUserLSig = isUserSig . unXRec @p
isClassD :: HsDecl a -> Bool
isClassD (TyClD _ d) = isClassDecl d
@@ -123,10 +115,10 @@ pretty = showPpr
-- instantiated at DocNameI instead of (GhcPass _).
-- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _)
-hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr flag n -> IdP n
-hsTyVarBndrName (UserTyVar _ _ name) = unLoc name
-hsTyVarBndrName (KindedTyVar _ _ (L _ name) _) = name
-hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec
+hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ NoExtCon, UnXRec n)
+ => HsTyVarBndr flag n -> IdP n
+hsTyVarBndrName (UserTyVar _ _ name) = unXRec @n name
+hsTyVarBndrName (KindedTyVar _ _ name _) = unXRec @n name
hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName
hsTyVarNameI (UserTyVar _ _ (L _ n)) = n
@@ -139,33 +131,45 @@ getConNamesI :: ConDecl DocNameI -> [Located DocName]
getConNamesI ConDeclH98 {con_name = name} = [name]
getConNamesI ConDeclGADT {con_names = names} = names
-hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing
-hsImplicitBodyI (HsIB { hsib_body = body }) = body
-
hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI
-hsSigTypeI = hsImplicitBodyI
+hsSigTypeI = sig_body . unLoc
+
+mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn
+-- Dubious, because the implicit binders are empty even
+-- though the type might have free varaiables
+mkEmptySigType lty@(L loc ty) = L loc $ case ty of
+ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }
+ , hst_body = body }
+ -> HsSig { sig_ext = noExtField
+ , sig_bndrs = HsOuterExplicit { hso_xexplicit = noExtField
+ , hso_bndrs = bndrs }
+ , sig_body = body }
+ _ -> HsSig { sig_ext = noExtField
+ , sig_bndrs = HsOuterImplicit{hso_ximplicit = []}
+ , sig_body = lty }
mkHsForAllInvisTeleI ::
[LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI
mkHsForAllInvisTeleI invis_bndrs =
HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs }
-getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI
-getConArgsI d = con_args d
+mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI
+mkHsImplicitSigTypeI body =
+ HsSig { sig_ext = noExtField
+ , sig_bndrs = HsOuterImplicit{hso_ximplicit = noExtField}
+ , sig_body = body }
-getGADTConType :: ConDecl DocNameI -> LHsType DocNameI
+getGADTConType :: ConDecl DocNameI -> LHsSigType 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
-- we are cavalier about locations and extensions, hence the
-- 'undefined's
-getGADTConType (ConDeclGADT { con_forall = L _ has_forall
- , con_qvars = qtvs
- , con_mb_cxt = mcxt, con_args = args
+getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs
+ , con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
- , hst_tele = mkHsForAllInvisTeleI qtvs
- , hst_body = theta_ty })
- | otherwise = theta_ty
+ = noLoc (HsSig { sig_ext = noExtField
+ , sig_bndrs = outer_bndrs
+ , sig_body = theta_ty })
where
theta_ty | Just theta <- mcxt
= noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
@@ -174,9 +178,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)
@@ -186,7 +189,7 @@ getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI]
getMainDeclBinderI (TyClD _ d) = [tcdNameI d]
getMainDeclBinderI (ValD _ d) =
- case collectHsBindBinders d of
+ case collectHsBindBinders CollNoDictBinders d of
[] -> []
(name:_) -> [name]
getMainDeclBinderI (SigD _ d) = sigNameNoLoc d
@@ -206,73 +209,33 @@ tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln
tcdNameI :: TyClDecl DocNameI -> DocName
tcdNameI = unLoc . tyClDeclLNameI
--- -------------------------------------
-
-getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn
--- 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
--- we are cavalier about locations and extensions, hence the
--- 'undefined's
-getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall
- , con_qvars = qtvs
- , con_mb_cxt = mcxt, con_args = args
- , con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
- , hst_tele = mkHsForAllInvisTele qtvs
- , hst_body = theta_ty })
- | otherwise = theta_ty
- where
- theta_ty | Just theta <- mcxt
- = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
- | otherwise
- = tau_ty
-
--- 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)
-
- -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
- mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
-
-getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"
- -- Should only be called on ConDeclGADT
-
-
-mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn
--- Dubious, because the implicit binders are empty even
--- though the type might have free varaiables
-mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty)
-
-
addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn
-- Add the class context to a class-op signature
addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
- = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype))))
- -- The mkEmptySigWcType is suspicious
+ = L pos (TypeSig noExtField lname (mkEmptyWildCardBndrs (go_sig_ty ltype)))
where
- go (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))
- = L loc (HsForAllTy { hst_tele = tele, hst_xforall = noExtField
- , hst_body = go ty })
- go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
+ go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty }))
+ = L loc (HsSig { sig_ext = noExtField
+ , sig_bndrs = bndrs, sig_body = go_ty ty })
+
+ go_ty (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))
+ = L loc (HsForAllTy { hst_xforall = noExtField
+ , hst_tele = tele, hst_body = go_ty ty })
+ go_ty (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
= L loc (HsQualTy { hst_xqual = noExtField
, hst_ctxt = add_ctxt ctxt, hst_body = ty })
- go (L loc ty)
+ go_ty (L loc ty)
= L loc (HsQualTy { hst_xqual = noExtField
, hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
- extra_pred :: LHsType GhcRn
- extra_pred = nlHsTyConApp Prefix cls (map HsValArg (lHsQTyVarsToTypes tvs0))
-
- add_ctxt :: LHsContext GhcRn -> LHsContext GhcRn
+ extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0)
add_ctxt (L loc preds) = L loc (extra_pred : preds)
addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
-lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]
+lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn]
lHsQTyVarsToTypes tvs
- = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))
+ = [ HsValArg $ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))
| tv <- hsQTvExplicit tvs ]
@@ -280,7 +243,6 @@ lHsQTyVarsToTypes tvs
-- * Making abstract declarations
--------------------------------------------------------------------------------
-
restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
restrictTo names (L loc decl) = L loc $ case decl of
TyClD x d | isDataDecl d ->
@@ -303,17 +265,27 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
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 (unLoc fields) -> Just d
- | otherwise -> Just (d { con_args = PrefixCon (field_types $ unLoc 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
+ keep :: ConDecl GhcRn -> Maybe (ConDecl GhcRn)
+ keep d
+ | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
+ case d of
+ ConDeclH98 { con_args = con_args' } -> case con_args' of
+ PrefixCon {} -> Just d
+ RecCon fields
+ | all field_avail (unLoc fields) -> Just d
+ | otherwise -> Just (d { con_args = PrefixCon [] (field_types $ unLoc 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
+
+ ConDeclGADT { con_g_args = con_args' } -> case con_args' of
+ PrefixConGADT {} -> Just d
+ RecConGADT fields
+ | all field_avail (unLoc fields) -> Just d
+ | otherwise -> Just (d { con_g_args = PrefixConGADT (field_types $ unLoc fields) })
+ -- see above
where
field_avail :: LConDeclField GhcRn -> Bool
field_avail (L _ (ConDeclField _ fs _ _))
@@ -358,17 +330,19 @@ data Precedence
--
-- We cannot add parens that may be required by fixities because we do not have
-- any fixity information to work with in the first place :(.
-reparenTypePrec :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a
+reparenTypePrec :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => Precedence -> HsType a -> HsType a
reparenTypePrec = go
where
-- Shorter name for 'reparenType'
- go :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a
+ go :: Precedence -> HsType a -> HsType a
go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty)
go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)
go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys)
go _ (HsListTy x ty) = HsListTy x (reparenLType ty)
- go _ (HsRecTy x flds) = HsRecTy x (map (fmap reparenConDeclField) flds)
+ go _ (HsRecTy x flds) = HsRecTy x (map (mapXRec @a reparenConDeclField) flds)
go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d
go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys)
go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)
@@ -381,7 +355,8 @@ reparenTypePrec = go
go p (HsQualTy x ctxt ty)
= let p' [_] = PREC_CTX
p' _ = PREC_TOP -- parens will get added anyways later...
- in paren p PREC_CTX $ HsQualTy x (fmap (\xs -> map (goL (p' xs)) xs) ctxt) (goL PREC_TOP ty)
+ ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt
+ in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty)
go p (HsFunTy x w ty1 ty2)
= paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2)
go p (HsAppTy x fun_ty arg_ty)
@@ -390,7 +365,7 @@ reparenTypePrec = go
= paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki)
go p (HsOpTy x ty1 op ty2)
= paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2)
- go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed
+ go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed
go _ t@HsTyVar{} = t
go _ t@HsStarTy{} = t
go _ t@HsSpliceTy{} = t
@@ -399,43 +374,68 @@ reparenTypePrec = go
go _ t@XHsType{} = t
-- Located variant of 'go'
- goL :: (XParTy a ~ NoExtField) => Precedence -> LHsType a -> LHsType a
- goL ctxt_prec = fmap (go ctxt_prec)
+ goL :: Precedence -> LHsType a -> LHsType a
+ goL ctxt_prec = mapXRec @a (go ctxt_prec)
-- Optionally wrap a type in parens
- paren :: (XParTy a ~ NoExtField)
- => Precedence -- Precedence of context
+ paren :: Precedence -- Precedence of context
-> Precedence -- Precedence of top-level operator
-> HsType a -> HsType a -- Wrap in parens if (ctxt >= op)
- paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . noLoc
+ paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . wrapXRec @a
| otherwise = id
-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')
-reparenType :: (XParTy a ~ NoExtField) => HsType a -> HsType a
+reparenType :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => HsType a -> HsType a
reparenType = reparenTypePrec PREC_TOP
-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')
-reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a
-reparenLType = fmap reparenType
+reparenLType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => LHsType a -> LHsType a
+reparenLType = mapXRec @a reparenType
+
+-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec')
+reparenSigType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => HsSigType a -> HsSigType a
+reparenSigType (HsSig x bndrs body) =
+ HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body)
+reparenSigType v@XHsSigType{} = v
+
+-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec')
+reparenOuterTyVarBndrs :: forall flag a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a
+reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp
+reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
+ HsOuterExplicit x (map (mapXRec @(NoGhcTc a) reparenTyVar) exp_bndrs)
+reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v
-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')
-reparenHsForAllTelescope :: (XParTy a ~ NoExtField)
+reparenHsForAllTelescope :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
=> HsForAllTelescope a -> HsForAllTelescope a
reparenHsForAllTelescope (HsForAllVis x bndrs) =
- HsForAllVis x (map (fmap reparenTyVar) bndrs)
+ HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs)
reparenHsForAllTelescope (HsForAllInvis x bndrs) =
- HsForAllInvis x (map (fmap reparenTyVar) bndrs)
+ HsForAllInvis x (map (mapXRec @a reparenTyVar) bndrs)
reparenHsForAllTelescope v@XHsForAllTelescope{} = v
-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
-reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a
+reparenTyVar :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => HsTyVarBndr flag a -> HsTyVarBndr flag a
reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n
reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind)
reparenTyVar v@XTyVarBndr{} = v
-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
-reparenConDeclField :: (XParTy a ~ NoExtField) => ConDeclField a -> ConDeclField a
+reparenConDeclField :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => ConDeclField a -> ConDeclField a
reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d
reparenConDeclField c@XConDeclField{} = c
@@ -471,10 +471,9 @@ class Parent a where
instance Parent (ConDecl GhcRn) where
children con =
- case con_args con of
- RecCon fields -> map (extFieldOcc . unLoc) $
- concatMap (cd_fld_names . unLoc) (unLoc fields)
- _ -> []
+ case getRecConArgs_maybe con of
+ Nothing -> []
+ Just flds -> map (extFieldOcc . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds)
instance Parent (TyClDecl GhcRn) where
children d
@@ -526,14 +525,6 @@ modifySessionDynFlags f = do
return ()
--- Extract the minimal complete definition of a Name, if one exists
-minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef)
-minimalDef n = do
- mty <- lookupGlobalName n
- case mty of
- Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c
- _ -> return Nothing
-
-------------------------------------------------------------------------------
-- * DynFlags
-------------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 10:51:15 +0000