From 3cd971e8455368d8dfd377f68bca8ff663a922a9 Mon Sep 17 00:00:00 2001
From: Neil Mitchell <unknown>
Date: Sat, 14 Jun 2008 12:10:18 +0000
Subject: Add initial structure for outputting documentation as well, but does
 not yet output anything

---
 src/Haddock/Backends/Hoogle.hs | 26 +++++++++++++++++++++-----
 1 file changed, 21 insertions(+), 5 deletions(-)

(limited to 'src/Haddock')

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 635cc9bf..5f9a60a9 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -18,6 +18,7 @@ import GHC hiding ((<.>))
 import SrcLoc
 import Outputable
 
+import Control.Monad
 import Data.Char
 import Data.List
 import Data.Maybe
@@ -36,7 +37,8 @@ ppHoogle maybe_package ifaces odir = do
 
 
 ppModule :: Interface -> [String]
-ppModule iface = ["", "module " ++ moduleString (ifaceMod iface)] ++
+ppModule iface = "" : doc (ifaceDoc iface) ++
+                 ["module " ++ moduleString (ifaceMod iface)] ++
                  concatMap ppExport (ifaceExportItems iface) ++
                  concatMap ppInstance (ifaceInstances iface)
 
@@ -65,7 +67,7 @@ typeSig name flds = name ++ " :: " ++ concat (intersperse " -> " flds)
 -- How to print each export
 
 ppExport :: ExportItem Name -> [String]
-ppExport (ExportDecl name decl _ _) = f $ unL decl
+ppExport (ExportDecl name decl dc _) = doc dc ++ f (unL decl)
     where
         f (TyClD d@TyData{}) = ppData d
         f (TyClD d@ClassDecl{}) = ppClass d
@@ -73,6 +75,7 @@ ppExport (ExportDecl name decl _ _) = f $ unL decl
 ppExport _ = []
 
 
+-- note: does not yet output documentation for class methods
 ppClass :: TyClDecl Name -> [String]
 ppClass x = out x{tcdSigs=[]} :
             map (indent . out) (tcdSigs x)
@@ -91,15 +94,28 @@ ppData x = showData x{tcdCons=[],tcdDerivs=Nothing} :
 
 
 ppCtor :: TyClDecl Name -> ConDecl Name -> [String]
-ppCtor dat con = f $ con_details con
+ppCtor dat con = ldoc (con_doc con) ++ f (con_details con)
     where
         f (PrefixCon args) = [typeSig name $ map out args ++ [resType]]
         f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
-        f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++
-                          [out (unL $ cd_fld_name r) `typeSig` [resType, out $ cd_fld_type r] | r <- recs]
+        f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat
+                          [ldoc (cd_fld_doc r) ++
+                           [out (unL $ cd_fld_name r) `typeSig` [resType, out $ cd_fld_type r]]
+                          | r <- recs]
 
         name = out $ unL $ con_name con
 
         resType = case con_res con of
             ResTyH98 -> unwords $ out (tcdLName dat) : map out (tcdTyVars dat)
             ResTyGADT x -> out $ unL x
+
+
+---------------------------------------------------------------------
+-- How to show documentation
+
+ldoc :: Maybe (LHsDoc Name) -> [String]
+ldoc = doc . liftM unL
+
+doc :: Maybe (HsDoc Name) -> [String]
+doc Nothing = []
+doc (Just d) = [] -- can add here, if wanted
-- 
cgit v1.2.3