aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs16
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs23
-rw-r--r--haddock-api/src/Haddock/Convert.hs169
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs8
-rw-r--r--haddock-api/src/Haddock/Types.hs5
6 files changed, 148 insertions, 75 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 1cc23e6e..d79e0e6c 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -553,7 +553,7 @@ ppInstHead unicode (InstHead {..}) = case ihdInstType of
TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs
DataInst _ -> error "data instances not supported by --latex yet"
where
- typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode
+ typ = ppAppNameTypes ihdClsName ihdTypes unicode
tibody = maybe empty (\t -> equals <+> ppType unicode t)
lookupAnySubdoc :: (Eq name1) =>
@@ -831,27 +831,27 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument"
--------------------------------------------------------------------------------
--- | Print an application of a DocName and two lists of HsTypes (kinds, types)
-ppAppNameTypes :: DocName -> [HsType DocNameI] -> [HsType DocNameI] -> Bool -> LaTeX
-ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode)
+-- | Print an application of a DocName to its list of HsTypes
+ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX
+ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)
-- | Print an application of a DocName and a list of Names
ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX
ppAppDocNameNames _summ n ns =
- ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName
+ ppTypeApp n ns (ppBinder . nameOccName . getName) ppSymName
-- | General printing of type applications
-ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX
-ppTypeApp n [] (t1:t2:rest) ppDN ppT
+ppTypeApp :: DocName -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX
+ppTypeApp n (t1:t2:rest) ppDN ppT
| operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
| operator = opApp
where
operator = isNameSym . getName $ n
opApp = ppT t1 <+> ppDN n <+> ppT t2
-ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts)
+ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 3b53b1eb..3b85f96c 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -286,7 +286,7 @@ ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI
-> Html
ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =
ppFamilyInfo True pfdInfo <+>
- ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+>
+ ppAppNameTypes (unLoc pfdLName) (map unLoc pfdTyVars) unicode qual <+>
ppResultSig (unLoc pfdKindSig) unicode qual
ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocNameI -> Html
@@ -321,7 +321,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl
ppTyFamEqn (HsIB { hsib_body = FamEqn { feqn_tycon = n, feqn_rhs = rhs
, feqn_pats = ts } })
- = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
+ = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual
<+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
, Nothing, [] )
@@ -368,29 +368,28 @@ ppDataBinderWithVars summ unicode qual decl =
ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html
ppAppDocNameTyVarBndrs summ unicode qual n vs =
- ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual . unLoc)
+ ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc)
where
ppDN notation = ppBinderFixity notation summ . nameOccName . getName
ppBinderFixity Infix = ppBinderInfix
ppBinderFixity _ = ppBinder
--- | Print an application of a 'DocName' and two lists of 'HsTypes' (kinds, types)
-ppAppNameTypes :: DocName -> [HsType DocNameI] -> [HsType DocNameI]
- -> Unicode -> Qualification -> Html
-ppAppNameTypes n ks ts unicode qual =
- ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts)
+-- | Print an application of a 'DocName' to its list of 'HsType's
+ppAppNameTypes :: DocName -> [HsType DocNameI] -> Unicode -> Qualification -> Html
+ppAppNameTypes n ts unicode qual =
+ ppTypeApp n ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts)
-- | General printing of type applications
-ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
-ppTypeApp n [] (t1:t2:rest) ppDN ppT
+ppTypeApp :: DocName -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
+ppTypeApp n (t1:t2:rest) ppDN ppT
| operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
| operator = opApp
where
operator = isNameSym . getName $ n
opApp = ppT t1 <+> ppDN Infix n <+> ppT t2
-ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)
+ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
@@ -621,7 +620,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
where
iid = instanceId origin no orphan ihd
- typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
+ typ = ppAppNameTypes ihdClsName ihdTypes unicode qual
ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 67aa88e1..325d9cf6 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -25,6 +25,7 @@ import ConLike
import Data.Either (lefts, rights)
import DataCon
import FamInstEnv
+import FV
import HsSyn
import Name
import NameSet ( emptyNameSet )
@@ -37,11 +38,12 @@ import Type
import TyCoRep
import TysPrim ( alphaTyVars )
import TysWiredIn ( listTyConName, starKindTyConName, unitTy )
-import PrelNames ( hasKey, eqTyConKey, ipClassKey
+import PrelNames ( hasKey, eqTyConKey, funTyConKey, ipClassKey
, tYPETyConKey, liftedRepDataConKey )
import Unique ( getUnique )
-import Util ( filterByList, filterOut )
+import Util ( compareLength, filterByList, filterOut, splitAtList )
import Var
+import VarSet
import Haddock.Types
import Haddock.Interface.Specialize
@@ -77,7 +79,7 @@ tyThingToLHsDecl t = case t of
in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl
{ tcdCtxt = synifyCtx (classSCTheta cl)
, tcdLName = synifyName cl
- , tcdTyVars = synifyTyVars (classTyVars cl)
+ , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl))
, tcdFixity = Prefix
, tcdFDs = map (\ (l,r) -> noLoc
(map (noLoc . getName) l, map (noLoc . getName) r) ) $
@@ -110,15 +112,20 @@ tyThingToLHsDecl t = case t of
synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn
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
+ = let name = synifyName tc
+ args_types_only = filterOutInvisibleTypes tc args
+ typats = map (synifyType WithinType) args_types_only
+ annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)
+ args_types_only typats
+ hs_rhs = synifyType WithinType rhs
in HsIB { hsib_vars = map tyVarName tkvs
, hsib_closed = True
, hsib_body = FamEqn { feqn_tycon = name
- , feqn_pats = typats
+ , feqn_pats = annot_typats
, feqn_fixity = Prefix
, feqn_rhs = hs_rhs } }
+ where
+ fam_tvs = tyConVisibleTyVars tc
synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn)
synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
@@ -185,7 +192,7 @@ synifyTyCon _coax tc
mkFamDecl i = return $ FamDecl $
FamilyDecl { fdInfo = i
, fdLName = synifyName tc
- , fdTyVars = synifyTyVars (tyConTyVars tc)
+ , fdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, fdFixity = Prefix
, fdResultSig =
synifyFamilyResultSig resultVar (tyConResKind tc)
@@ -197,7 +204,7 @@ synifyTyCon _coax tc
synifyTyCon coax tc
| Just ty <- synTyConRhs_maybe tc
= return $ SynDecl { tcdLName = synifyName tc
- , tcdTyVars = synifyTyVars (tyConTyVars tc)
+ , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, tcdFixity = Prefix
, tcdRhs = synifyType WithinType ty
, tcdFVs = placeHolderNamesTc }
@@ -210,7 +217,7 @@ synifyTyCon coax tc
Just a -> synifyName a -- Data families are named according to their
-- CoAxioms, not their TyCons
_ -> synifyName tc
- tyvars = synifyTyVars (tyConTyVars tc)
+ tyvars = synifyTyVars (tyConVisibleTyVars tc)
kindSig = Just (tyConKind tc)
-- The data constructors.
--
@@ -345,6 +352,33 @@ synifyTyVar tv
kind = tyVarKind tv
name = getName tv
+-- | Annotate (with HsKingSig) a type if the first parameter is True
+-- and if the type contains a free variable.
+-- This is used to synify type patterns for poly-kinded tyvars in
+-- synifying class and type instances.
+annotHsType :: Bool -- True <=> annotate
+ -> Type -> LHsType GhcRn -> LHsType GhcRn
+ -- tiny optimization: if the type is annotated, don't annotate again.
+annotHsType _ _ hs_ty@(L _ (HsKindSig {})) = hs_ty
+annotHsType True ty hs_ty
+ | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
+ = let ki = typeKind ty
+ hs_ki = synifyType WithinType ki
+ in noLoc (HsKindSig hs_ty hs_ki)
+annotHsType _ _ hs_ty = hs_ty
+
+-- | For every type variable in the input,
+-- report whether or not the tv is poly-kinded. This is used to eventually
+-- feed into 'annotHsType'.
+mkIsPolyTvs :: [TyVar] -> [Bool]
+mkIsPolyTvs = map is_poly_tv
+ where
+ is_poly_tv tv = not $
+ isEmptyVarSet $
+ filterVarSet isTyVar $
+ tyCoVarsOfType $
+ tyVarKind tv
+
--states of what to do with foralls:
data SynifyTypeState
= WithinType
@@ -377,37 +411,68 @@ synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)
synifyType :: SynifyTypeState -> Type -> LHsType GhcRn
synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv)
synifyType _ (TyConApp tc tys)
- -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)
- | tc `hasKey` tYPETyConKey
- , [TyConApp lev []] <- tys
- , lev `hasKey` liftedRepDataConKey
- = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName))
- -- Use non-prefix tuple syntax where possible, because it looks nicer.
- | Just sort <- tyConTuple_maybe tc
- , tyConArity tc == length tys
- = noLoc $ HsTupleTy (case sort of
- BoxedTuple -> HsBoxedTuple
- ConstraintTuple -> HsConstraintTuple
- UnboxedTuple -> HsUnboxedTuple)
- (map (synifyType WithinType) tys)
- -- ditto for lists
- | getName tc == listTyConName, [ty] <- tys =
- noLoc $ HsListTy (synifyType WithinType ty)
- -- ditto for implicit parameter tycons
- | tc `hasKey` ipClassKey
- , [name, ty] <- tys
- , Just x <- isStrLitTy name
- = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty)
- -- and equalities
- | 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 NotPromoted $ noLoc (getName tc))
- (map (synifyType WithinType) $
- filterOut isCoercionTy tys)
+ = maybe_sig res_ty
+ where
+ res_ty :: LHsType GhcRn
+ res_ty
+ -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)
+ | tc `hasKey` tYPETyConKey
+ , [TyConApp lev []] <- tys
+ , lev `hasKey` liftedRepDataConKey
+ = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName))
+ -- Use non-prefix tuple syntax where possible, because it looks nicer.
+ | Just sort <- tyConTuple_maybe tc
+ , tyConArity tc == length tys
+ = noLoc $ HsTupleTy (case sort of
+ BoxedTuple -> HsBoxedTuple
+ ConstraintTuple -> HsConstraintTuple
+ UnboxedTuple -> HsUnboxedTuple)
+ (map (synifyType WithinType) vis_tys)
+ -- ditto for lists
+ | getName tc == listTyConName, [ty] <- tys =
+ noLoc $ HsListTy (synifyType WithinType ty)
+ -- ditto for implicit parameter tycons
+ | tc `hasKey` ipClassKey
+ , [name, ty] <- tys
+ , Just x <- isStrLitTy name
+ = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty)
+ -- and equalities
+ | 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 NotPromoted $ noLoc (getName tc))
+ (map (synifyType WithinType) $
+ filterOut isCoercionTy vis_tys)
+
+ vis_tys = filterOutInvisibleTypes tc tys
+ binders = tyConBinders tc
+ res_kind = tyConResKind tc
+
+ maybe_sig :: LHsType GhcRn -> LHsType GhcRn
+ maybe_sig ty'
+ | needs_kind_sig
+ = let full_kind = typeKind (mkTyConApp tc tys)
+ full_kind' = synifyType WithinType full_kind
+ in noLoc $ HsKindSig ty' full_kind'
+ | otherwise = ty'
+
+ needs_kind_sig :: Bool
+ needs_kind_sig
+ | GT <- compareLength tys binders
+ = False
+ | otherwise
+ = let (dropped_binders, remaining_binders)
+ = splitAtList tys binders
+ result_kind = mkTyConKind remaining_binders res_kind
+ result_vars = tyCoVarsOfType result_kind
+ dropped_vars = fvVarSet $
+ mapUnionFV injectiveVarsOfBinder dropped_binders
+
+ in not (subVarSet result_vars dropped_vars)
+
synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1
synifyType _ (AppTy t1 t2) = let
s1 = synifyType WithinType t1
@@ -457,11 +522,10 @@ synifyKindSig k = synifyType WithinType k
synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn
synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
{ ihdClsName = getName cls
- , ihdKinds = map (unLoc . synifyType WithinType) ks
- , ihdTypes = map (unLoc . synifyType WithinType) ts
+ , ihdTypes = map unLoc annot_ts
, ihdInstType = ClassInst
{ clsiCtx = map (unLoc . synifyType WithinType) preds
- , clsiTyVars = synifyTyVars $ classTyVars cls
+ , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon)
, clsiSigs = map synifyClsIdSig $ classMethods cls
, clsiAssocTys = do
(Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls
@@ -469,7 +533,11 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
}
}
where
- (ks,ts) = partitionInvisibles (classTyCon cls) id types
+ cls_tycon = classTyCon cls
+ ts = filterOutInvisibleTypes cls_tycon types
+ ts' = map (synifyType WithinType) ts
+ annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'
+ is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon)
synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification
-- Convert a family instance, this could be a type family or data family
@@ -478,8 +546,7 @@ synifyFamInst fi opaque = do
ityp' <- ityp $ fi_flavor fi
return InstHead
{ ihdClsName = fi_fam fi
- , ihdKinds = synifyTypes ks
- , ihdTypes = synifyTypes ts
+ , ihdTypes = map unLoc annot_ts
, ihdInstType = ityp'
}
where
@@ -488,5 +555,9 @@ synifyFamInst fi opaque = do
return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
ityp (DataFamilyInst c) =
DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c
- (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi
- synifyTypes = map (unLoc. synifyType WithinType)
+ fam_tc = famInstTyCon fi
+ ts = filterOutInvisibleTypes fam_tc $ fi_tys fi
+ synifyTypes = map (synifyType WithinType)
+ ts' = synifyTypes ts
+ annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'
+ is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 70962d9c..7023a908 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -294,7 +294,6 @@ renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename na
renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI)
renameInstHead InstHead {..} = do
cname <- rename ihdClsName
- kinds <- mapM renameType ihdKinds
types <- mapM renameType ihdTypes
itype <- case ihdInstType of
ClassInst { .. } -> ClassInst
@@ -306,7 +305,6 @@ renameInstHead InstHead {..} = do
DataInst dd -> DataInst <$> renameTyClD dd
return InstHead
{ ihdClsName = cname
- , ihdKinds = kinds
, ihdTypes = types
, ihdInstType = itype
}
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 0c8e89c2..6d2888d3 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -34,7 +34,13 @@ specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name)
specialize specs = go
where
go :: forall x. Data x => x -> x
- go = everywhereButType @name $ mkT $ sugar . specialize_ty_var
+ go = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var
+
+ strip_kind_sig :: HsType name -> HsType name
+ strip_kind_sig (HsKindSig (L _ t) _) = t
+ strip_kind_sig typ = typ
+
+ specialize_ty_var :: HsType name -> HsType name
specialize_ty_var (HsTyVar _ (L _ name'))
| Just t <- Map.lookup name' spec_map = t
specialize_ty_var typ = typ
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 188611a0..b4cdc343 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -390,11 +390,10 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
-- | An instance head that may have documentation and a source location.
type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name))
--- | The head of an instance. Consists of a class name, a list of kind
--- parameters, a list of type parameters and an instance type
+-- | The head of an instance. Consists of a class name, a list of type
+-- parameters (which may be annotated with kinds), and an instance type
data InstHead name = InstHead
{ ihdClsName :: IdP name
- , ihdKinds :: [HsType name]
, ihdTypes :: [HsType name]
, ihdInstType :: InstType name
}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 09:22:56 +0000