diff options
Diffstat (limited to 'haddock-api/src/Haddock/GhcUtils.hs')
-rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 254 |
1 files changed, 127 insertions, 127 deletions
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 10725ee5..34297a0a 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,15 @@ 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 +55,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 +96,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 +116,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 +132,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 +179,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) @@ -206,73 +210,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 +244,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 +266,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 +331,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 +356,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 +366,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 +375,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 +472,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 |