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.hs114
1 files changed, 68 insertions, 46 deletions
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 5cc005cc..6577e08f 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -21,7 +21,7 @@ module Haddock.GhcUtils where
import Control.Arrow
import Data.Char ( isSpace )
-import Haddock.Types( DocNameI )
+import Haddock.Types( DocName, DocNameI )
import Exception
import FV
@@ -38,7 +38,8 @@ import Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind,
isInvisibleArgFlag )
import VarSet ( VarSet, emptyVarSet )
import VarEnv ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )
-import TyCoRep ( Type(..), isRuntimeRepVar )
+import TyCoRep ( Type(..) )
+import Type ( isRuntimeRepVar )
import TysWiredIn( liftedRepDataConTyCon )
import StringBuffer ( StringBuffer )
@@ -48,7 +49,6 @@ import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
-
moduleString :: Module -> String
moduleString = moduleNameString . moduleName
@@ -70,7 +70,7 @@ 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 name -> SrcSpan
+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
@@ -79,12 +79,12 @@ getInstLoc (TyFamInstD _ (TyFamInstDecl
-- 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 _)) = panic "getInstLoc"
-getInstLoc (DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc"
-getInstLoc (TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc"
-getInstLoc (XInstDecl _) = panic "getInstLoc"
-getInstLoc (DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc"
-getInstLoc (TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc"
+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
@@ -101,20 +101,20 @@ filterSigNames p orig@(InlineSig _ n _) = ifTrueJust (p $ unLoc n) orig
filterSigNames p (FixSig _ (FixitySig _ ns ty)) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (FixSig noExt (FixitySig noExt filtered ty))
+ filtered -> Just (FixSig noExtField (FixitySig noExtField filtered ty))
filterSigNames _ orig@(MinimalSig _ _ _) = Just orig
filterSigNames p (TypeSig _ ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (TypeSig noExt filtered ty)
+ filtered -> Just (TypeSig noExtField filtered ty)
filterSigNames p (ClassOpSig _ is_default ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (ClassOpSig noExt is_default filtered ty)
+ filtered -> Just (ClassOpSig noExtField is_default filtered ty)
filterSigNames p (PatSynSig _ ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (PatSynSig noExt filtered ty)
+ filtered -> Just (PatSynSig noExtField filtered ty)
filterSigNames _ _ = Nothing
ifTrueJust :: Bool -> name -> Maybe name
@@ -135,10 +135,10 @@ 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 (L _ (TypeSig {})) = True
+isUserLSig (L _ (ClassOpSig {})) = True
+isUserLSig (L _ (PatSynSig {})) = True
+isUserLSig _ = False
isClassD :: HsDecl a -> Bool
@@ -165,8 +165,28 @@ nubByName f ns = go emptyNameSet ns
-- ---------------------------------------------------------------------
--- This function is duplicated as getGADTConType and getGADTConTypeG,
--- as I can't get the types to line up otherwise. AZ.
+-- These functions are duplicated from the GHC API, as they must be
+-- instantiated at DocNameI instead of (GhcPass _).
+
+hsTyVarNameI :: HsTyVarBndr DocNameI -> DocName
+hsTyVarNameI (UserTyVar _ (L _ n)) = n
+hsTyVarNameI (KindedTyVar _ (L _ n) _) = n
+hsTyVarNameI (XTyVarBndr nec) = noExtCon nec
+
+hsLTyVarNameI :: LHsTyVarBndr 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
getGADTConType :: ConDecl DocNameI -> LHsType DocNameI
-- The full type of a GADT data constructor We really only get this in
@@ -177,26 +197,27 @@ 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_xforall = NoExt
+ | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis
+ , hst_xforall = noExtField
, hst_bndrs = hsQTvExplicit qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
where
theta_ty | Just theta <- mcxt
- = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty })
+ = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
| otherwise
= tau_ty
tau_ty = case args of
- RecCon flds -> noLoc (HsFunTy noExt (noLoc (HsRecTy noExt (unLoc flds))) res_ty)
+ 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)
- mkFunTy a b = noLoc (HsFunTy noExt a b)
+ mkFunTy a b = noLoc (HsFunTy noExtField a b)
getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
-- Should only be called on ConDeclGADT
-getGADTConType (XConDecl {}) = panic "getGADTConType"
+getGADTConType (XConDecl nec) = noExtCon nec
-- -------------------------------------
@@ -209,26 +230,27 @@ 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 = NoExt
+ | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis
+ , hst_xforall = noExtField
, hst_bndrs = hsQTvExplicit qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
where
theta_ty | Just theta <- mcxt
- = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty })
+ = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
| otherwise
= tau_ty
tau_ty = case args of
- RecCon flds -> noLoc (HsFunTy noExt (noLoc (HsRecTy noExt (unLoc flds))) res_ty)
+ 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)
- mkFunTy a b = noLoc (HsFunTy noExt a b)
+ mkFunTy a b = noLoc (HsFunTy noExtField a b)
getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"
-- Should only be called on ConDeclGADT
-getGADTConTypeG (XConDecl {}) = panic "getGADTConTypeG"
+getGADTConTypeG (XConDecl nec) = noExtCon nec
-------------------------------------------------------------------------------
@@ -258,12 +280,12 @@ 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 ~ NoExt) => Precedence -> HsType a -> HsType a
+reparenTypePrec :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a
reparenTypePrec = go
where
-- Shorter name for 'reparenType'
- go :: (XParTy a ~ NoExt) => Precedence -> HsType a -> HsType a
+ go :: (XParTy a ~ NoExtField) => 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)
@@ -276,8 +298,8 @@ 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 tvs ty)
- = paren p PREC_CTX $ HsForAllTy x (map (fmap reparenTyVar) tvs) (reparenLType ty)
+ go p (HsForAllTy x fvf tvs ty)
+ = paren p PREC_CTX $ HsForAllTy x fvf (map (fmap reparenTyVar) tvs) (reparenLType ty)
go p (HsQualTy x ctxt ty)
= let p' [_] = PREC_CTX
p' _ = PREC_TOP -- parens will get added anyways later...
@@ -299,34 +321,34 @@ reparenTypePrec = go
go _ t@XHsType{} = t
-- Located variant of 'go'
- goL :: (XParTy a ~ NoExt) => Precedence -> LHsType a -> LHsType a
+ goL :: (XParTy a ~ NoExtField) => Precedence -> LHsType a -> LHsType a
goL ctxt_prec = fmap (go ctxt_prec)
-- Optionally wrap a type in parens
- paren :: (XParTy a ~ NoExt)
+ paren :: (XParTy a ~ NoExtField)
=> 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 NoExt . noLoc
+ paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . noLoc
| otherwise = id
-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')
-reparenType :: (XParTy a ~ NoExt) => HsType a -> HsType a
+reparenType :: (XParTy a ~ NoExtField) => HsType a -> HsType a
reparenType = reparenTypePrec PREC_TOP
-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')
-reparenLType :: (XParTy a ~ NoExt) => LHsType a -> LHsType a
+reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType = fmap reparenType
-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
-reparenTyVar :: (XParTy a ~ NoExt) => HsTyVarBndr a -> HsTyVarBndr a
+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 v@XTyVarBndr{} = v
-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
-reparenConDeclField :: (XParTy a ~ NoExt) => ConDeclField a -> ConDeclField a
+reparenConDeclField :: (XParTy a ~ NoExtField) => ConDeclField a -> ConDeclField a
reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d
reparenConDeclField c@XConDeclField{} = c
@@ -568,7 +590,7 @@ tryCppLine !loc !buf = spanSpace (S.prevChar buf '\n' == '\n') loc buf
-- | Get free type variables in a 'Type' in their order of appearance.
-- See [Ordering of implicit variables].
orderedFVs
- :: VarSet -- ^ free variables to ignore
+ :: VarSet -- ^ free variables to ignore
-> [Type] -- ^ types to traverse (in order) looking for free variables
-> [TyVar] -- ^ free type variables, in the order they appear in
orderedFVs vs tys =
@@ -582,7 +604,7 @@ orderedFVs vs tys =
-- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type
-- of 'const :: a -> b -> a':
--
--- >>> import Name
+-- >>> import Name
-- >>> import TyCoRep
-- >>> import TysPrim
-- >>> import Var
@@ -604,7 +626,7 @@ 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 _ arg res) a b c = (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
@@ -650,8 +672,8 @@ defaultRuntimeRepVars = go emptyVarEnv
go subs (TyConApp tc tc_args)
= TyConApp tc (map (go subs) tc_args)
- go subs (FunTy arg res)
- = FunTy (go subs arg) (go subs res)
+ go subs (FunTy af arg res)
+ = FunTy af (go subs arg) (go subs res)
go subs (AppTy t u)
= AppTy (go subs t) (go subs u)
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-26 14:22:53 +0000