aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorDavid Waern <davve@dtek.chalmers.se>2007-12-08 17:27:46 +0000
committerDavid Waern <davve@dtek.chalmers.se>2007-12-08 17:27:46 +0000
commit689ec13473c62085346ef38baf3f70d2d7c94df0 (patch)
treedc4957855b65f78247f4950aa47ef57e7cf83eb7 /src
parentbef29ab118174e4b172495bcfd2171a1cb7eb7e4 (diff)
Fix rendering of class operators
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Html.hs68
1 files changed, 26 insertions, 42 deletions
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index 4d377995..821d4ddf 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -751,18 +751,30 @@ ppTyNames = map ppTyName
--------------------------------------------------------------------------------
-- Type applications
--- Ocurring in contexts and instance heads
--------------------------------------------------------------------------------
-ppTypeApp n ts@(t1:t2:rest)
- | operator, not . null $ rest = parens opApp <+> ppParendTypes rest
+-- | Print an application of a DocName and a list of HsTypes
+ppAppNameTypes :: DocName -> [HsType DocName] -> Html
+ppAppNameTypes n ts = ppTypeApp n ts ppDocName ppParendType
+
+
+-- | Print an application of a DocName and a list of Names
+ppDataClassHead :: Bool -> DocName -> [Name] -> Html
+ppDataClassHead summ n ns =
+ ppTypeApp n ns (ppBinder summ . getName) ppName
+
+
+-- | General printing of type applications
+ppTypeApp :: DocName -> [a] -> (DocName -> Html) -> (a -> Html) -> Html
+ppTypeApp n ts@(t1:t2:rest) ppDN ppT
+ | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
| operator = opApp
where
operator = isNameSym . getName $ n
- opApp = ppParendType t1 <+> ppDocName n <+> ppParendType t2
+ opApp = ppT t1 <+> ppDN n <+> ppT t2
-ppTypeApp n ts = ppDocName n <+> ppParendTypes ts
+ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
--------------------------------------------------------------------------------
@@ -790,7 +802,7 @@ pp_hs_context cxt = parenList (map ppPred cxt)
ppLPred = ppPred . unLoc
-ppPred (HsClassP n ts) = ppTypeApp n (map unLoc ts)
+ppPred (HsClassP n ts) = ppAppNameTypes n (map unLoc ts)
-- TODO: find out what happened to the Dupable/Linear distinction
ppPred (HsEqualP t1 t2) = ppLType t1 <+> toHtml "~" <+> ppLType t2
ppPred (HsIParam (IPName n) t)
@@ -800,13 +812,10 @@ ppPred (HsIParam (IPName n) t)
-- -----------------------------------------------------------------------------
-- Class declarations
-ppClassHdr summ (L _ []) n tvs fds =
- keyword "class"
- <+> ppBinder summ n <+> hsep (ppTyVars tvs)
- <+> ppFds fds
ppClassHdr summ lctxt n tvs fds =
- keyword "class" <+> ppLContext lctxt
- <+> ppBinder summ n <+> hsep (ppTyVars tvs)
+ keyword "class"
+ <+> (if not . null . unLoc $ lctxt then ppLContext lctxt else empty)
+ <+> ppDataClassHead summ n (tyvarNames $ tvs)
<+> ppFds fds
ppFds fds =
@@ -830,7 +839,7 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc
, let mbDoc = Map.lookup n docMap ])
)
where
- hdr = ppClassHdr summary lctxt nm tvs fds
+ hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds
NoLink nm = unLoc lname
ppAT summary at = case at of
@@ -857,7 +866,7 @@ ppClassDecl summary links instances orig_c loc mbDoc docMap
NoLink nm = unLoc lname
ctxt = unLoc lctxt
- hdr = ppClassHdr summary lctxt nm ltyvars lfds
+ hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
classdoc = case mbDoc of
Nothing -> Html.emptyTable
@@ -885,8 +894,8 @@ ppClassDecl summary links instances orig_c loc mbDoc docMap
))
ppInstHead :: InstHead DocName -> Html
-ppInstHead ([], n, ts) = ppTypeApp n ts
-ppInstHead (ctxt, n, ts) = ppContextNoLocs ctxt <+> ppTypeApp n ts
+ppInstHead ([], n, ts) = ppAppNameTypes n ts
+ppInstHead (ctxt, n, ts) = ppContextNoLocs ctxt <+> ppAppNameTypes n ts
-- -----------------------------------------------------------------------------
@@ -1148,32 +1157,7 @@ ppDataHeader summary decl
-- context
ppLContext (tcdCtxt decl) <+>
-- T a b c ..., or a :+: b
- ppDataHead summary (orig $ tcdLName decl) (tyvarNames $ tcdTyVars decl)
-
-
--- | data context => ... =
--- ^ Print this part of a data\/newtype declaration
-ppDataHead :: Bool -> Name -> [Name] -> Html
-ppDataHead summary name tyvars
-
- -- (a :+: b) c d
- | isNameConSym name && length tyvars > 2 = parens first2 <+> rest
-
- -- a :+: b
- | isNameConSym name = first2
-
- -- Would like a case for:
- -- a `O` b
- -- and (a `O` b) c
- -- but GHC doesn't keep this information
-
- -- T a b c
- | otherwise = ppBinder summary name <+> hsep (ppTyNames tyvars)
-
- where
- first2 = ppTyName a <+> ppBinder summary name <+> ppTyName b
- rest = hsep $ ppTyNames restTypes
- a:b:restTypes = tyvars
+ ppDataClassHead summary (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)
-- ----------------------------------------------------------------------------