From d52487d1417080d45a800b1ceba71ed48b9582bb Mon Sep 17 00:00:00 2001
From: Mark Lentczner <markl@glyphic.com>
Date: Fri, 16 Jul 2010 20:12:39 +0000
Subject: new output for mini_ pages

---
 src/Haddock/Backends/Xhtml.hs        | 48 ++++++++++++++----------------------
 src/Haddock/Backends/Xhtml/Layout.hs |  5 ++++
 2 files changed, 24 insertions(+), 29 deletions(-)

(limited to 'src/Haddock')

diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index e204a9da..e3f28824 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -597,9 +597,8 @@ ppHtmlModuleMiniSynopsis odir _doctitle iface unicode = do
            thetitle (toHtml $ moduleString mdl) +++
            styleSheet +++
            (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
-        body << thediv ! [ theclass "outer" ] << (
-           (thediv ! [theclass "mini-topbar"]
-             << toHtml (moduleString mdl)) +++
+        miniBody << 
+          (divModuleHeader << sectionName << moduleString mdl +++
            miniSynopsis mdl iface unicode)
   createDirectoryIfMissing True odir
   writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString html)
@@ -654,38 +653,29 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode
 
 miniSynopsis :: Module -> Interface -> Bool -> Html
 miniSynopsis mdl iface unicode =
-    thediv ! [ theclass "mini-synopsis" ]
-      << hsep (map (processForMiniSynopsis mdl unicode) $ exports)
+    divInterface << mapMaybe (processForMiniSynopsis mdl unicode) exports
   where
     exports = numberSectionHeadings (ifaceRnExportItems iface)
 
-processForMiniSynopsis :: Module -> Bool -> ExportItem DocName ->  Html
+processForMiniSynopsis :: Module -> Bool -> ExportItem DocName -> Maybe Html
 processForMiniSynopsis mdl unicode (ExportDecl (L _loc decl0) _doc _ _insts) =
-  thediv ! [theclass "decl" ] <<
-  case decl0 of
-    TyClD d@(TyFamily{}) -> ppTyFamHeader True False d unicode
-    TyClD d@(TyData{tcdTyPats = ps})
-      | Nothing <- ps    -> keyword "data" <+> ppTyClBinderWithVarsMini mdl d
-      | Just _ <- ps     -> keyword "data" <+> keyword "instance"
-                                           <+> ppTyClBinderWithVarsMini mdl d
-    TyClD d@(TySynonym{tcdTyPats = ps})
-      | Nothing <- ps    -> keyword "type" <+> ppTyClBinderWithVarsMini mdl d
-      | Just _ <- ps     -> keyword "type" <+> keyword "instance"
-                                           <+> ppTyClBinderWithVarsMini mdl d
-    TyClD d@(ClassDecl {}) ->
-                            keyword "class" <+> ppTyClBinderWithVarsMini mdl d
+  ((divTopDecl <<).(declElem <<)) `fmap` case decl0 of
+    TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
+        (TyFamily{}) -> Just $ ppTyFamHeader True False d unicode
+        (TyData{tcdTyPats = ps})
+          | Nothing <- ps -> Just $ keyword "data" <+> b
+          | Just _ <- ps  -> Just $ keyword "data" <+> keyword "instance" <+> b
+        (TySynonym{tcdTyPats = ps})
+          | Nothing <- ps -> Just $ keyword "type" <+> b
+          | Just _ <- ps  -> Just $ keyword "type" <+> keyword "instance" <+> b
+        (ClassDecl {})    -> Just $ keyword "class" <+> b
+        _ -> Nothing
     SigD (TypeSig (L _ n) (L _ _)) ->
-        let nm = docNameOcc n
-        in ppNameMini mdl nm
-    _ -> noHtml
+         Just $ ppNameMini mdl (docNameOcc n)
+    _ -> Nothing
 processForMiniSynopsis _ _ (ExportGroup lvl _id txt) =
-  let heading
-        | lvl == 1 = h1
-        | lvl == 2 = h2
-        | lvl >= 3 = h3
-        | otherwise = error "bad group level"
-  in heading << docToHtml txt
-processForMiniSynopsis _ _ _ = noHtml
+  Just $ groupTag lvl << docToHtml txt
+processForMiniSynopsis _ _ _ = Nothing
 
 ppNameMini :: Module -> OccName -> Html
 ppNameMini mdl nm =
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 86e75740..d7f9c1c8 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -11,6 +11,8 @@
 -- Portability :  portable
 -----------------------------------------------------------------------------
 module Haddock.Backends.Xhtml.Layout (
+  miniBody,
+  
   divPackageHeader, divModuleHeader, divFooter,
   divTableOfContents, divDescription, divSynposis, divInterface, 
   
@@ -46,6 +48,9 @@ import GHC
 
 -- Sections of the document
 
+miniBody :: Html -> Html
+miniBody = body ! [identifier "mini"]
+
 divPackageHeader, divModuleHeader, divFooter :: Html -> Html
 divPackageHeader = thediv ! [identifier "package-header"]
 divModuleHeader  = thediv ! [identifier "module-header"]
-- 
cgit v1.2.3