diff options
Diffstat (limited to 'haddock-api/src/Haddock/GhcUtils.hs')
| -rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 222 |
1 files changed, 102 insertions, 120 deletions
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 43fe3e77..10725ee5 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -25,28 +25,27 @@ import Data.Maybe ( mapMaybe ) import Haddock.Types( DocName, DocNameI ) -import BasicTypes ( PromotionFlag(..) ) -import Exception -import FV -import Outputable ( Outputable, panic, showPpr ) -import Name -import NameSet -import Module -import HscTypes +import GHC.Utils.FV as FV +import GHC.Utils.Outputable ( Outputable, panic, showPpr ) +import GHC.Types.Basic (PromotionFlag(..)) +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Driver.Types import GHC -import Class -import DynFlags -import SrcLoc ( advanceSrcLoc ) -import Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind, - isInvisibleArgFlag ) -import VarSet ( VarSet, emptyVarSet ) -import VarEnv ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) -import TyCoRep ( Type(..) ) -import Type ( isRuntimeRepVar ) -import TysWiredIn( liftedRepDataConTyCon ) - -import StringBuffer ( StringBuffer ) -import qualified StringBuffer as S +import GHC.Core.Class +import GHC.Driver.Session +import GHC.Types.SrcLoc ( advanceSrcLoc ) +import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder + , tyVarKind, updateTyVarKind, isInvisibleArgFlag ) +import GHC.Types.Var.Set ( VarSet, emptyVarSet ) +import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) +import GHC.Core.TyCo.Rep ( Type(..) ) +import GHC.Core.Type ( isRuntimeRepVar ) +import GHC.Builtin.Types( liftedRepDataConTyCon ) +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) + +import GHC.Data.StringBuffer ( StringBuffer ) +import qualified GHC.Data.StringBuffer as S import Data.ByteString ( ByteString ) import qualified Data.ByteString as BS @@ -58,38 +57,6 @@ moduleString = moduleNameString . moduleName isNameSym :: Name -> Bool isNameSym = isSymOcc . nameOccName -getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)] -getMainDeclBinder (TyClD _ d) = [tcdName d] -getMainDeclBinder (ValD _ d) = - case collectHsBindBinders d of - [] -> [] - (name:_) -> [name] -getMainDeclBinder (SigD _ d) = sigNameNoLoc d -getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] -getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] -getMainDeclBinder _ = [] - --- Extract the source location where an instance is defined. This is used --- to correlate InstDecls with their Instance/CoAxiom Names, via the --- instanceMap. -getInstLoc :: InstDecl (GhcPass p) -> SrcSpan -getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) -getInstLoc (DataFamInstD _ (DataFamInstDecl - { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l -getInstLoc (TyFamInstD _ (TyFamInstDecl - -- Since CoAxioms' Names refer to the whole line for type family instances - -- in particular, we need to dig a bit deeper to pull out the entire - -- equation. This does not happen for data family instances, for some reason. - { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l -getInstLoc (ClsInstD _ (XClsInstDecl nec)) = noExtCon nec -getInstLoc (DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn nec)))) = noExtCon nec -getInstLoc (TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn nec)))) = noExtCon nec -getInstLoc (XInstDecl nec) = noExtCon nec -getInstLoc (DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs nec))) = noExtCon nec -getInstLoc (TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs nec))) = noExtCon nec - - - -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. -- but only one of the names is exported and we have to change the @@ -147,48 +114,45 @@ isClassD :: HsDecl a -> Bool isClassD (TyClD _ d) = isClassDecl d isClassD _ = False -isValD :: HsDecl a -> Bool -isValD (ValD _ _) = True -isValD _ = False - pretty :: Outputable a => DynFlags -> a -> String pretty = showPpr -nubByName :: (a -> Name) -> [a] -> [a] -nubByName f ns = go emptyNameSet ns - where - go !_ [] = [] - go !s (x:xs) - | y `elemNameSet` s = go s xs - | otherwise = let !s' = extendNameSet s y - in x : go s' xs - where - y = f x - - -- --------------------------------------------------------------------- -- These functions are duplicated from the GHC API, as they must be -- instantiated at DocNameI instead of (GhcPass _). -- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _) -hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr n -> IdP n -hsTyVarBndrName (UserTyVar _ name) = unLoc name -hsTyVarBndrName (KindedTyVar _ (L _ name) _) = name +hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr flag n -> IdP n +hsTyVarBndrName (UserTyVar _ _ name) = unLoc name +hsTyVarBndrName (KindedTyVar _ _ (L _ name) _) = name hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec +hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName +hsTyVarNameI (UserTyVar _ _ (L _ n)) = n +hsTyVarNameI (KindedTyVar _ _ (L _ n) _) = n + +hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName +hsLTyVarNameI = hsTyVarNameI . unLoc + getConNamesI :: ConDecl DocNameI -> [Located DocName] getConNamesI ConDeclH98 {con_name = name} = [name] getConNamesI ConDeclGADT {con_names = names} = names -getConNamesI (XConDecl nec) = noExtCon nec hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing hsImplicitBodyI (HsIB { hsib_body = body }) = body -hsImplicitBodyI (XHsImplicitBndrs nec) = noExtCon nec hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI hsSigTypeI = hsImplicitBodyI +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 + 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 @@ -198,9 +162,8 @@ getGADTConType (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_fvf = ForallInvis - , hst_xforall = noExtField - , hst_bndrs = hsQTvExplicit qtvs + | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField + , hst_tele = mkHsForAllInvisTeleI qtvs , hst_body = theta_ty }) | otherwise = theta_ty where @@ -209,16 +172,16 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall | otherwise = tau_ty +-- tau_ty :: LHsType DocNameI tau_ty = case args of - RecCon flds -> noLoc (HsFunTy noExtField (noLoc (HsRecTy noExtField (unLoc flds))) res_ty) - PrefixCon pos_args -> foldr mkFunTy res_ty pos_args - InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty) + 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 a b = noLoc (HsFunTy noExtField a b) + mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT -getGADTConType (XConDecl nec) = noExtCon nec getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI] getMainDeclBinderI (TyClD _ d) = [tcdNameI d] @@ -233,21 +196,19 @@ getMainDeclBinderI _ = [] familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName familyDeclLNameI (FamilyDecl { fdLName = n }) = n -familyDeclLNameI (XFamilyDecl nec) = noExtCon nec tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName tyClDeclLNameI (FamDecl { tcdFam = fd }) = familyDeclLNameI fd tyClDeclLNameI (SynDecl { tcdLName = ln }) = ln tyClDeclLNameI (DataDecl { tcdLName = ln }) = ln tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln -tyClDeclLNameI (XTyClDecl nec) = noExtCon nec tcdNameI :: TyClDecl DocNameI -> DocName tcdNameI = unLoc . tyClDeclLNameI -- ------------------------------------- -getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p) +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 @@ -256,9 +217,8 @@ 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_fvf = ForallInvis - , hst_xforall = noExtField - , hst_bndrs = hsQTvExplicit qtvs + | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField + , hst_tele = mkHsForAllInvisTele qtvs , hst_body = theta_ty }) | otherwise = theta_ty where @@ -267,16 +227,17 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall | otherwise = tau_ty +-- tau_ty :: LHsType DocNameI tau_ty = case args of - RecCon flds -> noLoc (HsFunTy noExtField (noLoc (HsRecTy noExtField (unLoc flds))) res_ty) - PrefixCon pos_args -> foldr mkFunTy res_ty pos_args - InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty) + 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 a b = noLoc (HsFunTy noExtField a b) + -- 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 -getGADTConTypeG (XConDecl nec) = noExtCon nec mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn @@ -291,9 +252,9 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where - go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tvs, hst_body = go ty }) + 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 })) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt ctxt, hst_body = ty }) @@ -301,7 +262,10 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) - extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) + extra_pred :: LHsType GhcRn + extra_pred = nlHsTyConApp Prefix cls (map HsValArg (lHsQTyVarsToTypes tvs0)) + + add_ctxt :: LHsContext GhcRn -> LHsContext GhcRn add_ctxt (L loc preds) = L loc (extra_pred : preds) addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine @@ -335,7 +299,6 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) [] -> defn { dd_ND = DataType, dd_cons = [] } [con] -> defn { dd_cons = [con] } _ -> error "Should not happen" -restrictDataDefn _ (XHsDataDefn nec) = noExtCon nec restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] @@ -345,7 +308,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] PrefixCon _ -> Just d RecCon fields | all field_avail (unLoc fields) -> Just d - | otherwise -> Just (d { con_args = PrefixCon (field_types (map unLoc (unLoc fields))) }) + | 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 @@ -355,8 +318,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField _ fs _ _)) = all (\f -> extFieldOcc (unLoc f) `elem` names) fs - field_avail (L _ (XConDeclField nec)) = noExtCon nec - field_types flds = [ t | ConDeclField _ _ t _ <- flds ] + + field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ] keep _ = Nothing @@ -413,14 +376,14 @@ reparenTypePrec = go = paren p PREC_SIG $ HsKindSig x (goL PREC_SIG ty) (goL PREC_SIG kind) go p (HsIParamTy x n ty) = paren p PREC_SIG $ HsIParamTy x n (reparenLType ty) - go p (HsForAllTy x fvf tvs ty) - = paren p PREC_CTX $ HsForAllTy x fvf (map (fmap reparenTyVar) tvs) (reparenLType ty) + go p (HsForAllTy x tele ty) + = paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType ty) 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) - go p (HsFunTy x ty1 ty2) - = paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2) + 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) = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty) go p (HsAppKindTy x fun_ty arg_ki) @@ -456,10 +419,19 @@ reparenType = reparenTypePrec PREC_TOP reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a reparenLType = fmap reparenType +-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec') +reparenHsForAllTelescope :: (XParTy a ~ NoExtField) + => HsForAllTelescope a -> HsForAllTelescope a +reparenHsForAllTelescope (HsForAllVis x bndrs) = + HsForAllVis x (map (fmap reparenTyVar) bndrs) +reparenHsForAllTelescope (HsForAllInvis x bndrs) = + HsForAllInvis x (map (fmap reparenTyVar) bndrs) +reparenHsForAllTelescope v@XHsForAllTelescope{} = v + -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') -reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr a -> HsTyVarBndr a -reparenTyVar (UserTyVar x n) = UserTyVar x n -reparenTyVar (KindedTyVar x n kind) = KindedTyVar x n (reparenLType kind) +reparenTyVar :: (XParTy a ~ NoExtField) => 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') @@ -469,6 +441,18 @@ reparenConDeclField c@XConDeclField{} = c ------------------------------------------------------------------------------- +-- * Located +------------------------------------------------------------------------------- + + +unL :: Located a -> a +unL (L _ x) = x + + +reL :: a -> Located a +reL = L undefined + +------------------------------------------------------------------------------- -- * NamedThing instances ------------------------------------------------------------------------------- @@ -542,11 +526,6 @@ modifySessionDynFlags f = do return () --- | A variant of 'gbracket' where the return value from the first computation --- is not required. -gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c -gbracket_ before_ after thing = gbracket before_ (const after) (const thing) - -- Extract the minimal complete definition of a Name, if one exists minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef) minimalDef n = do @@ -706,10 +685,10 @@ orderedFVs vs tys = -- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type -- of 'const :: a -> b -> a': -- --- >>> import Name +-- >>> import GHC.Types.Name -- >>> import TyCoRep --- >>> import TysPrim --- >>> import Var +-- >>> import GHC.Builtin.Types.Prim +-- >>> import GHC.Types.Var -- >>> a = TyVarTy alphaTyVar -- >>> b = TyVarTy betaTyVar -- >>> constTy = mkFunTys [a, b] a @@ -728,7 +707,9 @@ tyCoFVsOfType' (TyVarTy v) a b c = (FV.unitFV v `unionFV` tyCoFVsOfType' tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c tyCoFVsOfType' (LitTy {}) a b c = emptyFV a b c tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c -tyCoFVsOfType' (FunTy _ arg res) a b c = (tyCoFVsOfType' res `unionFV` tyCoFVsOfType' arg) a b c +tyCoFVsOfType' (FunTy _ w arg res) a b c = (tyCoFVsOfType' w `unionFV` + tyCoFVsOfType' res `unionFV` + tyCoFVsOfType' arg) a b c tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty) a b c tyCoFVsOfType' (CastTy ty _) a b c = (tyCoFVsOfType' ty) a b c tyCoFVsOfType' (CoercionTy _ ) a b c = emptyFV a b c @@ -750,7 +731,7 @@ tyCoFVsBndr' (Bndr tv _) fvs = FV.delFV tv fvs `unionFV` tyCoFVsOfType' (tyVarKi ------------------------------------------------------------------------------- -- | Traverses the type, defaulting type variables of kind 'RuntimeRep' to --- 'LiftedType'. See 'defaultRuntimeRepVars' in IfaceType.hs the original such +-- 'LiftedType'. See 'defaultRuntimeRepVars' in GHC.Iface.Type the original such -- function working over `IfaceType`'s. defaultRuntimeRepVars :: Type -> Type defaultRuntimeRepVars = go emptyVarEnv @@ -774,8 +755,8 @@ defaultRuntimeRepVars = go emptyVarEnv go subs (TyConApp tc tc_args) = TyConApp tc (map (go subs) tc_args) - go subs (FunTy af arg res) - = FunTy af (go subs arg) (go subs res) + go subs (FunTy af w arg res) + = FunTy af (go subs w) (go subs arg) (go subs res) go subs (AppTy t u) = AppTy (go subs t) (go subs u) @@ -785,3 +766,4 @@ defaultRuntimeRepVars = go emptyVarEnv go _ ty@(LitTy {}) = ty go _ ty@(CoercionTy {}) = ty + |