From bc5756d062bbc5cad5d4fa60798435ed020c518e Mon Sep 17 00:00:00 2001
From: nand <git@nand.wakku.to>
Date: Tue, 11 Feb 2014 11:52:48 +0100
Subject: Improve display of poly-kinded type operators
This now displays them as (==) k a b c ... to mirror GHC's behavior,
instead of the old (k == a) b c ... which was just wrong.
Signed-off-by: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
---
src/Haddock/Backends/LaTeX.hs | 22 +++++++++++-----------
src/Haddock/Backends/Xhtml.hs | 2 +-
src/Haddock/Backends/Xhtml/Decl.hs | 30 +++++++++++++++---------------
3 files changed, 27 insertions(+), 27 deletions(-)
(limited to 'src/Haddock/Backends')
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 2185340b..24e8b7c8 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -560,10 +560,10 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
ppInstHead :: Bool -> InstHead DocName -> LaTeX
-ppInstHead unicode (n, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ts unicode
-ppInstHead unicode (n, ts, TypeInst rhs) = keyword "type"
- <+> ppAppNameTypes n ts unicode <+> equals <+> ppType unicode rhs
-ppInstHead _unicode (_n, _ts, DataInst _dd) =
+ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode
+ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type"
+ <+> ppAppNameTypes n ks ts unicode <+> equals <+> ppType unicode rhs
+ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) =
error "data instances not supported by --latex yet"
lookupAnySubdoc :: (Eq name1) =>
@@ -749,27 +749,27 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument"
--------------------------------------------------------------------------------
--- | Print an application of a DocName and a list of HsTypes
-ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> LaTeX
-ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)
+-- | Print an application of a DocName and two lists of HsTypes (kinds, types)
+ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX
+ppAppNameTypes n ks ts unicode = ppTypeApp n ks 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] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX
-ppTypeApp n (t1:t2:rest) ppDN ppT
+ppTypeApp :: DocName -> [a] -> [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 ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
+ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts)
-------------------------------------------------------------------------------
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 53b106a2..77ff35b2 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -605,7 +605,7 @@ ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
ppTyClBinderWithVarsMini mdl decl =
let n = tcdName decl
ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above
- in ppTypeApp n ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName
+ in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName
ppModuleContents :: Qualification -> [ExportItem DocName] -> Html
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 9180c3c3..85eee248 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -235,7 +235,7 @@ ppTyFam summary associated links instances loc doc decl unicode qual
-- Individual equation of a closed type family
ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs
, tfie_pats = HsWB { hswb_cts = ts }}
- = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual
+ = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
<+> equals <+> ppType unicode qual (unLoc rhs)
, Nothing, [] )
@@ -270,31 +270,31 @@ ppDataBinderWithVars summ decl =
--------------------------------------------------------------------------------
--- | Print an application of a DocName and a list of HsTypes
-ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Qualification -> Html
-ppAppNameTypes n ts unicode qual =
- ppTypeApp n ts (ppDocName qual . Just) (ppParendType unicode qual)
+-- | Print an application of a DocName and two lists of HsTypes (kinds, types)
+ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> Qualification -> Html
+ppAppNameTypes n ks ts unicode qual =
+ ppTypeApp n ks ts (ppDocName qual . Just) (ppParendType unicode qual)
-- | Print an application of a DocName and a list of Names
ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html
ppAppDocNameNames summ n ns =
- ppTypeApp n ns ppDN ppTyName
+ ppTypeApp n [] ns ppDN ppTyName
where
ppDN is_infix = ppBinderFixity is_infix summ . nameOccName . getName
ppBinderFixity True = ppBinderInfix
ppBinderFixity False = ppBinder
-- | General printing of type applications
-ppTypeApp :: DocName -> [a] -> (Bool -> DocName -> Html) -> (a -> Html) -> Html
-ppTypeApp n (t1:t2:rest) ppDN ppT
+ppTypeApp :: DocName -> [a] -> [a] -> (Bool -> 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 True n <+> ppT t2
-ppTypeApp n ts ppDN ppT = ppDN False n <+> hsep (map ppT ts)
+ppTypeApp n ks ts ppDN ppT = ppDN False n <+> hsep (map ppT $ ks ++ ts)
-------------------------------------------------------------------------------
@@ -426,13 +426,13 @@ ppInstances instances baseName unicode qual
instName = getOccString $ getName baseName
instDecl :: DocInstance DocName -> SubDecl
instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
- instHead (n, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
- <+> ppAppNameTypes n ts unicode qual
- instHead (n, ts, TypeInst rhs) = keyword "type"
- <+> ppAppNameTypes n ts unicode qual
+ instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
+ <+> ppAppNameTypes n ks ts unicode qual
+ instHead (n, ks, ts, TypeInst rhs) = keyword "type"
+ <+> ppAppNameTypes n ks ts unicode qual
<+> equals <+> ppType unicode qual rhs
- instHead (n, ts, DataInst dd) = keyword "data"
- <+> ppAppNameTypes n ts unicode qual
+ instHead (n, ks, ts, DataInst dd) = keyword "data"
+ <+> ppAppNameTypes n ks ts unicode qual
<+> ppShortDataDecl False True dd unicode qual
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
--
cgit v1.2.3