aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs9
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs8
-rw-r--r--haddock-api/src/Haddock/Convert.hs43
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs24
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs12
-rw-r--r--haddock-api/src/Haddock/Utils.hs8
7 files changed, 60 insertions, 46 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 54dfb193..e73192ed 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -184,7 +184,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
name = out dflags $ map unL $ getConNames con
resType = apps $ map (reL . HsTyVar . reL) $
- (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat]
+ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat]
ppCtor dflags _dat subdocs con@ConDeclGADT {}
= concatMap (lookupCon dflags subdocs) (getConNames con) ++ f
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 223006f3..e9cc3f83 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -412,7 +412,7 @@ ppTyVars = map (ppSymName . getName . hsLTyVarName)
tyvarNames :: LHsQTyVars DocName -> [Name]
-tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs
+tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
@@ -723,7 +723,7 @@ ppSideBySideConstr subdocs unicode leader (L loc con) =
tyVars = tyvarNames (con_qvars con)
context = unLoc (con_cxt con)
- mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty)
+ mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty)
| otherwise = ty
mk_phi ty | null context = ty
| otherwise = L loc (HsQualTy (con_cxt con) ty)
@@ -955,7 +955,6 @@ ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
-ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy"
ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode
= maybeParen ctxt_prec pREC_OP $
@@ -965,7 +964,7 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
= maybeParen ctxt_prec pREC_CON $
hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]
-ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode
= maybeParen ctxt_prec pREC_FUN $
ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode
where
@@ -985,6 +984,8 @@ ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name
ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u
+ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy"
+
ppr_tylit :: HsTyLit -> Bool -> LaTeX
ppr_tylit (HsNumTy _ n) _ = integer n
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 4983aadd..0b5a3356 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -176,7 +176,7 @@ ppTyVars :: [LHsTyVarBndr DocName] -> [Html]
ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs
tyvarNames :: LHsQTyVars DocName -> [Name]
-tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs
+tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
@@ -200,7 +200,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
splice unicode qual
where
hdr = hsep ([keyword "type", ppBinder summary occ]
- ++ ppTyVars (hsQTvBndrs ltyvars))
+ ++ ppTyVars (hsQTvExplicit ltyvars))
full = hdr <+> equals <+> ppLType unicode qual ltype
occ = nameOccName . getName $ name
fixs
@@ -864,7 +864,7 @@ ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}"
ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys
-ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy"
+ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy"
ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
= maybeParen ctxt_prec pREC_CTX $
@@ -874,7 +874,7 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
= maybeParen ctxt_prec pREC_CON $
hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]
-ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual
= maybeParen ctxt_prec pREC_FUN $
ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual
where
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 8983cc77..2e28b0dd 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -28,19 +28,19 @@ import DataCon
import FamInstEnv
import Haddock.Types
import HsSyn
-import Kind ( splitKindFunTys, tyConResKind, isKind )
import Name
import RdrName ( mkVarUnqual )
import PatSyn
import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )
import TcType ( tcSplitSigmaTy )
import TyCon
-import Type (isStrLitTy, mkFunTys)
-import TypeRep
+import Type
+import TyCoRep
import TysPrim ( alphaTyVars )
-import TysWiredIn ( listTyConName, eqTyCon, ipTyCon )
+import TysWiredIn ( listTyConName, ipTyCon )
+import PrelNames ( hasKey, eqTyConKey )
import Unique ( getUnique )
-import Util ( filterByList )
+import Util ( filterByList, filterOut )
import Var
@@ -109,11 +109,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
= let name = synifyName tc
typats = map (synifyType WithinType) args
hs_rhs = synifyType WithinType rhs
- (kvs, tvs) = partition isKindVar tkvs
in TyFamEqn { tfe_tycon = name
, tfe_pats = HsIB { hsib_body = typats
- , hsib_kvs = map tyVarName kvs
- , hsib_tvs = map tyVarName tvs }
+ , hsib_vars = map tyVarName tkvs }
, tfe_rhs = hs_rhs }
synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name)
@@ -141,8 +139,8 @@ synifyTyCon _coax tc
let mk_hs_tv realKind fakeTyVar
= noLoc $ KindedTyVar (noLoc (getName fakeTyVar))
(synifyKindSig realKind)
- in HsQTvs { hsq_kvs = [] -- No kind polymorphism
- , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc)))
+ in HsQTvs { hsq_implicit = [] -- No kind polymorphism
+ , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc)))
alphaTyVars --a, b, c... which are unfortunately all kind *
}
@@ -180,11 +178,12 @@ synifyTyCon _coax tc
, fdLName = synifyName tc
, fdTyVars = synifyTyVars (tyConTyVars tc)
, fdResultSig =
- synifyFamilyResultSig resultVar (tyConResKind tc)
+ synifyFamilyResultSig resultVar tyConResKind
, fdInjectivityAnn =
synifyInjectivityAnn resultVar (tyConTyVars tc)
(familyTyConInjectivityInfo tc)
}
+ tyConResKind = piResultTys (tyConKind tc) (mkTyVarTys (tyConTyVars tc))
synifyTyCon coax tc
| Just ty <- synTyConRhs_maybe tc
@@ -292,7 +291,7 @@ synifyDataCon use_gadt_syntax dc =
(False,True) -> case linear_tys of
[a,b] -> return $ InfixCon a b
_ -> Left "synifyDataCon: infix with non-2 args?"
- gadt_ty = HsIB [] [] (synifyType WithinType res_ty)
+ gadt_ty = HsIB [] (synifyType WithinType res_ty)
-- finally we get synifyDataCon's result!
in hs_arg_tys >>=
\hat ->
@@ -321,10 +320,8 @@ synifyCtx = noLoc . map (synifyType WithinType)
synifyTyVars :: [TyVar] -> LHsQTyVars Name
-synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
- , hsq_tvs = map synifyTyVar tvs }
- where
- (kvs, tvs) = partition isKindVar ktvs
+synifyTyVars ktvs = HsQTvs { hsq_implicit = []
+ , hsq_explicit = map synifyTyVar ktvs }
synifyTyVar :: TyVar -> LHsTyVarBndr Name
synifyTyVar tv
@@ -379,19 +376,21 @@ synifyType _ (TyConApp tc tys)
, Just x <- isStrLitTy name
= noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty)
-- and equalities
- | tc == eqTyCon
+ | tc `hasKey` eqTyConKey
, [ty1, ty2] <- tys
= noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
-- Most TyCons:
| otherwise =
foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
(noLoc $ HsTyVar $ noLoc (getName tc))
- (map (synifyType WithinType) tys)
+ (map (synifyType WithinType) $
+ filterOut isCoercionTy tys)
+synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1
synifyType _ (AppTy t1 t2) = let
s1 = synifyType WithinType t1
s2 = synifyType WithinType t2
in noLoc $ HsAppTy s1 s2
-synifyType _ (FunTy t1 t2) = let
+synifyType _ (ForAllTy (Anon t1) t2) = let
s1 = synifyType WithinType t1
s2 = synifyType WithinType t2
in noLoc $ HsFunTy s1 s2
@@ -406,6 +405,8 @@ synifyType s forallty@(ForAllTy _tv _ty) =
ImplicitizeForAll -> noLoc sPhi
synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
+synifyType s (CastTy t _) = synifyType s t
+synifyType _ (CoercionTy {}) = error "synifyType:Coercion"
synifyTyLit :: TyLit -> HsTyLit
synifyTyLit (NumTyLit n) = HsNumTy mempty n
@@ -421,7 +422,7 @@ synifyInstHead (_, preds, cls, types) =
, map (unLoc . synifyType WithinType) ts
, ClassInst $ map (unLoc . synifyType WithinType) preds
)
- where (ks,ts) = break (not . isKind) types
+ where (ks,ts) = partitionInvisibles (classTyCon cls) id types
-- Convert a family instance, this could be a type family or data family
synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name)
@@ -434,4 +435,4 @@ synifyFamInst fi opaque =
synifyTyCon (Just $ famInstAxiom fi) c >>= return . DataInst
in fff >>= \f' -> return (fi_fam fi , map (unLoc . synifyType WithinType) ks,
map (unLoc . synifyType WithinType) ts , f')
- where (ks,ts) = break (not . isKind) $ fi_tys fi
+ where (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 080de6ff..86a9957c 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -22,6 +22,7 @@ import Control.Arrow hiding ((<+>))
import Data.List
import Data.Ord (comparing)
import Data.Function (on)
+import Data.Maybe ( maybeToList, mapMaybe )
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -41,7 +42,7 @@ import PrelNames
import TcRnDriver (tcRnGetInfo)
import TcType (tcSplitSigmaTy)
import TyCon
-import TypeRep
+import TyCoRep
import TysPrim( funTyCon )
import Var hiding (varName)
#define FSLIT(x) (mkFastString# (x#))
@@ -146,18 +147,26 @@ instHead (_, _, cls, args)
argCount :: Type -> Int
argCount (AppTy t _) = argCount t + 1
argCount (TyConApp _ ts) = length ts
-argCount (FunTy _ _ ) = 2
+argCount (ForAllTy (Anon _) _ ) = 2
argCount (ForAllTy _ t) = argCount t
+argCount (CastTy t _) = argCount t
argCount _ = 0
simplify :: Type -> SimpleType
+simplify (ForAllTy (Anon t1) t2) = SimpleType funTyConName [simplify t1, simplify t2]
simplify (ForAllTy _ t) = simplify t
-simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]
-simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])
+simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2))
where (SimpleType s ts) = simplify t1
simplify (TyVarTy v) = SimpleType (tyVarName v) []
-simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
+simplify (TyConApp tc ts) = SimpleType (tyConName tc)
+ (mapMaybe simplify_maybe ts)
simplify (LitTy l) = SimpleTyLit l
+simplify (CastTy ty _) = simplify ty
+simplify (CoercionTy _) = error "simplify:Coercion"
+
+simplify_maybe :: Type -> Maybe SimpleType
+simplify_maybe (CoercionTy {}) = Nothing
+simplify_maybe ty = Just (simplify ty)
-- Used for sorting
instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType)
@@ -207,9 +216,10 @@ isTypeHidden expInfo = typeHidden
TyVarTy {} -> False
AppTy t1 t2 -> typeHidden t1 || typeHidden t2
TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args
- FunTy t1 t2 -> typeHidden t1 || typeHidden t2
- ForAllTy _ ty -> typeHidden ty
+ ForAllTy bndr ty -> typeHidden (binderType bndr) || typeHidden ty
LitTy _ -> False
+ CastTy ty _ -> typeHidden ty
+ CoercionTy {} -> False
nameHidden :: Name -> Bool
nameHidden = isNameHidden expInfo
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 0b975687..845cb909 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -234,11 +234,11 @@ renameType t = case t of
HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
- HsOpTy a (w, L loc op) b -> do
+ HsOpTy a (L loc op) b -> do
op' <- rename op
a' <- renameLType a
b' <- renameLType b
- return (HsOpTy a' (w, L loc op') b')
+ return (HsOpTy a' (L loc op') b')
HsParTy ty -> return . HsParTy =<< renameLType ty
@@ -254,18 +254,18 @@ renameType t = case t of
HsTyLit x -> return (HsTyLit x)
- HsWrapTy a b -> HsWrapTy a <$> renameType b
HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a
HsCoreTy a -> pure (HsCoreTy a)
HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b
HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
+ HsAppsTy _ -> error "renameType: HsAppsTy"
renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)
-renameLHsQTyVars (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
+renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })
= do { tvs' <- mapM renameLTyVarBndr tvs
- ; return (HsQTvs { hsq_kvs = error "haddock:renameLHsQTyVars", hsq_tvs = tvs' }) }
+ ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs' }) }
-- This is rather bogus, but I'm not sure what else to do
renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
@@ -529,7 +529,7 @@ renameImplicit :: (in_thing -> RnM out_thing)
renameImplicit rn_thing (HsIB { hsib_body = thing })
= do { thing' <- rn_thing thing
; return (HsIB { hsib_body = thing'
- , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) }
+ , hsib_vars = PlaceHolder }) }
renameWc :: (in_thing -> RnM out_thing)
-> HsWildCardBndrs Name in_thing
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 45deca9c..3510d908 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -151,7 +151,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name]
lHsQTyVarsToTypes tvs
= [ noLoc (HsTyVar (noLoc (hsLTyVarName tv)))
- | tv <- hsQTvBndrs tvs ]
+ | tv <- hsQTvExplicit tvs ]
--------------------------------------------------------------------------------
-- * Making abstract declarations
@@ -200,7 +200,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
c' :: ConDecl Name
c' = ConDeclH98
{ con_name = head (con_names c)
- , con_qvars = Just $ HsQTvs { hsq_kvs = mempty, hsq_tvs = tvs }
+ , con_qvars = Just $ HsQTvs { hsq_implicit = mempty
+ , hsq_explicit = tvs }
, con_cxt = Just cxt
, con_details = details
, con_doc = con_doc c
@@ -224,7 +225,8 @@ emptyHsQTvs :: LHsQTyVars Name
-- This function is here, rather than in HsTypes, because it *renamed*, but
-- does not necessarily have all the rigt kind variables. It is used
-- in Haddock just for printing, so it doesn't matter
-emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] }
+emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs"
+ , hsq_explicit = [] }
--------------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-16 04:25:36 +0000