aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/LaTeX.hs20
-rw-r--r--src/Haddock/Backends/Xhtml.hs4
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs27
-rw-r--r--src/Haddock/Convert.hs16
-rw-r--r--src/Haddock/Interface/Rename.hs27
5 files changed, 58 insertions, 36 deletions
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index d6a71f27..c6ac2b0a 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -17,7 +17,7 @@ module Haddock.Backends.LaTeX (
import Haddock.Types
import Haddock.Utils
import Haddock.GhcUtils
-import Pretty hiding (Doc)
+import Pretty hiding (Doc, quote)
import qualified Pretty
import GHC
@@ -25,7 +25,6 @@ import OccName
import Name ( isTyConName, nameOccName )
import RdrName ( rdrNameOcc, isRdrTc )
import BasicTypes ( ipNameName )
-import Outputable ( Outputable, ppr, showSDoc )
import FastString ( unpackFS, unpackLitString )
import qualified Data.Map as Map
@@ -791,10 +790,6 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
-------------------------------------------------------------------------------
-ppKind :: Outputable a => a -> LaTeX
-ppKind k = text (showSDoc (ppr k))
-
-
ppBang :: HsBang -> LaTeX
ppBang HsNoBang = empty
ppBang _ = char '!' -- Unpacked args is an implementation detail,
@@ -840,6 +835,12 @@ ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode
ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode
ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode
+ppLKind :: Bool -> LHsKind DocName -> LaTeX
+ppLKind unicode y = ppKind unicode (unLoc y)
+
+ppKind :: Bool -> HsKind DocName -> LaTeX
+ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode
+
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
@@ -868,7 +869,7 @@ ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty
ppr_mono_ty _ (HsTyVar name) _ = ppDocName name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u
ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)
-ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppKind kind)
+ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppDocName (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
@@ -876,6 +877,9 @@ ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
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 $
@@ -885,7 +889,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
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 08e2fe07..9ac4211a 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -558,10 +558,10 @@ miniSynopsis mdl iface unicode qual =
processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
-> [Html]
-processForMiniSynopsis mdl unicode _ (ExportDecl (L _loc decl0) _doc _ _insts) =
+processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts) =
((divTopDecl <<).(declElem <<)) `fmap` case decl0 of
TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
- (TyFamily{}) -> [ppTyFamHeader True False d unicode]
+ (TyFamily{}) -> [ppTyFamHeader True False d unicode qual]
(TyData{tcdTyPats = ps})
| Nothing <- ps -> [keyword "data" <+> b]
| Just _ <- ps -> [keyword "data" <+> keyword "instance" <+> b]
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index c1f3a89a..44429167 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -35,7 +35,6 @@ import Text.XHtml hiding ( name, title, p, quote )
import GHC
import Name
import BasicTypes ( ipNameName )
-import Outputable ( ppr, showSDoc, Outputable )
-- TODO: use DeclInfo DocName or something
@@ -150,8 +149,8 @@ ppTyName name
--------------------------------------------------------------------------------
-ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html
-ppTyFamHeader summary associated decl unicode =
+ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppTyFamHeader summary associated decl unicode qual =
(case tcdFlavour decl of
TypeFamily
@@ -165,7 +164,7 @@ ppTyFamHeader summary associated decl unicode =
ppTyClBinderWithVars summary decl <+>
case tcdKind decl of
- Just kind -> dcolon unicode <+> ppKind kind
+ Just kind -> dcolon unicode <+> ppLKind unicode qual kind
Nothing -> noHtml
@@ -173,13 +172,13 @@ ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
TyClDecl DocName -> Bool -> Qualification -> Html
ppTyFam summary associated links loc mbDoc decl unicode qual
- | summary = ppTyFamHeader True associated decl unicode
+ | summary = ppTyFamHeader True associated decl unicode qual
| otherwise = header_ +++ maybeDocSection qual mbDoc +++ instancesBit
where
docname = tcdName decl
- header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode)
+ header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode qual)
instancesBit = ppInstances instances docname unicode qual
@@ -635,10 +634,6 @@ ppDataHeader summary decl unicode qual
--------------------------------------------------------------------------------
-ppKind :: Outputable a => a -> Html
-ppKind k = toHtml $ showSDoc (ppr k)
-
-
ppBang :: HsBang -> Html
ppBang HsNoBang = noHtml
ppBang _ = toHtml "!" -- Unpacked args is an implementation detail,
@@ -684,6 +679,11 @@ ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual
ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual
ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual
+ppLKind :: Bool -> Qualification-> LHsKind DocName -> Html
+ppLKind unicode qual y = ppKind unicode qual (unLoc y)
+
+ppKind :: Bool -> Qualification-> HsKind DocName -> Html
+ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
@@ -713,7 +713,7 @@ ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q
ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)
ppr_mono_ty _ (HsKindSig ty kind) u q =
- parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppKind kind)
+ parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind)
ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q)
ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
ppr_mono_ty _ (HsIParamTy n ty) u q = brackets (ppDocName q (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q)
@@ -725,6 +725,9 @@ ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteT
#endif
ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy"
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 ctxt_prec (HsEqTy ty1 ty2) unicode qual
= maybeParen ctxt_prec pREC_OP $
@@ -734,7 +737,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/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index e46a37a4..ea905ed0 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -20,8 +20,7 @@ module Haddock.Convert where
import HsSyn
import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy )
import TypeRep
-import Kind ( liftedTypeKind, constraintKind )
-import Coercion ( splitKindFunTys, synTyConResKind )
+import Kind ( liftedTypeKind, constraintKind, splitKindFunTys, synTyConResKind )
import Name
import Var
import Class
@@ -103,14 +102,14 @@ synifyTyCon tc
-- tyConTyVars doesn't work on fun/prim, but we can make them up:
(zipWith
(\fakeTyVar realKind -> noLoc $
- KindedTyVar (getName fakeTyVar) realKind)
+ KindedTyVar (getName fakeTyVar) (synifyKind realKind) placeHolderKind)
alphaTyVars --a, b, c... which are unfortunately all kind *
(fst . splitKindFunTys $ tyConKind tc)
)
-- assume primitive types aren't members of data/newtype families:
Nothing
-- we have their kind accurately:
- (Just (tyConKind tc))
+ (Just (synifyKind (tyConKind tc)))
-- no algebraic constructors:
[]
-- "deriving" needn't be specified:
@@ -119,13 +118,14 @@ synifyTyCon tc
case synTyConRhs tc of
SynFamilyTyCon ->
TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
- (Just (synTyConResKind tc))
+ (Just (synifyKind (synTyConResKind tc))) -- placeHolderKind
_ -> error "synifyTyCon: impossible open type synonym?"
| isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?)
case algTyConRhs tc of
DataFamilyTyCon ->
TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
Nothing --always kind '*'
+ -- placeHolderKind
_ -> error "synifyTyCon: impossible open data type?"
| otherwise =
-- (closed) type, newtype, and data
@@ -164,7 +164,7 @@ synifyTyCon tc
syn_type = synifyType WithinType (synTyConType tc)
in if isSynTyCon tc
then TySynonym name tyvars typats syn_type
- else TyData alg_nd alg_ctx name tyvars typats alg_kindSig alg_cons alg_deriv
+ else TyData alg_nd alg_ctx name tyvars typats (fmap synifyKind alg_kindSig) alg_cons alg_deriv
-- User beware: it is your responsibility to pass True (use_gadt_syntax)
@@ -238,7 +238,7 @@ synifyTyVars = map synifyTyVar
name = getName tv
in if isLiftedTypeKind kind
then UserTyVar name placeHolderKind
- else KindedTyVar name kind
+ else KindedTyVar name (synifyKind kind) placeHolderKind
--states of what to do with foralls:
@@ -306,6 +306,8 @@ synifyType s forallty@(ForAllTy _tv _ty) =
in noLoc $
HsForAllTy forallPlicitness sTvs sCtx sTau
+synifyKind :: Kind -> LHsKind Name
+synifyKind = synifyType (error "synifyKind")
synifyInstHead :: ([TyVar], [PredType], Class, [Type]) ->
([HsType Name], Name, [HsType Name])
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 546ba62b..88e64cfa 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -211,6 +211,12 @@ renameFnArgsDoc = mapM renameDoc
renameLType :: LHsType Name -> RnM (LHsType DocName)
renameLType = mapM renameType
+renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
+renameLKind = renameLType
+
+renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))
+renameMaybeLKind Nothing = return Nothing
+renameMaybeLKind (Just ki) = renameLKind ki >>= return . Just
renameType :: HsType Name -> RnM (HsType DocName)
renameType t = case t of
@@ -240,17 +246,18 @@ renameType t = case t of
HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
- HsOpTy a (L loc op) b -> do
+ HsOpTy a (w, (L loc op)) b -> do
op' <- rename op
a' <- renameLType a
b' <- renameLType b
- return (HsOpTy a' (L loc op') b')
+ return (HsOpTy a' (w, (L loc op')) b')
HsParTy ty -> return . HsParTy =<< renameLType ty
HsKindSig ty k -> do
ty' <- renameLType ty
- return (HsKindSig ty' k)
+ k' <- renameLKind k
+ return (HsKindSig ty' k')
HsDocTy ty doc -> do
ty' <- renameLType ty
@@ -263,7 +270,8 @@ renameType t = case t of
renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
renameLTyVarBndr (L loc tv) = do
name' <- rename (hsTyVarName tv)
- return $ L loc (replaceTyVarName tv name')
+ tyvar' <- replaceTyVarName tv name' renameLKind
+ return $ L loc tyvar'
renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])
@@ -311,19 +319,24 @@ renameTyClD d = case d of
lname' <- renameL lname
return (ForeignType lname' b)
- TyFamily flav lname ltyvars kind -> do
+-- TyFamily flav lname ltyvars kind tckind -> do
+ TyFamily flav lname ltyvars tckind -> do
lname' <- renameL lname
ltyvars' <- mapM renameLTyVarBndr ltyvars
- return (TyFamily flav lname' ltyvars' kind)
+-- kind' <- renameMaybeLKind kind
+ tckind' <- renameMaybeLKind tckind
+-- return (TyFamily flav lname' ltyvars' kind' tckind)
+ return (TyFamily flav lname' ltyvars' tckind')
TyData x lcontext lname ltyvars typats k cons _ -> do
lcontext' <- renameLContext lcontext
lname' <- renameL lname
ltyvars' <- mapM renameLTyVarBndr ltyvars
typats' <- mapM (mapM renameLType) typats
+ k' <- renameMaybeLKind k
cons' <- mapM renameLCon cons
-- I don't think we need the derivings, so we return Nothing
- return (TyData x lcontext' lname' ltyvars' typats' k cons' Nothing)
+ return (TyData x lcontext' lname' ltyvars' typats' k' cons' Nothing)
TySynonym lname ltyvars typats ltype -> do
lname' <- renameL lname
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 04:52:04 +0000