From 11ebf08d5ef30375ba5585b6079f696d49402c3f Mon Sep 17 00:00:00 2001 From: "davve@dtek.chalmers.se" Date: Sun, 25 Mar 2007 01:23:25 +0000 Subject: De-flatten the namespace --- haddock-ghc.cabal | 30 +- src/BlockTable.hs | 180 ----- src/FastMutInt2.hs | 63 -- src/GHCUtils.hs | 26 - src/Haddock/DevHelp.hs | 75 ++ src/Haddock/HH.hs | 174 +++++ src/Haddock/HH2.hs | 182 +++++ src/Haddock/HaddockDB.hs | 165 +++++ src/Haddock/Hoogle.hs | 184 +++++ src/Haddock/Html.hs | 1508 ++++++++++++++++++++++++++++++++++++++ src/Haddock/InterfaceFile.hs | 2 +- src/Haddock/ModuleTree.hs | 38 + src/Haddock/Rename.hs | 320 ++++++++ src/Haddock/Types.hs | 123 ++++ src/Haddock/Utils.hs | 340 +++++++++ src/Haddock/Utils/BlockTable.hs | 180 +++++ src/Haddock/Utils/FastMutInt2.hs | 63 ++ src/Haddock/Utils/GHC.hs | 26 + src/Haddock/Utils/Html.hs | 1037 ++++++++++++++++++++++++++ src/Haddock/Version.hs | 18 + src/HaddockDB.hs | 165 ----- src/HaddockDevHelp.hs | 75 -- src/HaddockHH.hs | 174 ----- src/HaddockHH2.hs | 182 ----- src/HaddockHoogle.hs | 184 ----- src/HaddockHtml.hs | 1508 -------------------------------------- src/HaddockModuleTree.hs | 38 - src/HaddockRename.hs | 320 -------- src/HaddockTypes.hs | 123 ---- src/HaddockUtil.hs | 340 --------- src/HaddockVersion.hs | 18 - src/Html.hs | 1037 -------------------------- src/Main.hs | 14 +- 33 files changed, 4456 insertions(+), 4456 deletions(-) delete mode 100644 src/BlockTable.hs delete mode 100644 src/FastMutInt2.hs delete mode 100644 src/GHCUtils.hs create mode 100644 src/Haddock/DevHelp.hs create mode 100644 src/Haddock/HH.hs create mode 100644 src/Haddock/HH2.hs create mode 100644 src/Haddock/HaddockDB.hs create mode 100644 src/Haddock/Hoogle.hs create mode 100644 src/Haddock/Html.hs create mode 100644 src/Haddock/ModuleTree.hs create mode 100644 src/Haddock/Rename.hs create mode 100644 src/Haddock/Types.hs create mode 100644 src/Haddock/Utils.hs create mode 100644 src/Haddock/Utils/BlockTable.hs create mode 100644 src/Haddock/Utils/FastMutInt2.hs create mode 100644 src/Haddock/Utils/GHC.hs create mode 100644 src/Haddock/Utils/Html.hs create mode 100644 src/Haddock/Version.hs delete mode 100644 src/HaddockDB.hs delete mode 100644 src/HaddockDevHelp.hs delete mode 100644 src/HaddockHH.hs delete mode 100644 src/HaddockHH2.hs delete mode 100644 src/HaddockHoogle.hs delete mode 100644 src/HaddockHtml.hs delete mode 100644 src/HaddockModuleTree.hs delete mode 100644 src/HaddockRename.hs delete mode 100644 src/HaddockTypes.hs delete mode 100644 src/HaddockUtil.hs delete mode 100644 src/HaddockVersion.hs delete mode 100644 src/Html.hs diff --git a/haddock-ghc.cabal b/haddock-ghc.cabal index 10ee010a..0df410d1 100644 --- a/haddock-ghc.cabal +++ b/haddock-ghc.cabal @@ -62,21 +62,21 @@ main-is: Main.hs extensions: CPP, PatternGuards ghc-options: -fglasgow-exts other-modules: - FastMutInt2 - BlockTable - HaddockDB - HaddockDevHelp - HaddockHH - HaddockHH2 - HaddockHoogle - HaddockHtml - HaddockModuleTree - HaddockRename - HaddockTypes - HaddockUtil - HaddockVersion - Html - GHCUtils + Haddock.Utils.FastMutInt2 + Haddock.Utils.BlockTable + Haddock.HaddockDB + Haddock.DevHelp + Haddock.HH + Haddock.HH2 + Haddock.Hoogle + Haddock.Utils.Html + Haddock.ModuleTree + Haddock.Rename + Haddock.Types + Haddock.Utils + Haddock.Version + Haddock.Utils.Html + Haddock.Utils.GHC Haddock.InterfaceFile Haddock.Exception Main diff --git a/src/BlockTable.hs b/src/BlockTable.hs deleted file mode 100644 index 5cd46f1b..00000000 --- a/src/BlockTable.hs +++ /dev/null @@ -1,180 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Text.Html.BlockTable --- Copyright : (c) Andy Gill, and the Oregon Graduate Institute of --- Science and Technology, 1999-2001 --- License : BSD-style (see the file libraries/core/LICENSE) --- --- Maintainer : Andy Gill --- Stability : experimental --- Portability : portable --- --- $Id: BlockTable.hs,v 1.2 2002/07/24 09:42:18 simonmar Exp $ --- --- An Html combinator library --- ------------------------------------------------------------------------------ - -module BlockTable ( - --- Datatypes: - - BlockTable, -- abstract - --- Contruction Functions: - - single, - empty, - above, - beside, - --- Investigation Functions: - - getMatrix, - showsTable, - showTable, - - ) where - -import Prelude - -infixr 4 `beside` -infixr 3 `above` - --- These combinators can be used to build formated 2D tables. --- The specific target useage is for HTML table generation. - -{- - Examples of use: - - > table1 :: BlockTable String - > table1 = single "Hello" +-----+ - |Hello| - This is a 1x1 cell +-----+ - Note: single has type - - single :: a -> BlockTable a - - So the cells can contain anything. - - > table2 :: BlockTable String - > table2 = single "World" +-----+ - |World| - +-----+ - - - > table3 :: BlockTable String - > table3 = table1 %-% table2 +-----%-----+ - |Hello%World| - % is used to indicate +-----%-----+ - the join edge between - the two Tables. - - > table4 :: BlockTable String - > table4 = table3 %/% table2 +-----+-----+ - |Hello|World| - Notice the padding on the %%%%%%%%%%%%% - smaller (bottom) cell to |World | - force the table to be a +-----------+ - rectangle. - - > table5 :: BlockTable String - > table5 = table1 %-% table4 +-----%-----+-----+ - |Hello%Hello|World| - Notice the padding on the | %-----+-----+ - leftmost cell, again to | %World | - force the table to be a +-----%-----------+ - rectangle. - - Now the table can be rendered with processTable, for example: - Main> processTable table5 - [[("Hello",(1,2)), - ("Hello",(1,1)), - ("World",(1,1))], - [("World",(2,1))]] :: [[([Char],(Int,Int))]] - Main> --} - --- --------------------------------------------------------------------------- --- Contruction Functions - --- Perhaps one day I'll write the Show instance --- to show boxes aka the above ascii renditions. - -instance (Show a) => Show (BlockTable a) where - showsPrec _ = showsTable - -type TableI a = [[(a,(Int,Int))]] -> [[(a,(Int,Int))]] - -data BlockTable a = Table (Int -> Int -> TableI a) Int Int - - --- You can create a (1x1) table entry - -single :: a -> BlockTable a -single a = Table (\ x y r -> [(a,(x+1,y+1))] : r) 1 1 - -empty :: BlockTable a -empty = Table (\ _ _ r -> r) 0 0 - - --- You can compose tables, horizonally and vertically - -above :: BlockTable a -> BlockTable a -> BlockTable a -beside :: BlockTable a -> BlockTable a -> BlockTable a - -t1 `above` t2 = trans (combine (trans t1) (trans t2) (.)) - -t1 `beside` t2 = combine t1 t2 (\ lst1 lst2 r -> - let - -- Note this depends on the fact that - -- that the result has the same number - -- of lines as the y dimention; one list - -- per line. This is not true in general - -- but is always true for these combinators. - -- I should assert this! - -- I should even prove this. - beside' (x:xs) (y:ys) = (x ++ y) : beside' xs ys - beside' (x:xs) [] = x : xs ++ r - beside' [] (y:ys) = y : ys ++ r - beside' [] [] = r - in - beside' (lst1 []) (lst2 [])) - --- trans flips (transposes) over the x and y axis of --- the table. It is only used internally, and typically --- in pairs, ie. (flip ... munge ... (un)flip). - -trans :: BlockTable a -> BlockTable a -trans (Table f1 x1 y1) = Table (flip f1) y1 x1 - -combine :: BlockTable a - -> BlockTable b - -> (TableI a -> TableI b -> TableI c) - -> BlockTable c -combine (Table f1 x1 y1) (Table f2 x2 y2) comb = Table new_fn (x1+x2) max_y - where - max_y = max y1 y2 - new_fn x y = - case compare y1 y2 of - EQ -> comb (f1 0 y) (f2 x y) - GT -> comb (f1 0 y) (f2 x (y + y1 - y2)) - LT -> comb (f1 0 (y + y2 - y1)) (f2 x y) - --- --------------------------------------------------------------------------- --- Investigation Functions - --- This is the other thing you can do with a Table; --- turn it into a 2D list, tagged with the (x,y) --- sizes of each cell in the table. - -getMatrix :: BlockTable a -> [[(a,(Int,Int))]] -getMatrix (Table r _ _) = r 0 0 [] - --- You can also look at a table - -showsTable :: (Show a) => BlockTable a -> ShowS -showsTable table = shows (getMatrix table) - -showTable :: (Show a) => BlockTable a -> String -showTable table = showsTable table "" diff --git a/src/FastMutInt2.hs b/src/FastMutInt2.hs deleted file mode 100644 index a197a448..00000000 --- a/src/FastMutInt2.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# OPTIONS_GHC -cpp -fglasgow-exts #-} --- --- (c) The University of Glasgow 2002 --- --- Unboxed mutable Ints - -module FastMutInt2( - FastMutInt, newFastMutInt, - readFastMutInt, writeFastMutInt, - incFastMutInt, incFastMutIntBy - ) where - -#include "MachDeps.h" - -#ifndef SIZEOF_HSINT -#define SIZEOF_HSINT INT_SIZE_IN_BYTES -#endif - - -#if __GLASGOW_HASKELL__ < 503 -import GlaExts -import PrelIOBase -#else -import GHC.Base -import GHC.IOBase -#endif - -#if __GLASGOW_HASKELL__ < 411 -newByteArray# = newCharArray# -#endif - -#ifdef __GLASGOW_HASKELL__ -data FastMutInt = FastMutInt (MutableByteArray# RealWorld) - -newFastMutInt :: IO FastMutInt -newFastMutInt = IO $ \s0 -> - case newByteArray# size s0 of { (# s, arr #) -> - (# s, FastMutInt arr #) } - where I# size = SIZEOF_HSINT - -readFastMutInt :: FastMutInt -> IO Int -readFastMutInt (FastMutInt arr) = IO $ \s0 -> - case readIntArray# arr 0# s0 of { (# s, i #) -> - (# s, I# i #) } - -writeFastMutInt :: FastMutInt -> Int -> IO () -writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s0 -> - case writeIntArray# arr 0# i s0 of { s -> - (# s, () #) } - -incFastMutInt :: FastMutInt -> IO Int -- Returns original value -incFastMutInt (FastMutInt arr) = IO $ \s0 -> - case readIntArray# arr 0# s0 of { (# s1, i #) -> - case writeIntArray# arr 0# (i +# 1#) s1 of { s -> - (# s, I# i #) } } - -incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value -incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s0 -> - case readIntArray# arr 0# s0 of { (# s1, i #) -> - case writeIntArray# arr 0# (i +# n) s1 of { s -> - (# s, I# i #) } } -#endif - diff --git a/src/GHCUtils.hs b/src/GHCUtils.hs deleted file mode 100644 index 2c732923..00000000 --- a/src/GHCUtils.hs +++ /dev/null @@ -1,26 +0,0 @@ -module GHCUtils where - -import Debug.Trace - -import GHC -import HsSyn -import SrcLoc -import HscTypes -import Outputable - -getMainDeclBinder :: HsDecl name -> Maybe name -getMainDeclBinder (TyClD d) = Just (tcdName d) -getMainDeclBinder (ValD d) - = case collectAcc d [] of - [] -> Nothing - (name:_) -> Just (unLoc name) -getMainDeclBinder (SigD d) = sigNameNoLoc d -getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name) -getMainDeclBinder (ForD (ForeignExport name _ _)) = Nothing -getMainDeclBinder _ = Nothing - --- To keep if if minf_iface is re-introduced ---modInfoName = moduleName . mi_module . minf_iface ---modInfoMod = mi_module . minf_iface - -trace_ppr x y = trace (showSDoc (ppr x)) y diff --git a/src/Haddock/DevHelp.hs b/src/Haddock/DevHelp.hs new file mode 100644 index 00000000..afcbd1c3 --- /dev/null +++ b/src/Haddock/DevHelp.hs @@ -0,0 +1,75 @@ +module Haddock.DevHelp(ppDevHelpFile) where + +import Haddock.ModuleTree +import Haddock.Types +import Haddock.Utils + +import Module ( moduleName, moduleNameString, Module, mkModule, mkModuleName ) +import PackageConfig ( stringToPackageId ) +import Name ( Name, nameModule, getOccString ) + +import Data.Maybe ( fromMaybe ) +import qualified Data.Map as Map +import Text.PrettyPrint + +ppDevHelpFile :: FilePath -> String -> Maybe String -> [HaddockModule] -> IO () +ppDevHelpFile odir doctitle maybe_package modules = do + let devHelpFile = package++".devhelp" + tree = mkModuleTree True [ (hmod_mod mod, toDescription mod) | mod <- modules ] + doc = + text "" $$ + (text "text doctitle<> + text "\" link=\""<>text contentsHtmlFile<>text"\" author=\"\" name=\""<>text package<>text "\">") $$ + text "" $$ + nest 4 (ppModuleTree [] tree) $+$ + text "" $$ + text "" $$ + nest 4 (ppList index) $+$ + text "" $$ + text "" + writeFile (pathJoin [odir, devHelpFile]) (render doc) + where + package = fromMaybe "pkg" maybe_package + + ppModuleTree :: [String] -> [ModuleTree] -> Doc + ppModuleTree ss [x] = ppNode ss x + ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs + ppModuleTree _ [] = error "HaddockHH.ppHHContents.fn: no module trees given" + + ppNode :: [String] -> ModuleTree -> Doc + ppNode ss (Node s leaf _ _short ts) = + case ts of + [] -> text "ppAttribs<>text "/>" + ts -> + text "ppAttribs<>text ">" $$ + nest 4 (ppModuleTree (s:ss) ts) $+$ + text "" + where + ppLink | leaf = text (moduleHtmlFile (mkModule (stringToPackageId "") + (mkModuleName mdl))) + | otherwise = empty + + ppAttribs = text "name="<>doubleQuotes (text s)<+>text "link="<>doubleQuotes ppLink + + mdl = foldr (++) "" (s' : map ('.':) ss') + (s':ss') = reverse (s:ss) + -- reconstruct the module name + + index :: [(Name, [Module])] + index = Map.toAscList (foldr getModuleIndex Map.empty modules) + + getModuleIndex hmod fm = + Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mod]) | name <- hmod_exports hmod, nameModule name == mod]) fm + where mod = hmod_mod hmod + + ppList :: [(Name, [Module])] -> Doc + ppList [] = empty + ppList ((name,refs):mdls) = + ppReference name refs $$ + ppList mdls + + ppReference :: Name -> [Module] -> Doc + ppReference name [] = empty + ppReference name (mod:refs) = + text "text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mod name)<>text"\"/>" $$ + ppReference name refs diff --git a/src/Haddock/HH.hs b/src/Haddock/HH.hs new file mode 100644 index 00000000..a41d7297 --- /dev/null +++ b/src/Haddock/HH.hs @@ -0,0 +1,174 @@ +module Haddock.HH(ppHHContents, ppHHIndex, ppHHProject) where + +ppHHContents = error "not yet" +ppHHIndex = error "not yet" +ppHHProject = error "not yet" + +{- +import HaddockModuleTree +import HaddockTypes +import HaddockUtil +import HsSyn2 hiding(Doc) +import qualified Map + +import Data.Char ( toUpper ) +import Data.Maybe ( fromMaybe ) +import Text.PrettyPrint + +ppHHContents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO () +ppHHContents odir doctitle maybe_package tree = do + let contentsHHFile = package++".hhc" + + html = + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + ppModuleTree tree $$ + text "" + writeFile (pathJoin [odir, contentsHHFile]) (render html) + where + package = fromMaybe "pkg" maybe_package + + ppModuleTree :: [ModuleTree] -> Doc + ppModuleTree ts = + text "" $$ + text "" $$ + text "" $$ + text "
    " $+$ + nest 4 (text "
  • " <> nest 4 + (text "" $$ + nest 4 (text "text doctitle<>text "\">" $$ + text "") $$ + text "") $+$ + text "
    • " $$ + text "
      " $+$ + nest 4 (fn [] ts) $+$ + text "
    ") $+$ + text "
" + + fn :: [String] -> [ModuleTree] -> Doc + fn ss [x] = ppNode ss x + fn ss (x:xs) = ppNode ss x $$ fn ss xs + fn _ [] = error "HaddockHH.ppHHContents.fn: no module trees given" + + ppNode :: [String] -> ModuleTree -> Doc + ppNode ss (Node s leaf _pkg _ []) = + ppLeaf s ss leaf + ppNode ss (Node s leaf _pkg _ ts) = + ppLeaf s ss leaf $$ + text "
    " $+$ + nest 4 (fn (s:ss) ts) $+$ + text "
" + + ppLeaf s ss isleaf = + text "
  • " <> nest 4 + (text "" $$ + text " text s <> text "\">" $$ + (if isleaf then text " text (moduleHtmlFile mdl) <> text "\">" else empty) $$ + text "") $+$ + text "
    • " + where + mdl = foldr (++) "" (s' : map ('.':) ss') + (s':ss') = reverse (s:ss) + -- reconstruct the module name + +------------------------------- +ppHHIndex :: FilePath -> Maybe String -> [Interface] -> IO () +ppHHIndex odir maybe_package ifaces = do + let indexHHFile = package++".hhk" + + html = + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "
      " $+$ + nest 4 (ppList index) $+$ + text "
    " $$ + text "" + writeFile (pathJoin [odir, indexHHFile]) (render html) + where + package = fromMaybe "pkg" maybe_package + + index :: [(HsName, [Module])] + index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces) + + getIfaceIndex iface fm = + foldl (\m (k,e) -> Map.insertWith (++) k e m) fm [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl'] + where mdl = iface_module iface + + ppList [] = empty + ppList ((name,refs):mdls) = + text "
  • " <> nest 4 + (text "" $$ + text " text (show name) <> text "\">" $$ + ppReference name refs $$ + text "") $+$ + text "
    • " $$ + ppList mdls + + ppReference name [] = empty + ppReference name (Module mdl:refs) = + text " text (nameHtmlRef mdl name) <> text "\">" $$ + ppReference name refs + + +ppHHProject :: FilePath -> String -> Maybe String -> [Interface] -> [FilePath] -> IO () +ppHHProject odir doctitle maybe_package ifaces pkg_paths = do + let projectHHFile = package++".hhp" + doc = + text "[OPTIONS]" $$ + text "Compatibility=1.1 or later" $$ + text "Compiled file=" <> text package <> text ".chm" $$ + text "Contents file=" <> text package <> text ".hhc" $$ + text "Default topic=" <> text contentsHtmlFile $$ + text "Display compile progress=No" $$ + text "Index file=" <> text package <> text ".hhk" $$ + text "Title=" <> text doctitle $$ + space $$ + text "[FILES]" $$ + ppMods ifaces $$ + text contentsHtmlFile $$ + text indexHtmlFile $$ + ppIndexFiles chars $$ + ppLibFiles ("":pkg_paths) + writeFile (pathJoin [odir, projectHHFile]) (render doc) + where + package = fromMaybe "pkg" maybe_package + + ppMods [] = empty + ppMods (iface:ifaces) = + let Module mdl = iface_module iface in + text (moduleHtmlFile mdl) $$ + ppMods ifaces + + ppIndexFiles [] = empty + ppIndexFiles (c:cs) = + text (subIndexHtmlFile c) $$ + ppIndexFiles cs + + ppLibFiles [] = empty + ppLibFiles (path:paths) = + ppLibFile cssFile $$ + ppLibFile iconFile $$ + ppLibFile jsFile $$ + ppLibFile plusFile $$ + ppLibFile minusFile $$ + ppLibFiles paths + where + toPath fname | null path = fname + | otherwise = pathJoin [path, fname] + ppLibFile fname = text (toPath fname) + + chars :: [Char] + chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces)) + + getIfaceIndex iface fm = + Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm + where mdl = iface_module iface +-} diff --git a/src/Haddock/HH2.hs b/src/Haddock/HH2.hs new file mode 100644 index 00000000..945734e6 --- /dev/null +++ b/src/Haddock/HH2.hs @@ -0,0 +1,182 @@ +module Haddock.HH2(ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where + +ppHH2Contents = error "not yet" +ppHH2Index = error "not yet" +ppHH2Files = error "not yet" +ppHH2Collection = error "not yet" + +{- +import HaddockModuleTree +import HaddockTypes +import HaddockUtil +import HsSyn2 hiding(Doc) +import qualified Map + +import Data.Char ( toUpper ) +import Data.Maybe ( fromMaybe ) +import Text.PrettyPrint + +ppHH2Contents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO () +ppHH2Contents odir doctitle maybe_package tree = do + let + contentsHH2File = package++".HxT" + + doc = + text "" $$ + text "" $$ + text "" $$ + nest 4 (text "text doctitle<>text"\" Url=\"index.html\">" $$ + nest 4 (ppModuleTree [] tree) $+$ + text "") $$ + text "" + writeFile (pathJoin [odir, contentsHH2File]) (render doc) + where + package = fromMaybe "pkg" maybe_package + + ppModuleTree :: [String] -> [ModuleTree] -> Doc + ppModuleTree ss [x] = ppNode ss x + ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs + ppModuleTree _ [] = error "HaddockHH2.ppHH2Contents.ppModuleTree: no module trees given" + + ppNode :: [String] -> ModuleTree -> Doc + ppNode ss (Node s leaf _pkg _short []) = + text " ppAttributes leaf (s:ss) <> text "/>" + ppNode ss (Node s leaf _pkg _short ts) = + text " ppAttributes leaf (s:ss) <> text ">" $$ + nest 4 (ppModuleTree (s:ss) ts) $+$ + text "" + + ppAttributes :: Bool -> [String] -> Doc + ppAttributes isleaf ss = hsep [ppId,ppTitle,ppUrl] + where + mdl = foldr (++) "" (s' : map ('.':) ss') + (s':ss') = reverse ss + -- reconstruct the module name + + ppId = text "Id=" <> doubleQuotes (text mdl) + + ppTitle = text "Title=" <> doubleQuotes (text (head ss)) + + ppUrl | isleaf = text " Url=" <> doubleQuotes (text (moduleHtmlFile mdl)) + | otherwise = empty + +----------------------------------------------------------------------------------- + +ppHH2Index :: FilePath -> Maybe String -> [Interface] -> IO () +ppHH2Index odir maybe_package ifaces = do + let + indexKHH2File = package++"K.HxK" + indexNHH2File = package++"N.HxK" + docK = + text "" $$ + text "" $$ + text "" $$ + nest 4 (ppList index) $+$ + text "" + docN = + text "" $$ + text "" $$ + text "" $$ + text "" $$ + nest 4 (text "text contentsHtmlFile<>text "\"/>") $$ + text "" $$ + text "" + writeFile (pathJoin [odir, indexKHH2File]) (render docK) + writeFile (pathJoin [odir, indexNHH2File]) (render docN) + where + package = fromMaybe "pkg" maybe_package + + index :: [(HsName, [Module])] + index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces) + + getIfaceIndex iface fm = + Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm + where mdl = iface_module iface + + ppList [] = empty + ppList ((name,mdls):vs) = + text " text (escapeStr (show name)) <> text "\">" $$ + nest 4 (vcat (map (ppJump name) mdls)) $$ + text "" $$ + ppList vs + + ppJump name (Module mdl) = text " text (nameHtmlRef mdl name) <> text "\"/>" + + +----------------------------------------------------------------------------------- + +ppHH2Files :: FilePath -> Maybe String -> [Interface] -> [FilePath] -> IO () +ppHH2Files odir maybe_package ifaces pkg_paths = do + let filesHH2File = package++".HxF" + doc = + text "" $$ + text "" $$ + text "" $$ + nest 4 (ppMods ifaces $$ + text "text contentsHtmlFile<>text "\"/>" $$ + text "text indexHtmlFile<>text "\"/>" $$ + ppIndexFiles chars $$ + ppLibFiles ("":pkg_paths)) $$ + text "" + writeFile (pathJoin [odir, filesHH2File]) (render doc) + where + package = fromMaybe "pkg" maybe_package + + ppMods [] = empty + ppMods (iface:ifaces) = + text " text (moduleHtmlFile mdl) <> text "\"/>" $$ + ppMods ifaces + where Module mdl = iface_module iface + + ppIndexFiles [] = empty + ppIndexFiles (c:cs) = + text "text (subIndexHtmlFile c)<>text "\"/>" $$ + ppIndexFiles cs + + ppLibFiles [] = empty + ppLibFiles (path:paths) = + ppLibFile cssFile $$ + ppLibFile iconFile $$ + ppLibFile jsFile $$ + ppLibFile plusFile $$ + ppLibFile minusFile $$ + ppLibFiles paths + where + toPath fname | null path = fname + | otherwise = pathJoin [path, fname] + ppLibFile fname = text "text (toPath fname)<>text "\"/>" + + chars :: [Char] + chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces)) + + getIfaceIndex iface fm = + Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm + where mdl = iface_module iface + +----------------------------------------------------------------------------------- + +ppHH2Collection :: FilePath -> String -> Maybe String -> IO () +ppHH2Collection odir doctitle maybe_package = do + let + package = fromMaybe "pkg" maybe_package + collectionHH2File = package++".HxC" + + doc = + text "" $$ + text "" $$ + text " text doctitle <> text "\">" $$ + nest 4 (text "" $$ + nest 4 (text " text package <> text ".HxF\"/>") $$ + text "" $$ + text " text package <> text ".HxT\"/>" $$ + text " text package <> text "K.HxK\"/>" $$ + text " text package <> text "N.HxK\"/>" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "") $$ + text "" + writeFile (pathJoin [odir, collectionHH2File]) (render doc) +-} diff --git a/src/Haddock/HaddockDB.hs b/src/Haddock/HaddockDB.hs new file mode 100644 index 00000000..6341c6c4 --- /dev/null +++ b/src/Haddock/HaddockDB.hs @@ -0,0 +1,165 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2003 +-- + +module Haddock.HaddockDB (ppDocBook) where + +{- +import HaddockTypes +import HaddockUtil +import HsSyn2 + +import Text.PrettyPrint +-} + +----------------------------------------------------------------------------- +-- Printing the results in DocBook format + +ppDocBook = error "not working" +{- +ppDocBook :: FilePath -> [(Module, Interface)] -> String +ppDocBook odir mods = render (ppIfaces mods) + +ppIfaces mods + = text "" + $$ text "" + $$ text "" + $$ text "HaskellDoc version 0.0" + $$ text "" + $$ text "
    " + $$ vcat (map do_mod mods) + $$ text "
    " + where + do_mod (Module mod, iface) + = text " text mod <> text "\">" + $$ text "<literal>" + <> text mod + <> text "</literal>" + $$ text "" + <> text mod + <> text "" + $$ text "" + $$ vcat (map (do_export mod) (eltsFM (iface_decls iface))) + $$ text "" + $$ text "" + + do_export mod decl | (nm:_) <- declBinders decl + = text "" + <> do_decl decl + <> text "" + $$ text "" + $$ text "" + $$ text "" + $$ text "" + $$ text "" + do_export _ _ = empty + + do_decl (HsTypeSig _ [nm] ty _) + = ppHsName nm <> text " :: " <> ppHsType ty + do_decl (HsTypeDecl _ nm args ty _) + = hsep ([text "type", ppHsName nm ] + ++ map ppHsName args + ++ [equals, ppHsType ty]) + do_decl (HsNewTypeDecl loc ctx nm args con drv _) + = hsep ([text "data", ppHsName nm] -- data, not newtype + ++ map ppHsName args + ) <+> equals <+> ppHsConstr con -- ToDo: derivings + do_decl (HsDataDecl loc ctx nm args cons drv _) + = hsep ([text "data", {-ToDo: context-}ppHsName nm] + ++ map ppHsName args) + <+> vcat (zipWith (<+>) (equals : repeat (char '|')) + (map ppHsConstr cons)) + do_decl (HsClassDecl loc ty fds decl _) + = hsep [text "class", ppHsType ty] + do_decl decl + = empty + +ppHsConstr :: HsConDecl -> Doc +ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) = + ppHsName name + <> (braces . hsep . punctuate comma . map ppField $ fieldList) +ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = + hsep (ppHsName name : map ppHsBangType typeList) + +ppField (HsFieldDecl ns ty doc) + = hsep (punctuate comma (map ppHsName ns) ++ + [text "::", ppHsBangType ty]) + +ppHsBangType :: HsBangType -> Doc +ppHsBangType (HsBangedTy ty) = char '!' <> ppHsType ty +ppHsBangType (HsUnBangedTy ty) = ppHsType ty + +ppHsContext :: HsContext -> Doc +ppHsContext [] = empty +ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> + hsep (map ppHsAType b)) context) + +ppHsType :: HsType -> Doc +ppHsType (HsForAllType Nothing context htype) = + hsep [ ppHsContext context, text "=>", ppHsType htype] +ppHsType (HsForAllType (Just tvs) [] htype) = + hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype]) +ppHsType (HsForAllType (Just tvs) context htype) = + hsep (text "forall" : map ppHsName tvs ++ text "." : + ppHsContext context : text "=>" : [ppHsType htype]) +ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b] +ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t] +ppHsType t = ppHsBType t + +ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) + = brackets $ ppHsType b +ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b] +ppHsBType t = ppHsAType t + +ppHsAType :: HsType -> Doc +ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l +ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l +-- special case +ppHsAType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) + = brackets $ ppHsType b +ppHsAType (HsTyVar name) = ppHsName name +ppHsAType (HsTyCon name) = ppHsQName name +ppHsAType t = parens $ ppHsType t + +ppHsQName :: HsQName -> Doc +ppHsQName (UnQual str) = ppHsName str +ppHsQName n@(Qual (Module mod) str) + | n == unit_con_name = ppHsName str + | isSpecial str = ppHsName str + | otherwise + = text "" + +isSpecial (HsTyClsName id) | HsSpecial _ <- id = True +isSpecial (HsVarName id) | HsSpecial _ <- id = True +isSpecial _ = False + +ppHsName :: HsName -> Doc +ppHsName (HsTyClsName id) = ppHsIdentifier id +ppHsName (HsVarName id) = ppHsIdentifier id + +ppHsIdentifier :: HsIdentifier -> Doc +ppHsIdentifier (HsIdent str) = text str +ppHsIdentifier (HsSymbol str) = text str +ppHsIdentifier (HsSpecial str) = text str + +ppLinkId :: String -> HsName -> Doc +ppLinkId mod str + = hcat [char '\"', text mod, char '.', ppHsName str, char '\"'] + +-- ----------------------------------------------------------------------------- +-- * Misc + +parenList :: [Doc] -> Doc +parenList = parens . fsep . punctuate comma + +ubxParenList :: [Doc] -> Doc +ubxParenList = ubxparens . fsep . punctuate comma + +ubxparens p = text "(#" <> p <> text "#)" +-} diff --git a/src/Haddock/Hoogle.hs b/src/Haddock/Hoogle.hs new file mode 100644 index 00000000..618d6eb3 --- /dev/null +++ b/src/Haddock/Hoogle.hs @@ -0,0 +1,184 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2003 +-- +-- This file, (c) Neil Mitchell 2006 +-- Write out Hoogle compatible documentation +-- http://www.haskell.org/hoogle/ + +module Haddock.Hoogle ( + ppHoogle + ) where + +ppHoogle = undefined + +{- +import HaddockTypes +import HaddockUtil +import HsSyn2 + +import Data.List ( intersperse ) + + + +prefix = ["-- Hoogle documentation, generated by Haddock", + "-- See Hoogle, http://www.haskell.org/hoogle/"] + +ppHoogle :: Maybe String -> [Interface] -> FilePath -> IO () +ppHoogle maybe_package ifaces odir = + do + let + filename = case maybe_package of + Just x -> x ++ ".txt" + Nothing -> "hoogle.txt" + + visible_ifaces = filter visible ifaces + visible i = OptHide `notElem` iface_options i + + contents = prefix : map ppModule visible_ifaces + + writeFile (pathJoin [odir, filename]) (unlines $ concat contents) + + + +-- --------------------------------------------------------------------------- +-- Generate the HTML page for a module + + +ppDecl :: HsDecl -> [String] +ppDecl (HsNewTypeDecl src context name args ctor unknown docs) = + ppData "newtype" context name args [ctor] + +ppDecl (HsDataDecl src context name args ctors unknown docs) = + ppData "data" context name args ctors + +ppDecl (HsTypeSig src names t doc) = map (`ppFunc` t) names + +ppDecl (HsForeignImport src _ _ _ name t doc) = ppDecl $ HsTypeSig src [name] t doc + +ppDecl (HsClassDecl src context name args fundeps members doc) = + ("class " ++ ppContext context ++ ppType typ) : concatMap f members + where + typ = foldl HsTyApp (HsTyCon $ UnQual name) (map HsTyVar args) + newcontext = (UnQual name, map HsTyVar args) + f (HsTypeSig src names t doc) = ppDecl (HsTypeSig src names (addContext newcontext t) doc) + f (HsFunBind{}) = [] + f (HsPatBind{}) = [] + f x = ["-- ERR " ++ show x] + +ppDecl (HsTypeDecl src name args t doc) = + ["type " ++ show name ++ concatMap (\x -> ' ':show x) args ++ " = " ++ ppType t] + +ppDecl x = ["-- ERR " ++ show x] + + + +addContext :: HsAsst -> HsType -> HsType +addContext ctx (HsForAllType Nothing context t) = HsForAllType Nothing (HsAssump ctx : context) t +addContext ctx x = HsForAllType Nothing [HsAssump ctx] x + + + +ppFunc :: HsName -> HsType -> String +ppFunc name typ = show name ++ " :: " ++ ppType typ + + +ppData :: String -> HsContext -> HsName -> [HsName] -> [HsConDecl] -> [String] +ppData mode context name args ctors = (mode ++ " " ++ ppType typ) : concatMap (ppCtor typ) ctors + where + typ = foldl HsTyApp (HsTyCon $ UnQual name) (map HsTyVar args) + + +deBang :: HsBangType -> HsType +deBang (HsBangedTy x) = x +deBang (HsUnBangedTy x) = x + + +ppCtor :: HsType -> HsConDecl -> [String] +ppCtor result (HsConDecl src name types context typ doc) = + [show name ++ " :: " ++ ppContext context ++ ppTypesArr (map deBang typ ++ [result])] + +ppCtor result (HsRecDecl src name types context fields doc) = + ppCtor result (HsConDecl src name types context (map snd fields2) doc) ++ + concatMap f fields2 + where + fields2 = [(name, typ) | HsFieldDecl names typ _ <- fields, name <- names] + f (name, typ) = ppDecl $ HsTypeSig src [name] (HsTyFun result (deBang typ)) doc + + +brack True x = "(" ++ x ++ ")" +brack False x = x + +ppContext :: HsContext -> String +ppContext [] = "" +ppContext xs = brack (length xs > 1) (concat $ intersperse ", " $ map ppContextItem xs) ++ " => " + +ppContextItem :: HsAsst -> String +ppContextItem (name, types) = ppQName name ++ concatMap (\x -> ' ':ppType x) types + +ppContext2 :: HsIPContext -> String +ppContext2 xs = ppContext [x | HsAssump x <- xs] + + +ppType :: HsType -> String +ppType x = f 0 x + where + f _ (HsTyTuple _ xs) = brack True $ concat $ intersperse ", " $ map (f 0) xs + f _ (HsTyCon x) = ppQName x + f _ (HsTyVar x) = show x + + -- ignore ForAll types as Hoogle does not support them + f n (HsForAllType (Just items) context t) = + -- brack (n > 1) $ + -- "forall" ++ concatMap (\x -> ' ':toStr x) items ++ " . " ++ f 0 t + f n t + + f n (HsForAllType Nothing context t) = brack (n > 1) $ + ppContext2 context ++ f 0 t + + f n (HsTyFun a b) = brack g $ f (h 3) a ++ " -> " ++ f (h 2) b + where + g = n > 2 + h x = if g then 0 else x + + f n (HsTyApp a b) | ppType a == "[]" = "[" ++ f 0 b ++ "]" + + f n (HsTyApp a b) = brack g $ f (h 3) a ++ " " ++ f (h 4) b + where + g = n > 3 + h x = if g then 0 else x + + f n (HsTyDoc x _) = f n x + + f n x = brack True $ show x + + +ppQName :: HsQName -> String +ppQName (Qual _ name) = show name +ppQName (UnQual name) = show name + + + +ppTypesArr :: [HsType] -> String +ppTypesArr xs = ppType $ foldr1 HsTyFun xs + + + +ppInst :: InstHead -> String +ppInst (context, item) = "instance " ++ ppContext context ++ ppContextItem item + + + +ppModule :: Interface -> [String] +ppModule iface = "" : ("module " ++ mdl) : concatMap ppExport (iface_exports iface) + where + Module mdl = iface_module iface + + +ppExport :: ExportItem -> [String] +ppExport (ExportDecl name decl insts) = ppDecl decl ++ map ppInst insts +ppExport _ = [] + + +-} diff --git a/src/Haddock/Html.hs b/src/Haddock/Html.hs new file mode 100644 index 00000000..6bd80687 --- /dev/null +++ b/src/Haddock/Html.hs @@ -0,0 +1,1508 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2003 +-- + +module Haddock.Html ( + ppHtml, copyHtmlBits, + ppHtmlIndex, ppHtmlContents, + ppHtmlHelpFiles + ) where + +import Prelude hiding (div) + +import Haddock.DevHelp +import Haddock.HH +import Haddock.HH2 +import Haddock.ModuleTree +import Haddock.Types +import Haddock.Utils +import Haddock.Version +import Haddock.Utils.Html +import qualified Haddock.Utils.Html as Html + +import Control.Exception ( bracket ) +import Control.Monad ( when, unless ) +import Data.Char ( isUpper, toUpper ) +import Data.List ( sortBy ) +import Data.Maybe ( fromJust, isJust, mapMaybe, fromMaybe ) +import Foreign.Marshal.Alloc ( allocaBytes ) +import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile ) +import Debug.Trace ( trace ) +import Data.Map ( Map ) +import qualified Data.Map as Map hiding ( Map ) + +import GHC +import Name +import Module +import PackageConfig ( stringToPackageId ) +import RdrName hiding ( Qual ) +import SrcLoc +import FastString ( unpackFS ) +import BasicTypes ( IPName(..), Boxity(..) ) +import Type ( Kind ) +import Outputable ( ppr, defaultUserStyle, showSDoc ) + +-- the base, module and entity URLs for the source code and wiki links. +type SourceURLs = (Maybe String, Maybe String, Maybe String) +type WikiURLs = (Maybe String, Maybe String, Maybe String) + +-- ----------------------------------------------------------------------------- +-- Generating HTML documentation + +ppHtml :: String + -> Maybe String -- package + -> [HaddockModule] + -> FilePath -- destination directory + -> Maybe (GHC.HsDoc GHC.RdrName) -- prologue text, maybe + -> Maybe String -- the Html Help format (--html-help) + -> SourceURLs -- the source URL (--source) + -> WikiURLs -- the wiki URL (--wiki) + -> Maybe String -- the contents URL (--use-contents) + -> Maybe String -- the index URL (--use-index) + -> IO () + +ppHtml doctitle maybe_package hmods odir prologue maybe_html_help_format + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url = do + let + visible_hmods = filter visible hmods + visible i = OptHide `notElem` hmod_options i + + when (not (isJust maybe_contents_url)) $ + ppHtmlContents odir doctitle maybe_package + maybe_html_help_format maybe_index_url maybe_source_url maybe_wiki_url + visible_hmods + False -- we don't want to display the packages in a single-package contents + prologue + + when (not (isJust maybe_index_url)) $ + ppHtmlIndex odir doctitle maybe_package maybe_html_help_format + maybe_contents_url maybe_source_url maybe_wiki_url visible_hmods + + when (not (isJust maybe_contents_url && isJust maybe_index_url)) $ + ppHtmlHelpFiles doctitle maybe_package hmods odir maybe_html_help_format [] + + mapM_ (ppHtmlModule odir doctitle + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url) visible_hmods + +ppHtmlHelpFiles + :: String -- doctitle + -> Maybe String -- package + -> [HaddockModule] + -> FilePath -- destination directory + -> Maybe String -- the Html Help format (--html-help) + -> [FilePath] -- external packages paths + -> IO () +ppHtmlHelpFiles doctitle maybe_package hmods odir maybe_html_help_format pkg_paths = do + let + visible_hmods = filter visible hmods + visible i = OptHide `notElem` hmod_options i + + -- Generate index and contents page for Html Help if requested + case maybe_html_help_format of + Nothing -> return () + Just "mshelp" -> ppHHProject odir doctitle maybe_package visible_hmods pkg_paths + Just "mshelp2" -> do + ppHH2Files odir maybe_package visible_hmods pkg_paths + ppHH2Collection odir doctitle maybe_package + Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_hmods + Just format -> fail ("The "++format++" format is not implemented") + +copyFile :: FilePath -> FilePath -> IO () +copyFile fromFPath toFPath = + (bracket (openFile fromFPath ReadMode) hClose $ \hFrom -> + bracket (openFile toFPath WriteMode) hClose $ \hTo -> + allocaBytes bufferSize $ \buffer -> + copyContents hFrom hTo buffer) + where + bufferSize = 1024 + + copyContents hFrom hTo buffer = do + count <- hGetBuf hFrom buffer bufferSize + when (count > 0) $ do + hPutBuf hTo buffer count + copyContents hFrom hTo buffer + + +copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO () +copyHtmlBits odir libdir maybe_css = do + let + libhtmldir = pathJoin [libdir, "html"] + css_file = case maybe_css of + Nothing -> pathJoin [libhtmldir, cssFile] + Just f -> f + css_destination = pathJoin [odir, cssFile] + copyLibFile f = do + copyFile (pathJoin [libhtmldir, f]) (pathJoin [odir, f]) + copyFile css_file css_destination + mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile ] + +footer :: HtmlTable +footer = + tda [theclass "botbar"] << + ( toHtml "Produced by" <+> + (anchor ! [href projectUrl] << toHtml projectName) <+> + toHtml ("version " ++ projectVersion) + ) + +srcButton :: SourceURLs -> Maybe HaddockModule -> HtmlTable +srcButton (Just src_base_url, _, _) Nothing = + topButBox (anchor ! [href src_base_url] << toHtml "Source code") + +srcButton (_, Just src_module_url, _) (Just hmod) = + let url = spliceURL (Just $ hmod_orig_filename hmod) + (Just $ hmod_mod hmod) Nothing src_module_url + in topButBox (anchor ! [href url] << toHtml "Source code") + +srcButton _ _ = + Html.emptyTable + +spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> String -> String +spliceURL maybe_file maybe_mod maybe_name url = run url + where + file = fromMaybe "" maybe_file + mod = case maybe_mod of + Nothing -> "" + Just mod -> moduleString mod + + (name, kind) = + case maybe_name of + Nothing -> ("","") + Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v") + | otherwise -> (escapeStr (getOccString n), "t") + + run "" = "" + run ('%':'M':rest) = mod ++ run rest + run ('%':'F':rest) = file ++ run rest + run ('%':'N':rest) = name ++ run rest + run ('%':'K':rest) = kind ++ run rest + + run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mod ++ run rest + run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest + run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest + run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest + + run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) = + map (\x -> if x == '.' then c else x) mod ++ run rest + + run (c:rest) = c : run rest + +wikiButton :: WikiURLs -> Maybe Module -> HtmlTable +wikiButton (Just wiki_base_url, _, _) Nothing = + topButBox (anchor ! [href wiki_base_url] << toHtml "User Comments") + +wikiButton (_, Just wiki_module_url, _) (Just mod) = + let url = spliceURL Nothing (Just mod) Nothing wiki_module_url + in topButBox (anchor ! [href url] << toHtml "User Comments") + +wikiButton _ _ = + Html.emptyTable + +contentsButton :: Maybe String -> HtmlTable +contentsButton maybe_contents_url + = topButBox (anchor ! [href url] << toHtml "Contents") + where url = case maybe_contents_url of + Nothing -> contentsHtmlFile + Just url -> url + +indexButton :: Maybe String -> HtmlTable +indexButton maybe_index_url + = topButBox (anchor ! [href url] << toHtml "Index") + where url = case maybe_index_url of + Nothing -> indexHtmlFile + Just url -> url + +simpleHeader :: String -> Maybe String -> Maybe String + -> SourceURLs -> WikiURLs -> HtmlTable +simpleHeader doctitle maybe_contents_url maybe_index_url + maybe_source_url maybe_wiki_url = + (tda [theclass "topbar"] << + vanillaTable << ( + (td << + image ! [src "haskell_icon.gif", width "16", height 16, alt " " ] + ) <-> + (tda [theclass "title"] << toHtml doctitle) <-> + srcButton maybe_source_url Nothing <-> + wikiButton maybe_wiki_url Nothing <-> + contentsButton maybe_contents_url <-> indexButton maybe_index_url + )) + +pageHeader :: String -> HaddockModule -> String + -> SourceURLs -> WikiURLs + -> Maybe String -> Maybe String -> HtmlTable +pageHeader mdl hmod doctitle + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url = + (tda [theclass "topbar"] << + vanillaTable << ( + (td << + image ! [src "haskell_icon.gif", width "16", height 16, alt " "] + ) <-> + (tda [theclass "title"] << toHtml doctitle) <-> + srcButton maybe_source_url (Just hmod) <-> + wikiButton maybe_wiki_url (Just $ hmod_mod hmod) <-> + contentsButton maybe_contents_url <-> + indexButton maybe_index_url + ) + ) + tda [theclass "modulebar"] << + (vanillaTable << ( + (td << font ! [size "6"] << toHtml mdl) <-> + moduleInfo hmod + ) + ) + +moduleInfo :: HaddockModule -> HtmlTable +moduleInfo hmod = + let + info = hmod_info hmod + + doOneEntry :: (String, (GHC.HaddockModInfo GHC.Name) -> Maybe String) -> Maybe HtmlTable + doOneEntry (fieldName,field) = case field info of + Nothing -> Nothing + Just fieldValue -> + Just ((tda [theclass "infohead"] << toHtml fieldName) + <-> (tda [theclass "infoval"]) << toHtml fieldValue) + + entries :: [HtmlTable] + entries = mapMaybe doOneEntry [ + ("Portability",GHC.hmi_portability), + ("Stability",GHC.hmi_stability), + ("Maintainer",GHC.hmi_maintainer) + ] + in + case entries of + [] -> Html.emptyTable + _ -> tda [align "right"] << narrowTable << (foldl1 () entries) + +-- --------------------------------------------------------------------------- +-- Generate the module contents + +ppHtmlContents + :: FilePath + -> String + -> Maybe String + -> Maybe String + -> Maybe String + -> SourceURLs + -> WikiURLs + -> [HaddockModule] -> Bool -> Maybe (GHC.HsDoc GHC.RdrName) + -> IO () +ppHtmlContents odir doctitle + maybe_package maybe_html_help_format maybe_index_url + maybe_source_url maybe_wiki_url modules showPkgs prologue = do + let tree = mkModuleTree showPkgs + [(hmod_mod mod, toDescription mod) | mod <- modules] + html = + header + (documentCharacterEncoding +++ + thetitle (toHtml doctitle) +++ + styleSheet +++ + (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++ + body << vanillaTable << ( + simpleHeader doctitle Nothing maybe_index_url + maybe_source_url maybe_wiki_url + ppPrologue doctitle prologue + ppModuleTree doctitle tree + s15 + footer + ) + writeFile (pathJoin [odir, contentsHtmlFile]) (renderHtml html) + + -- Generate contents page for Html Help if requested + case maybe_html_help_format of + Nothing -> return () + Just "mshelp" -> ppHHContents odir doctitle maybe_package tree + Just "mshelp2" -> ppHH2Contents odir doctitle maybe_package tree + Just "devhelp" -> return () + Just format -> fail ("The "++format++" format is not implemented") + +ppPrologue :: String -> Maybe (GHC.HsDoc GHC.RdrName) -> HtmlTable +ppPrologue title Nothing = Html.emptyTable +ppPrologue title (Just doc) = + (tda [theclass "section1"] << toHtml title) + docBox (rdrDocToHtml doc) + +ppModuleTree :: String -> [ModuleTree] -> HtmlTable +ppModuleTree _ ts = + tda [theclass "section1"] << toHtml "Modules" + td << vanillaTable2 << htmlTable + where + genTable htmlTable id [] = (htmlTable,id) + genTable htmlTable id (x:xs) = genTable (htmlTable u) id' xs + where + (u,id') = mkNode [] x 0 id + + (htmlTable,_) = genTable emptyTable 0 ts + +mkNode :: [String] -> ModuleTree -> Int -> Int -> (HtmlTable,Int) +mkNode ss (Node s leaf pkg short ts) depth id = htmlNode + where + htmlNode = case ts of + [] -> (td_pad_w 1.25 depth << htmlModule <-> shortDescr <-> htmlPkg,id) + _ -> (td_w depth << (collapsebutton id_s +++ htmlModule) <-> shortDescr <-> htmlPkg + (td_subtree << sub_tree), id') + + mod_width = 50::Int {-em-} + + td_pad_w pad depth = + tda [thestyle ("padding-left: " ++ show pad ++ "em;" ++ + "width: " ++ show (mod_width - depth*2) ++ "em")] + + td_w depth = + tda [thestyle ("width: " ++ show (mod_width - depth*2) ++ "em")] + + td_subtree = + tda [thestyle ("padding: 0; padding-left: 2em")] + + shortDescr :: HtmlTable + shortDescr = case short of + Nothing -> td empty + Just doc -> tda [theclass "rdoc"] (origDocToHtml doc) + + htmlModule + | leaf = ppModule (mkModule (stringToPackageId pkgName) + (mkModuleName mdl)) "" + | otherwise = toHtml s + + -- ehm.. TODO: change the ModuleTree type + (htmlPkg, pkgName) = case pkg of + Nothing -> (td << empty, "") + Just p -> (td << toHtml p, p) + + mdl = foldr (++) "" (s' : map ('.':) ss') + (s':ss') = reverse (s:ss) + -- reconstruct the module name + + id_s = "n:" ++ show id + + (sub_tree,id') = genSubTree emptyTable (id+1) ts + + genSubTree :: HtmlTable -> Int -> [ModuleTree] -> (Html,Int) + genSubTree htmlTable id [] = (sub_tree,id) + where + sub_tree = collapsed vanillaTable2 id_s htmlTable + genSubTree htmlTable id (x:xs) = genSubTree (htmlTable u) id' xs + where + (u,id') = mkNode (s:ss) x (depth+1) id + +-- The URL for source and wiki links, and the current module +type LinksInfo = (SourceURLs, WikiURLs, HaddockModule) + + +-- --------------------------------------------------------------------------- +-- Generate the index + +ppHtmlIndex :: FilePath + -> String + -> Maybe String + -> Maybe String + -> Maybe String + -> SourceURLs + -> WikiURLs + -> [HaddockModule] + -> IO () +ppHtmlIndex odir doctitle maybe_package maybe_html_help_format + maybe_contents_url maybe_source_url maybe_wiki_url modules = do + let html = + header (documentCharacterEncoding +++ + thetitle (toHtml (doctitle ++ " (Index)")) +++ + styleSheet) +++ + body << vanillaTable << ( + simpleHeader doctitle maybe_contents_url Nothing + maybe_source_url maybe_wiki_url + index_html + ) + + when split_indices $ + mapM_ (do_sub_index index) initialChars + + writeFile (pathJoin [odir, indexHtmlFile]) (renderHtml html) + + -- Generate index and contents page for Html Help if requested + case maybe_html_help_format of + Nothing -> return () + Just "mshelp" -> ppHHIndex odir maybe_package modules + Just "mshelp2" -> ppHH2Index odir maybe_package modules + Just "devhelp" -> return () + Just format -> fail ("The "++format++" format is not implemented") + where + split_indices = length index > 50 + + index_html + | split_indices = + tda [theclass "section1"] << + toHtml ("Index") + indexInitialLetterLinks + | otherwise = + td << table ! [cellpadding 0, cellspacing 5] << + aboves (map indexElt index) + + indexInitialLetterLinks = + td << table ! [cellpadding 0, cellspacing 5] << + besides [ td << anchor ! [href (subIndexHtmlFile c)] << + toHtml [c] + | c <- initialChars + , any ((==c) . toUpper . head . fst) index ] + + do_sub_index this_ix c + = unless (null index_part) $ + writeFile (pathJoin [odir, subIndexHtmlFile c]) (renderHtml html) + where + html = header (documentCharacterEncoding +++ + thetitle (toHtml (doctitle ++ " (Index)")) +++ + styleSheet) +++ + body << vanillaTable << ( + simpleHeader doctitle maybe_contents_url Nothing + maybe_source_url maybe_wiki_url + indexInitialLetterLinks + tda [theclass "section1"] << + toHtml ("Index (" ++ c:")") + td << table ! [cellpadding 0, cellspacing 5] << + aboves (map indexElt index_part) + ) + + index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c] + + index :: [(String, Map GHC.Name [(Module,Bool)])] + index = sortBy cmp (Map.toAscList full_index) + where cmp (n1,_) (n2,_) = n1 `compare` n2 + + -- for each name (a plain string), we have a number of original HsNames that + -- it can refer to, and for each of those we have a list of modules + -- that export that entity. Each of the modules exports the entity + -- in a visible or invisible way (hence the Bool). + full_index :: Map String (Map GHC.Name [(Module,Bool)]) + full_index = Map.fromListWith (flip (Map.unionWith (++))) + (concat (map getHModIndex modules)) + + getHModIndex hmod = + [ (getOccString name, + Map.fromList [(name, [(mdl, name `elem` hmod_visible_exports hmod)])]) + | name <- hmod_exports hmod ] + where mdl = hmod_mod hmod + + indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable + indexElt (str, entities) = + case Map.toAscList entities of + [(nm,entries)] -> + tda [ theclass "indexentry" ] << toHtml str <-> + indexLinks nm entries + many_entities -> + tda [ theclass "indexentry" ] << toHtml str + aboves (map doAnnotatedEntity (zip [1..] many_entities)) + + doAnnotatedEntity (j,(nm,entries)) + = tda [ theclass "indexannot" ] << + toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <-> + indexLinks nm entries + + ppAnnot n | not (isValOcc n) = toHtml "Type/Class" + | isDataOcc n = toHtml "Data Constructor" + | otherwise = toHtml "Function" + + indexLinks nm entries = + tda [ theclass "indexlinks" ] << + hsep (punctuate comma + [ if visible then + linkId mod (Just nm) << toHtml (moduleString mod) + else + toHtml (moduleString mod) + | (mod, visible) <- entries ]) + + initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" + +-- --------------------------------------------------------------------------- +-- Generate the HTML page for a module + +ppHtmlModule + :: FilePath -> String + -> SourceURLs -> WikiURLs + -> Maybe String -> Maybe String + -> HaddockModule -> IO () +ppHtmlModule odir doctitle + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url hmod = do + let + mod = hmod_mod hmod + mdl = moduleString mod + html = + header (documentCharacterEncoding +++ + thetitle (toHtml mdl) +++ + styleSheet +++ + (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++ + body << vanillaTable << ( + pageHeader mdl hmod doctitle + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url s15 + hmodToHtml maybe_source_url maybe_wiki_url hmod s15 + footer + ) + writeFile (pathJoin [odir, moduleHtmlFile mod]) (renderHtml html) + +hmodToHtml :: SourceURLs -> WikiURLs -> HaddockModule -> HtmlTable +hmodToHtml maybe_source_url maybe_wiki_url hmod + = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: bdy) + where + docMap = hmod_rn_doc_map hmod + + exports = numberSectionHeadings (hmod_rn_export_items hmod) + + has_doc (ExportDecl _ _ doc _) = isJust doc + has_doc (ExportNoDecl _ _ _) = False + has_doc (ExportModule _) = False + has_doc _ = True + + no_doc_at_all = not (any has_doc exports) + + contents = td << vanillaTable << ppModuleContents exports + + description + = case hmod_rn_doc hmod of + Nothing -> Html.emptyTable + Just doc -> (tda [theclass "section1"] << toHtml "Description") + docBox (docToHtml doc) + + -- omit the synopsis if there are no documentation annotations at all + synopsis + | no_doc_at_all = Html.emptyTable + | otherwise + = (tda [theclass "section1"] << toHtml "Synopsis") + s15 + (tda [theclass "body"] << vanillaTable << + abovesSep s8 (map (processExport True linksInfo docMap) + (filter forSummary exports)) + ) + + -- if the documentation doesn't begin with a section header, then + -- add one ("Documentation"). + maybe_doc_hdr + = case exports of + [] -> Html.emptyTable + ExportGroup _ _ _ : _ -> Html.emptyTable + _ -> tda [ theclass "section1" ] << toHtml "Documentation" + + bdy = map (processExport False linksInfo docMap) exports + linksInfo = (maybe_source_url, maybe_wiki_url, hmod) + +ppModuleContents :: [ExportItem DocName] -> HtmlTable +ppModuleContents exports + | length sections == 0 = Html.emptyTable + | otherwise = tda [theclass "section4"] << bold << toHtml "Contents" + td << dlist << concatHtml sections + where + (sections, _leftovers{-should be []-}) = process 0 exports + + process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName]) + process _ [] = ([], []) + process n items@(ExportGroup lev id0 doc : rest) + | lev <= n = ( [], items ) + | otherwise = ( html:secs, rest2 ) + where + html = (dterm << linkedAnchor id0 << docToHtml doc) + +++ mk_subsections ssecs + (ssecs, rest1) = process lev rest + (secs, rest2) = process n rest1 + process n (_ : rest) = process n rest + + mk_subsections [] = noHtml + mk_subsections ss = ddef << dlist << concatHtml ss + +-- we need to assign a unique id to each section heading so we can hyperlink +-- them from the contents: +numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName] +numberSectionHeadings exports = go 1 exports + where go :: Int -> [ExportItem DocName] -> [ExportItem DocName] + go _ [] = [] + go n (ExportGroup lev _ doc : es) + = ExportGroup lev (show n) doc : go (n+1) es + go n (other:es) + = other : go n es + +processExport :: Bool -> LinksInfo -> DocMap -> (ExportItem DocName) -> HtmlTable +processExport _ _ _ (ExportGroup lev id0 doc) + = ppDocGroup lev (namedAnchor id0 << docToHtml doc) +processExport summary links docMap (ExportDecl x decl doc insts) + = doDecl summary links x decl doc insts docMap +processExport summmary _ _ (ExportNoDecl _ y []) + = declBox (ppDocName y) +processExport summmary _ _ (ExportNoDecl _ y subs) + = declBox (ppDocName y <+> parenList (map ppDocName subs)) +processExport _ _ _ (ExportDoc doc) + = docBox (docToHtml doc) +processExport _ _ _ (ExportModule mod) + = declBox (toHtml "module" <+> ppModule mod "") + +forSummary :: (ExportItem DocName) -> Bool +forSummary (ExportGroup _ _ _) = False +forSummary (ExportDoc _) = False +forSummary _ = True + +ppDocGroup :: Int -> Html -> HtmlTable +ppDocGroup lev doc + | lev == 1 = tda [ theclass "section1" ] << doc + | lev == 2 = tda [ theclass "section2" ] << doc + | lev == 3 = tda [ theclass "section3" ] << doc + | otherwise = tda [ theclass "section4" ] << doc + +declWithDoc :: Bool -> LinksInfo -> SrcSpan -> Name -> Maybe (HsDoc DocName) -> Html -> HtmlTable +declWithDoc True _ _ _ _ html_decl = declBox html_decl +declWithDoc False links loc nm Nothing html_decl = topDeclBox links loc nm html_decl +declWithDoc False links loc nm (Just doc) html_decl = + topDeclBox links loc nm html_decl docBox (docToHtml doc) + +doDecl :: Bool -> LinksInfo -> Name -> LHsDecl DocName -> + Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> HtmlTable +doDecl summary links x (L loc d) mbDoc instances docMap = doDecl d + where + doDecl (TyClD d) = doTyClD d + doDecl (SigD s) = ppSig summary links loc mbDoc s + doDecl (ForD d) = ppFor summary links loc mbDoc d + + doTyClD d0@(TyData {}) = ppDataDecl summary links instances x loc mbDoc d0 + doTyClD d0@(TySynonym {}) = ppTySyn summary links loc mbDoc d0 + doTyClD d0@(ClassDecl {}) = ppClassDecl summary links instances x loc mbDoc docMap d0 + +ppSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> Sig DocName -> HtmlTable +ppSig summary links loc mbDoc (TypeSig lname ltype) + | summary || noArgDocs t = + declWithDoc summary links loc n mbDoc (ppTypeSig summary n t) + | otherwise = topDeclBox links loc n (ppBinder False n) + (tda [theclass "body"] << vanillaTable << ( + do_args dcolon t + (case mbDoc of + Just doc -> ndocBox (docToHtml doc) + Nothing -> Html.emptyTable) + )) + + where + t = unLoc ltype + NoLink n = unLoc lname + + noLArgDocs (L _ t) = noArgDocs t + noArgDocs (HsForAllTy _ _ _ t) = noLArgDocs t + noArgDocs (HsFunTy (L _ (HsDocTy _ _)) _) = False + noArgDocs (HsFunTy _ r) = noLArgDocs r + noArgDocs (HsDocTy _ _) = False + noArgDocs _ = True + + do_largs leader (L _ t) = do_args leader t + do_args :: Html -> (HsType DocName) -> HtmlTable + do_args leader (HsForAllTy Explicit tvs lctxt ltype) + = (argBox ( + leader <+> + hsep (keyword "forall" : ppTyVars tvs ++ [dot]) <+> + ppLContextNoArrow lctxt) + <-> rdocBox noHtml) + do_largs darrow ltype + do_args leader (HsForAllTy Implicit _ lctxt ltype) + = (argBox (leader <+> ppLContextNoArrow lctxt) + <-> rdocBox noHtml) + do_largs darrow ltype + do_args leader (HsFunTy (L _ (HsDocTy lt ldoc)) r) + = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc))) + do_largs arrow r + do_args leader (HsFunTy lt r) + = (argBox (leader <+> ppLType lt) <-> rdocBox noHtml) do_largs arrow r + do_args leader (HsDocTy lt ldoc) + = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc))) + do_args leader t + = argBox (leader <+> ppType t) <-> rdocBox (noHtml) + +ppTyVars tvs = map ppName (tyvarNames tvs) + +tyvarNames = map f + where f x = let NoLink n = hsTyVarName (unLoc x) in n + +ppFor summary links loc mbDoc (ForeignImport lname ltype _) + = ppSig summary links loc mbDoc (TypeSig lname ltype) +ppFor _ _ _ _ _ = error "ppFor" + +-- we skip type patterns for now +ppTySyn summary links loc mbDoc (TySynonym lname ltyvars _ ltype) + = declWithDoc summary links loc n mbDoc ( + hsep ([keyword "type", ppBinder summary n] + ++ ppTyVars ltyvars) <+> equals <+> ppLType ltype) + where NoLink n = unLoc lname + +ppLType (L _ t) = ppType t + +ppTypeSig :: Bool -> Name -> (HsType DocName) -> Html +ppTypeSig summary nm ty = ppBinder summary nm <+> dcolon <+> ppType ty + +-------------------------------------------------------------------------------- +-- Contexts +-------------------------------------------------------------------------------- + +ppLContext = ppContext . unLoc +ppLContextNoArrow = ppContextNoArrow . unLoc + +ppContextNoArrow :: HsContext DocName -> Html +ppContextNoArrow [] = empty +ppContextNoArrow cxt = pp_hs_context (map unLoc cxt) + +ppContextNoLocs :: [HsPred DocName] -> Html +ppContextNoLocs [] = empty +ppContextNoLocs cxt = pp_hs_context cxt <+> darrow + +ppContext :: HsContext DocName -> Html +ppContext cxt = ppContextNoLocs (map unLoc cxt) + +pp_hs_context [] = empty +pp_hs_context [p] = ppPred p +pp_hs_context cxt = parenList (map ppPred cxt) + +ppLPred = ppPred . unLoc + +ppPred (HsClassP n ts) = ppDocName n <+> hsep (map ppLType ts) +-- TODO: find out what happened to the Dupable/Linear distinction +ppPred (HsIParam (IPName n) t) + = toHtml "?" +++ ppDocName n <+> dcolon <+> ppLType 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) + <+> ppFds fds + +ppFds fds = + if null fds then noHtml else + char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) + where + fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> toHtml "->" <+> + hsep (map ppDocName vars2) + +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> DocMap -> HtmlTable +ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc docMap = + if null sigs && null ats + then (if summary then declBox else topDeclBox links loc nm) hdr + else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where") + + (tda [theclass "body"] << + vanillaTable << + aboves ([ ppAT summary at | L _ at <- ats ] ++ + [ ppSig summary links loc mbDoc sig + | L _ sig@(TypeSig (L _ (NoLink n)) ty) <- sigs, let mbDoc = Map.lookup n docMap ]) + ) + where + hdr = ppClassHdr summary lctxt nm tvs fds + NoLink nm = unLoc lname + + ppAT summary at = case at of + TyData {} -> topDeclBox links loc nm (ppDataHeader summary at) + _ -> error "associated type synonyms or type families not supported yet" + +-- we skip ATs for now +ppClassDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key -> SrcSpan -> + Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName -> + HtmlTable +ppClassDecl summary links instances orig_c loc mbDoc docMap + decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ _ _) + | summary = ppShortClassDecl summary links decl loc docMap + | otherwise + = classheader + tda [theclass "body"] << vanillaTable << ( + classdoc methodsBit instancesBit + ) + where + classheader + | null lsigs = topDeclBox links loc nm hdr + | otherwise = topDeclBox links loc nm (hdr <+> keyword "where") + + NoLink nm = unLoc lname + ctxt = unLoc lctxt + + hdr = ppClassHdr summary lctxt nm ltyvars lfds + + classdoc = case mbDoc of + Nothing -> Html.emptyTable + Just d -> ndocBox (docToHtml d) + + methodsBit + | null lsigs = Html.emptyTable + | otherwise = + s8 methHdr + tda [theclass "body"] << vanillaTable << ( + abovesSep s8 [ ppSig summary links loc mbDoc sig + | L _ sig@(TypeSig n _) <- lsigs, + let mbDoc = Map.lookup (orig n) docMap ] + ) + + instId = collapseId nm + instancesBit + | null instances = Html.emptyTable + | otherwise + = s8 instHdr instId + tda [theclass "body"] << + collapsed thediv instId ( + spacedTable1 << ( + aboves (map (declBox . ppInstHead) instances) + )) + +ppInstHead :: InstHead DocName -> Html +ppInstHead ([], n, ts) = ppAsst n ts +ppInstHead (ctxt, n, ts) = ppContextNoLocs ctxt <+> ppAsst n ts + +ppAsst n ts = ppDocName n <+> hsep (map ppParendType ts) + +-- ----------------------------------------------------------------------------- +-- Data & newtype declarations + +orig (L _ (NoLink name)) = name +orig _ = error "orig" + +-- TODO: print contexts +ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> + Maybe (HsDoc DocName) -> TyClDecl DocName -> Html +ppShortDataDecl summary links loc mbDoc dataDecl + + | [lcon] <- cons, ResTyH98 <- resTy = + ppDataHeader summary dataDecl + <+> equals <+> ppShortConstr summary (unLoc lcon) + + | [] <- cons = ppDataHeader summary dataDecl + + | otherwise = vanillaTable << ( + case resTy of + ResTyH98 -> dataHeader + tda [theclass "body"] << vanillaTable << ( + aboves (zipWith doConstr ('=':repeat '|') cons) + ) + ResTyGADT _ -> dataHeader + tda [theclass "body"] << vanillaTable << ( + aboves (map doGADTConstr cons) + ) + ) + + where + dataHeader = + (if summary then declBox else topDeclBox links loc name) + ((ppDataHeader summary dataDecl) <+> + case resTy of ResTyGADT _ -> keyword "where"; _ -> empty) + + doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con)) + doGADTConstr con = declBox (ppShortConstr summary (unLoc con)) + + name = orig (tcdLName dataDecl) + context = unLoc (tcdCtxt dataDecl) + newOrData = tcdND dataDecl + tyVars = tyvarNames (tcdTyVars dataDecl) + mbKSig = tcdKindSig dataDecl + cons = tcdCons dataDecl + resTy = (con_res . unLoc . head) cons + +ppDataDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key -> + SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> HtmlTable +ppDataDecl summary links instances x loc mbDoc dataDecl + + | summary = declWithDoc summary links loc name mbDoc + (ppShortDataDecl summary links loc mbDoc dataDecl) + + | otherwise = dataHeader + tda [theclass "body"] << vanillaTable << ( + datadoc + constrBit + instancesBit + ) + + where + name = orig (tcdLName dataDecl) + context = unLoc (tcdCtxt dataDecl) + newOrData = tcdND dataDecl + tyVars = tyvarNames (tcdTyVars dataDecl) + mbKSig = tcdKindSig dataDecl + cons = tcdCons dataDecl + resTy = (con_res . unLoc . head) cons + + dataHeader = + (if summary then declBox else topDeclBox links loc name) + ((ppDataHeader summary dataDecl) <+> whereBit) + + whereBit + | null cons = empty + | otherwise = case resTy of + ResTyGADT _ -> keyword "where" + _ -> empty + + constrTable + | any isRecCon cons = spacedTable5 + | otherwise = spacedTable1 + + datadoc = case mbDoc of + Just doc -> ndocBox (docToHtml doc) + Nothing -> Html.emptyTable + + constrBit + | null cons = Html.emptyTable + | otherwise = constrHdr ( + tda [theclass "body"] << constrTable << + aboves (map ppSideBySideConstr cons) + ) + + instId = collapseId name + + instancesBit + | null instances = Html.emptyTable + | otherwise + = instHdr instId + tda [theclass "body"] << + collapsed thediv instId ( + spacedTable1 << ( + aboves (map (declBox . ppInstHead) instances) + ) + ) + +isRecCon lcon = case con_details (unLoc lcon) of + RecCon _ -> True + _ -> False + +ppShortConstr :: Bool -> ConDecl DocName -> Html +ppShortConstr summary con = case con_res con of + + ResTyH98 -> case con_details con of + PrefixCon args -> header +++ hsep (ppBinder summary name : map ppLType args) + RecCon fields -> header +++ ppBinder summary name <+> + braces (vanillaTable << aboves (map (ppShortField summary) fields)) + InfixCon arg1 arg2 -> header +++ + hsep [ppLType arg1, ppBinder summary name, ppLType arg2] + + ResTyGADT resTy -> case con_details con of + PrefixCon args -> doGADTCon args resTy + RecCon _ -> error "GADT records not suported" + InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + + where + doGADTCon args resTy = ppBinder summary name <+> dcolon <+> hsep [ + ppForAll forall ltvs lcontext, + ppLType (foldr mkFunTy resTy args) ] + + header = ppConstrHdr forall tyVars context + name = orig (con_name con) + ltvs = con_qvars con + tyVars = tyvarNames ltvs + lcontext = con_cxt con + context = unLoc (con_cxt con) + forall = con_explicit con + mkFunTy a b = noLoc (HsFunTy a b) + +ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Html +ppConstrHdr forall tvs ctxt + = (if null tvs then noHtml else ppForall) + +++ + (if null ctxt then noHtml else ppContext ctxt <+> toHtml "=> ") + where + ppForall = case forall of + Explicit -> keyword "forall" <+> hsep (map ppName tvs) <+> toHtml ". " + Implicit -> empty + +ppSideBySideConstr :: LConDecl DocName -> HtmlTable +ppSideBySideConstr (L _ con) = case con_res con of + + ResTyH98 -> case con_details con of + + PrefixCon args -> + argBox (hsep ((header +++ ppBinder False name) : map ppLType args)) + <-> maybeRDocBox mbLDoc + + RecCon fields -> + argBox (header +++ ppBinder False name) <-> + maybeRDocBox mbLDoc + (tda [theclass "body"] << spacedTable1 << + aboves (map ppSideBySideField fields)) + + InfixCon arg1 arg2 -> + argBox (hsep [header+++ppLType arg1, ppBinder False name, ppLType arg2]) + <-> maybeRDocBox mbLDoc + + ResTyGADT resTy -> case con_details con of + PrefixCon args -> doGADTCon args resTy + RecCon _ -> error "GADT records not supported" + InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + + where + doGADTCon args resTy = argBox (ppBinder False name <+> dcolon <+> hsep [ + ppForAll forall ltvs (con_cxt con), + ppLType (foldr mkFunTy resTy args) ] + ) <-> maybeRDocBox mbLDoc + + + header = ppConstrHdr forall tyVars context + name = orig (con_name con) + ltvs = con_qvars con + tyVars = tyvarNames (con_qvars con) + context = unLoc (con_cxt con) + forall = con_explicit con + mbLDoc = con_doc con + mkFunTy a b = noLoc (HsFunTy a b) + +ppSideBySideField :: HsRecField DocName (LHsType DocName) -> HtmlTable +ppSideBySideField (HsRecField lname ltype mbLDoc) = + argBox (ppBinder False (orig lname) + <+> dcolon <+> ppLType ltype) <-> + maybeRDocBox mbLDoc + +{- +ppHsFullConstr :: HsConDecl -> Html +ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = + declWithDoc False doc ( + hsep ((ppHsConstrHdr tvs ctxt +++ + ppHsBinder False nm) : map ppHsBangType typeList) + ) +ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = + td << vanillaTable << ( + case doc of + Nothing -> aboves [hdr, fields_html] + Just _ -> aboves [hdr, constr_doc, fields_html] + ) + + where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) + + constr_doc + | isJust doc = docBox (docToHtml (fromJust doc)) + | otherwise = Html.emptyTable + + fields_html = + td << + table ! [width "100%", cellpadding 0, cellspacing 8] << ( + aboves (map ppFullField (concat (map expandField fields))) + ) +-} + +ppShortField :: Bool -> HsRecField DocName (LHsType DocName)-> HtmlTable +ppShortField summary (HsRecField lname ltype mbLDoc) + = tda [theclass "recfield"] << ( + ppBinder summary (orig lname) + <+> dcolon <+> ppLType ltype + ) + +{- +ppFullField :: HsFieldDecl -> Html +ppFullField (HsFieldDecl [n] ty doc) + = declWithDoc False doc ( + ppHsBinder False n <+> dcolon <+> ppHsBangType ty + ) +ppFullField _ = error "ppFullField" + +expandField :: HsFieldDecl -> [HsFieldDecl] +expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] +-} + +-- | Print the LHS of a data/newtype declaration. +-- Currently doesn't handle 'data instance' decls or kind signatures +ppDataHeader :: Bool -> TyClDecl DocName -> Html +ppDataHeader summary decl + | not (isDataDecl decl) = error "ppDataHeader: illegal argument" + | otherwise = + -- newtype or data + (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> + -- context + ppLContext (tcdCtxt decl) <+> + -- T a b c ..., or a :+: b + (if isConSym name + then ppName (tyvars!!0) <+> ppBinder summary name <+> ppName (tyvars!!1) + else ppBinder summary name <+> hsep (map ppName tyvars)) + where + tyvars = tyvarNames $ tcdTyVars decl + name = orig $ tcdLName decl + +-- ---------------------------------------------------------------------------- +-- Types and contexts + +ppKind k = toHtml $ showSDoc (ppr k) + +{- +ppForAll Implicit _ lctxt = ppCtxtPart lctxt +ppForAll Explicit ltvs lctxt = + hsep (keyword "forall" : ppTyVars ltvs ++ [dot]) <+> ppCtxtPart lctxt +-} + +ppBang HsStrict = toHtml "!" +ppBang HsUnbox = toHtml "!!" + +tupleParens Boxed = parenList +tupleParens Unboxed = ubxParenList +{- +ppType :: HsType DocName -> Html +ppType t = case t of + t@(HsForAllTy expl ltvs lcontext ltype) -> ppForAllTy t <+> ppLType ltype + HsTyVar n -> ppDocName n + HsBangTy HsStrict lt -> toHtml "!" <+> ppLType lt + HsBangTy HsUnbox lt -> toHtml "!!" <+> ppLType lt + HsAppTy a b -> ppLType a <+> ppLType b + HsFunTy a b -> hsep [ppLType a, toHtml "->", ppLType b] + HsListTy t -> brackets $ ppLType t + HsPArrTy t -> toHtml "[:" +++ ppLType t +++ toHtml ":]" + HsTupleTy Boxed ts -> parenList $ map ppLType ts + HsTupleTy Unboxed ts -> ubxParenList $ map ppLType ts + HsOpTy a n b -> ppLType a <+> ppLDocName n <+> ppLType b + HsParTy t -> parens $ ppLType t + HsNumTy n -> toHtml (show n) + HsPredTy p -> ppPred p + HsKindSig t k -> hsep [ppLType t, dcolon, ppKind k] + HsSpliceTy _ -> error "ppType" + HsDocTy t _ -> ppLType t +-} +-------------------------------------------------------------------------------- +-- Rendering of HsType +-------------------------------------------------------------------------------- + +pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC +pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC + -- Used for LH arg of (->) +pREC_OP = (2 :: Int) -- Used for arg of any infix operator + -- (we don't keep their fixities around) +pREC_CON = (3 :: Int) -- Used for arg of type applicn: + -- always parenthesise unless atomic + +maybeParen :: Int -- Precedence of context + -> Int -- Precedence of top-level operator + -> Html -> Html -- Wrap in parens if (ctxt >= op) +maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p + | otherwise = p + +ppType ty = ppr_mono_ty pREC_TOP (prepare ty) +ppParendType ty = ppr_mono_ty pREC_CON ty + +-- Before printing a type +-- (a) Remove outermost HsParTy parens +-- (b) Drop top-level for-all type variables in user style +-- since they are implicit in Haskell +prepare (HsParTy ty) = prepare (unLoc ty) +prepare ty = ty + +ppForAll exp tvs cxt + | show_forall = forall_part <+> ppLContext cxt + | otherwise = ppLContext cxt + where + show_forall = not (null tvs) && is_explicit + is_explicit = case exp of {Explicit -> True; Implicit -> False} + forall_part = hsep (keyword "forall" : ppTyVars tvs) +++ dot + +ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) + +ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty) + = maybeParen ctxt_prec pREC_FUN $ + hsep [ppForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty] + +-- gaw 2004 +ppr_mono_ty ctxt_prec (HsBangTy b ty) = ppBang b +++ ppLType ty +ppr_mono_ty ctxt_prec (HsTyVar name) = ppDocName name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2 +ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (map ppLType tys) +ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppKind kind) +ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) +ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) +ppr_mono_ty ctxt_prec (HsPredTy pred) = parens (ppPred pred) +ppr_mono_ty ctxt_prec (HsNumTy n) = toHtml (show n) -- generics only +ppr_mono_ty ctxt_prec (HsSpliceTy s) = error "ppr_mono_ty-haddock" + +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) + = maybeParen ctxt_prec pREC_CON $ + hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty] + +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) + = maybeParen ctxt_prec pREC_OP $ + ppr_mono_lty pREC_OP ty1 <+> ppLDocName op <+> ppr_mono_lty pREC_OP ty2 + +ppr_mono_ty ctxt_prec (HsParTy ty) + = parens (ppr_mono_lty pREC_TOP ty) + +ppr_mono_ty ctxt_prec (HsDocTy ty doc) + = ppLType ty + +ppr_fun_ty ctxt_prec ty1 ty2 + = let p1 = ppr_mono_lty pREC_FUN ty1 + p2 = ppr_mono_lty pREC_TOP ty2 + in + maybeParen ctxt_prec pREC_FUN $ + hsep [p1, arrow <+> p2] + +-- ---------------------------------------------------------------------------- +-- Names + +ppOccName :: OccName -> Html +ppOccName name = toHtml $ occNameString name + +ppRdrName :: RdrName -> Html +ppRdrName = ppOccName . rdrNameOcc + +ppLDocName (L _ d) = ppDocName d + +ppDocName :: DocName -> Html +ppDocName (Link name) = linkId (nameModule name) (Just name) << ppName name +ppDocName (NoLink name) = toHtml (getOccString name) + +linkTarget :: Name -> Html +linkTarget name = namedAnchor (anchorNameStr name) << toHtml "" + +ppName :: Name -> Html +ppName name = toHtml (getOccString name) + +ppBinder :: Bool -> Name -> Html +-- The Bool indicates whether we are generating the summary, in which case +-- the binder will be a link to the full definition. +ppBinder True nm = linkedAnchor (anchorNameStr nm) << ppBinder' nm +ppBinder False nm = linkTarget nm +++ bold << ppBinder' nm + +ppBinder' :: Name -> Html +ppBinder' name + | isVarSym name = parens $ toHtml (getOccString name) + | otherwise = toHtml (getOccString name) + +linkId :: Module -> Maybe Name -> Html -> Html +linkId mod mbName = anchor ! [href hr] + where + hr = case mbName of + Nothing -> moduleHtmlFile mod + Just name -> nameHtmlRef mod name + +ppModule :: Module -> String -> Html +ppModule mod ref = anchor ! [href ((moduleHtmlFile mod) ++ ref)] + << toHtml (moduleString mod) + +-- ----------------------------------------------------------------------------- +-- * Doc Markup + +parHtmlMarkup :: (a -> Html) -> DocMarkup a Html +parHtmlMarkup ppId = Markup { + markupParagraph = paragraph, + markupEmpty = toHtml "", + markupString = toHtml, + markupAppend = (+++), + markupIdentifier = tt . ppId . head, + markupModule = \m -> ppModule (mkModuleNoPkg m) "", + markupEmphasis = emphasize . toHtml, + markupMonospaced = tt . toHtml, + markupUnorderedList = ulist . concatHtml . map (li <<), + markupOrderedList = olist . concatHtml . map (li <<), + markupDefList = dlist . concatHtml . map markupDef, + markupCodeBlock = pre, + markupURL = \url -> anchor ! [href url] << toHtml url, + markupAName = \aname -> namedAnchor aname << toHtml "" + } + +markupDef (a,b) = dterm << a +++ ddef << b + +htmlMarkup = parHtmlMarkup ppDocName +htmlOrigMarkup = parHtmlMarkup ppName +htmlRdrMarkup = parHtmlMarkup ppRdrName + +-- If the doc is a single paragraph, don't surround it with

    (this causes +-- ugly extra whitespace with some browsers). +docToHtml :: GHC.HsDoc DocName -> Html +docToHtml doc = markup htmlMarkup (unParagraph (markup htmlCleanup doc)) + +origDocToHtml :: GHC.HsDoc GHC.Name -> Html +origDocToHtml doc = markup htmlOrigMarkup (unParagraph (markup htmlCleanup doc)) + +rdrDocToHtml doc = markup htmlRdrMarkup (unParagraph (markup htmlCleanup doc)) + +-- If there is a single paragraph, then surrounding it with

    ..

    +-- can add too much whitespace in some browsers (eg. IE). However if +-- we have multiple paragraphs, then we want the extra whitespace to +-- separate them. So we catch the single paragraph case and transform it +-- here. +unParagraph (GHC.DocParagraph d) = d +--NO: This eliminates line breaks in the code block: (SDM, 6/5/2003) +--unParagraph (DocCodeBlock d) = (DocMonospaced d) +unParagraph doc = doc + +htmlCleanup :: DocMarkup a (GHC.HsDoc a) +htmlCleanup = idMarkup { + markupUnorderedList = GHC.DocUnorderedList . map unParagraph, + markupOrderedList = GHC.DocOrderedList . map unParagraph + } + +-- ----------------------------------------------------------------------------- +-- * Misc + +hsep :: [Html] -> Html +hsep [] = noHtml +hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls + +infixr 8 <+> +(<+>) :: Html -> Html -> Html +a <+> b = Html (getHtmlElements (toHtml a) ++ HtmlString " ": getHtmlElements (toHtml b)) + +keyword :: String -> Html +keyword s = thespan ! [theclass "keyword"] << toHtml s + +equals, comma :: Html +equals = char '=' +comma = char ',' + +char :: Char -> Html +char c = toHtml [c] + +empty :: Html +empty = noHtml + +parens, brackets, braces :: Html -> Html +parens h = char '(' +++ h +++ char ')' +brackets h = char '[' +++ h +++ char ']' +pabrackets h = toHtml "[:" +++ h +++ toHtml ":]" +braces h = char '{' +++ h +++ char '}' + +punctuate :: Html -> [Html] -> [Html] +punctuate _ [] = [] +punctuate h (d0:ds) = go d0 ds + where + go d [] = [d] + go d (e:es) = (d +++ h) : go e es + +abovesSep :: HtmlTable -> [HtmlTable] -> HtmlTable +abovesSep _ [] = Html.emptyTable +abovesSep h (d0:ds) = go d0 ds + where + go d [] = d + go d (e:es) = d h go e es + +parenList :: [Html] -> Html +parenList = parens . hsep . punctuate comma + +ubxParenList :: [Html] -> Html +ubxParenList = ubxparens . hsep . punctuate comma + +ubxparens :: Html -> Html +ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" + +{- +text :: Html +text = strAttr "TEXT" +-} + +-- a box for displaying code +declBox :: Html -> HtmlTable +declBox html = tda [theclass "decl"] << html + +-- a box for top level documented names +-- it adds a source and wiki link at the right hand side of the box +topDeclBox :: LinksInfo -> SrcSpan -> Name -> Html -> HtmlTable +topDeclBox ((_,_,Nothing), (_,_,Nothing), _) _ _ html = declBox html +topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url), hmod) + loc name html = + tda [theclass "topdecl"] << + ( table ! [theclass "declbar"] << + ((tda [theclass "declname"] << html) + <-> srcLink + <-> wikiLink) + ) + where srcLink = + case maybe_source_url of + Nothing -> Html.emptyTable + Just url -> tda [theclass "declbut"] << + let url' = spliceURL (Just fname) (Just mod) + (Just name) url + in anchor ! [href url'] << toHtml "Source" + wikiLink = + case maybe_wiki_url of + Nothing -> Html.emptyTable + Just url -> tda [theclass "declbut"] << + let url' = spliceURL (Just fname) (Just mod) + (Just name) url + in anchor ! [href url'] << toHtml "Comments" + + mod = hmod_mod hmod + fname = unpackFS (srcSpanFile loc) + +-- a box for displaying an 'argument' (some code which has text to the +-- right of it). Wrapping is not allowed in these boxes, whereas it is +-- in a declBox. +argBox :: Html -> HtmlTable +argBox html = tda [theclass "arg"] << html + +-- a box for displaying documentation, +-- indented and with a little padding at the top +docBox :: Html -> HtmlTable +docBox html = tda [theclass "doc"] << html + +-- a box for displaying documentation, not indented. +ndocBox :: Html -> HtmlTable +ndocBox html = tda [theclass "ndoc"] << html + +-- a box for displaying documentation, padded on the left a little +rdocBox :: Html -> HtmlTable +rdocBox html = tda [theclass "rdoc"] << html + +maybeRDocBox :: Maybe (GHC.LHsDoc DocName) -> HtmlTable +maybeRDocBox Nothing = rdocBox (noHtml) +maybeRDocBox (Just ldoc) = rdocBox (docToHtml (unLoc ldoc)) + +-- a box for the buttons at the top of the page +topButBox :: Html -> HtmlTable +topButBox html = tda [theclass "topbut"] << html + +-- a vanilla table has width 100%, no border, no padding, no spacing +-- a narrow table is the same but without width 100%. +vanillaTable, narrowTable :: Html -> Html +vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0] +vanillaTable2 = table ! [theclass "vanilla2", cellspacing 0, cellpadding 0] +narrowTable = table ! [theclass "narrow", cellspacing 0, cellpadding 0] + +spacedTable1, spacedTable5 :: Html -> Html +spacedTable1 = table ! [theclass "vanilla", cellspacing 1, cellpadding 0] +spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0] + +constrHdr, methHdr :: HtmlTable +constrHdr = tda [ theclass "section4" ] << toHtml "Constructors" +methHdr = tda [ theclass "section4" ] << toHtml "Methods" + +instHdr :: String -> HtmlTable +instHdr id = + tda [ theclass "section4" ] << (collapsebutton id +++ toHtml " Instances") + +dcolon, arrow, darrow :: Html +dcolon = toHtml "::" +arrow = toHtml "->" +darrow = toHtml "=>" +dot = toHtml "." + +s8, s15 :: HtmlTable +s8 = tda [ theclass "s8" ] << noHtml +s15 = tda [ theclass "s15" ] << noHtml + +namedAnchor :: String -> Html -> Html +namedAnchor n = anchor ! [name (escapeStr n)] + +-- +-- A section of HTML which is collapsible via a +/- button. +-- + +-- TODO: Currently the initial state is non-collapsed. Change the 'minusFile' +-- below to a 'plusFile' and the 'display:block;' to a 'display:none;' when we +-- use cookies from JavaScript to have a more persistent state. + +collapsebutton :: String -> Html +collapsebutton id = + image ! [ src minusFile, theclass "coll", onclick ("toggle(this,'" ++ id ++ "')"), alt "show/hide" ] + +collapsed :: (HTML a) => (Html -> Html) -> String -> a -> Html +collapsed fn id html = + fn ! [identifier id, thestyle "display:block;"] << html + +-- A quote is a valid part of a Haskell identifier, but it would interfere with +-- the ECMA script string delimiter used in collapsebutton above. +collapseId :: Name -> String +collapseId nm = "i:" ++ escapeStr (getOccString nm) + +linkedAnchor :: String -> Html -> Html +linkedAnchor frag = anchor ! [href hr] + where hr | null frag = "" + | otherwise = '#': escapeStr frag + +documentCharacterEncoding :: Html +documentCharacterEncoding = + meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"] + +styleSheet :: Html +styleSheet = + thelink ! [href cssFile, rel "stylesheet", thetype "text/css"] diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index becd40df..7964a3a5 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -4,7 +4,7 @@ module Haddock.InterfaceFile ( readInterfaceFile ) where -import HaddockTypes +import Haddock.Types import Haddock.Exception import Binary diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs new file mode 100644 index 00000000..e4c72880 --- /dev/null +++ b/src/Haddock/ModuleTree.hs @@ -0,0 +1,38 @@ +module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where + +import Haddock.Types ( DocName ) +import GHC ( HsDoc, Name ) +import Module ( Module, moduleNameString, moduleName, modulePackageId ) +import PackageConfig ( packageIdString ) + +data ModuleTree = Node String Bool (Maybe String) (Maybe (HsDoc Name)) [ModuleTree] + +mkModuleTree :: Bool -> [(Module, Maybe (HsDoc Name))] -> [ModuleTree] +mkModuleTree showPkgs mods = + foldr fn [] [ (splitModule mod, modPkg mod, short) | (mod, short) <- mods ] + where + modPkg mod | showPkgs = Just (packageIdString (modulePackageId mod)) + | otherwise = Nothing + fn (mod,pkg,short) trees = addToTrees mod pkg short trees + +addToTrees :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree] -> [ModuleTree] +addToTrees [] pkg short ts = ts +addToTrees ss pkg short [] = mkSubTree ss pkg short +addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) + | s1 > s2 = t : addToTrees (s1:ss) pkg short ts + | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts + | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts + where + this_pkg = if null ss then pkg else node_pkg + this_short = if null ss then short else node_short + +mkSubTree :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree] +mkSubTree [] pkg short = [] +mkSubTree [s] pkg short = [Node s True pkg short []] +mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)] + +splitModule :: Module -> [String] +splitModule mod = split (moduleNameString (moduleName mod)) + where split mod0 = case break (== '.') mod0 of + (s1, '.':s2) -> s1 : split s2 + (s1, _) -> [s1] diff --git a/src/Haddock/Rename.hs b/src/Haddock/Rename.hs new file mode 100644 index 00000000..7e12a412 --- /dev/null +++ b/src/Haddock/Rename.hs @@ -0,0 +1,320 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2003 +-- + +module Haddock.Rename ( + runRnFM, -- the monad (instance of Monad) + renameDoc, renameMaybeDoc, renameExportItems, +) where + +import Haddock.Types + +import GHC +import BasicTypes +import SrcLoc +import Bag ( emptyBag ) + +import Data.Map ( Map ) +import qualified Data.Map as Map hiding ( Map ) +import Prelude hiding ( mapM ) +import Data.Traversable ( mapM ) + +-- ----------------------------------------------------------------------------- +-- Monad for renaming + +-- The monad does two things for us: it passes around the environment for +-- renaming, and it returns a list of names which couldn't be found in +-- the environment. + +newtype GenRnM n a = + RnM { unRn :: (n -> (Bool, DocName)) -- name lookup function + -> (a,[n]) + } + +type RnM a = GenRnM Name a + +instance Monad (GenRnM n) where + (>>=) = thenRn + return = returnRn + +returnRn :: a -> GenRnM n a +returnRn a = RnM (\_ -> (a,[])) +thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b +m `thenRn` k = RnM (\lkp -> case unRn m lkp of + (a,out1) -> case unRn (k a) lkp of + (b,out2) -> (b,out1++out2)) + +getLookupRn :: RnM (Name -> (Bool, DocName)) +getLookupRn = RnM (\lkp -> (lkp,[])) +outRn :: Name -> RnM () +outRn name = RnM (\_ -> ((),[name])) + +lookupRn :: (DocName -> a) -> Name -> RnM a +lookupRn and_then name = do + lkp <- getLookupRn + case lkp name of + (False,maps_to) -> do outRn name; return (and_then maps_to) + (True, maps_to) -> return (and_then maps_to) + +runRnFM :: Map Name Name -> RnM a -> (a,[Name]) +runRnFM env rn = unRn rn lkp + where lkp n = case Map.lookup n env of + Nothing -> (False, NoLink n) + Just q -> (True, Link q) + +runRn :: (n -> (Bool,DocName)) -> GenRnM n a -> (a,[n]) +runRn lkp rn = unRn rn lkp + +-- ----------------------------------------------------------------------------- +-- Renaming + +keep n = NoLink n +keepL (L loc n) = L loc (NoLink n) + +rename = lookupRn id +renameL (L loc name) = return . L loc =<< rename name + +renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] +renameExportItems items = mapM renameExportItem items + +renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName)) +renameMaybeDoc mbDoc = mapM renameDoc mbDoc + +renameLDoc (L loc doc) = return . L loc =<< renameDoc doc + +renameDoc :: HsDoc Name -> RnM (HsDoc DocName) +renameDoc doc = case doc of + DocEmpty -> return DocEmpty + DocAppend a b -> do + a' <- renameDoc a + b' <- renameDoc b + return (DocAppend a' b') + DocString str -> return (DocString str) + DocParagraph doc -> do + doc' <- renameDoc doc + return (DocParagraph doc') + DocIdentifier ids -> do + lkp <- getLookupRn + case [ n | (True, n) <- map lkp ids ] of + ids'@(_:_) -> return (DocIdentifier ids') + [] -> return (DocIdentifier (map NoLink ids)) + DocModule str -> return (DocModule str) + DocEmphasis doc -> do + doc' <- renameDoc doc + return (DocEmphasis doc') + DocMonospaced doc -> do + doc' <- renameDoc doc + return (DocMonospaced doc') + DocUnorderedList docs -> do + docs' <- mapM renameDoc docs + return (DocUnorderedList docs') + DocOrderedList docs -> do + docs' <- mapM renameDoc docs + return (DocOrderedList docs') + DocDefList docs -> do + docs' <- mapM (\(a,b) -> do + a' <- renameDoc a + b' <- renameDoc b + return (a',b')) docs + return (DocDefList docs') + DocCodeBlock doc -> do + doc' <- renameDoc doc + return (DocCodeBlock doc') + DocURL str -> return (DocURL str) + DocAName str -> return (DocAName str) + +renameLPred (L loc p) = return . L loc =<< renamePred p + +renamePred :: HsPred Name -> RnM (HsPred DocName) +renamePred (HsClassP name types) = do + name' <- rename name + types' <- mapM renameLType types + return (HsClassP name' types') +renamePred (HsIParam (IPName name) t) = do + name' <- rename name + t' <- renameLType t + return (HsIParam (IPName name') t') + +renameLType (L loc t) = return . L loc =<< renameType t + +renameType t = case t of + HsForAllTy expl tyvars lcontext ltype -> do + tyvars' <- mapM renameLTyVarBndr tyvars + lcontext' <- renameLContext lcontext + ltype' <- renameLType ltype + return (HsForAllTy expl tyvars' lcontext' ltype') + + HsTyVar n -> return . HsTyVar =<< rename n + HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype + + HsAppTy a b -> do + a' <- renameLType a + b' <- renameLType b + return (HsAppTy a' b') + + HsFunTy a b -> do + a' <- renameLType a + b' <- renameLType b + return (HsFunTy a' b') + + HsListTy t -> return . HsListTy =<< renameLType t + HsPArrTy t -> return . HsPArrTy =<< renameLType t + + HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts + + HsOpTy a (L loc op) b -> do + op' <- rename op + a' <- renameLType a + b' <- renameLType b + return (HsOpTy a' (L loc op') b') + + HsParTy t -> return . HsParTy =<< renameLType t + + HsNumTy n -> return (HsNumTy n) + + HsPredTy p -> return . HsPredTy =<< renamePred p + + HsKindSig t k -> do + t' <- renameLType t + return (HsKindSig t' k) + + HsDocTy t doc -> do + t' <- renameLType t + doc' <- renameLDoc doc + return (HsDocTy t' doc') + + _ -> error "renameType" + +renameLTyVarBndr (L loc tv) = do + name' <- rename (hsTyVarName tv) + return $ L loc (replaceTyVarName tv name') + +renameLContext (L loc context) = do + context' <- mapM renameLPred context + return (L loc context') + +renameInstHead :: InstHead Name -> RnM (InstHead DocName) +renameInstHead (preds, className, types) = do + preds' <- mapM renamePred preds + className' <- rename className + types' <- mapM renameType types + return (preds', className', types') + +renameLDecl (L loc d) = return . L loc =<< renameDecl d + +renameDecl d = case d of + TyClD d -> do + d' <- renameTyClD d + return (TyClD d') + SigD s -> do + s' <- renameSig s + return (SigD s') + ForD d -> do + d' <- renameForD d + return (ForD d') + _ -> error "renameDecl" + +renameTyClD d = case d of + ForeignType _ _ _ -> error "renameTyClD" -- I'm guessing these can't be exported + -- ForeignType name a b -> do + -- name' <- renameL name + -- return (ForeignType name' a b) + + TyData x lcontext lname ltyvars _ k cons _ -> do + lcontext' <- renameLContext lcontext + ltyvars' <- mapM renameLTyVarBndr ltyvars + cons' <- mapM renameLCon cons + -- I don't think we need the derivings, so we return Nothing + -- We skip the type patterns too. TODO: find out what they are :-) + return (TyData x lcontext' (keepL lname) ltyvars' Nothing k cons' Nothing) + + TySynonym lname ltyvars typat ltype -> do + ltyvars' <- mapM renameLTyVarBndr ltyvars + ltype' <- renameLType ltype + -- We skip type patterns here as well. + return (TySynonym (keepL lname) ltyvars' Nothing ltype') + + ClassDecl lcontext lname ltyvars lfundeps lsigs _ _ _ -> do + lcontext' <- renameLContext lcontext + ltyvars' <- mapM renameLTyVarBndr ltyvars + lfundeps' <- mapM renameLFunDep lfundeps + lsigs' <- mapM renameLSig lsigs + -- we don't need the default methods or the already collected doc entities + -- we skip the ATs for now. + return (ClassDecl lcontext' (keepL lname) ltyvars' lfundeps' lsigs' emptyBag [] []) + + where + renameLCon (L loc con) = return . L loc =<< renameCon con + renameCon (ConDecl lname expl ltyvars lcontext details restype mbldoc) = do + ltyvars' <- mapM renameLTyVarBndr ltyvars + lcontext' <- renameLContext lcontext + details' <- renameDetails details + restype' <- renameResType restype + mbldoc' <- mapM renameLDoc mbldoc + return (ConDecl (keepL lname) expl ltyvars' lcontext' details' restype' mbldoc') + + renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields + renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps + renameDetails (InfixCon a b) = do + a' <- renameLType a + b' <- renameLType b + return (InfixCon a' b') + + renameField (HsRecField id arg doc) = do + arg' <- renameLType arg + doc' <- mapM renameLDoc doc + return (HsRecField (keepL id) arg' doc') + + renameResType (ResTyH98) = return ResTyH98 + renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t + + renameLFunDep (L loc (xs, ys)) = return (L loc (map keep xs, map keep ys)) + + renameLSig (L loc sig) = return . L loc =<< renameSig sig + +renameSig sig = case sig of + TypeSig (L loc name) ltype -> do + ltype' <- renameLType ltype + return (TypeSig (L loc (keep name)) ltype') +{- SpecSig lname ltype x -> do + lname' <- renameL lname + ltype' <- renameLType ltype + return (SpecSig lname' ltype' x) + InlineSig lname x -> do + lname' <- renameL lname + return (InlineSig lname' x) + SpecInstSig t -> return . SpecInstSig =<< renameLType t + FixSig fsig -> return . FixSig =<< renameFixitySig fsig + where + renameFixitySig (FixitySig lname x) = do + lname' <- renameL lname + return (FixitySig lname' x) +-} + +renameForD (ForeignImport lname ltype x) = do + ltype' <- renameLType ltype + return (ForeignImport (keepL lname) ltype' x) +renameForD (ForeignExport lname ltype x) = do + ltype' <- renameLType ltype + return (ForeignExport (keepL lname) ltype' x) + +renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) +renameExportItem item = case item of + ExportModule mod -> return (ExportModule mod) + ExportGroup lev id doc -> do + doc' <- renameDoc doc + return (ExportGroup lev id doc') + ExportDecl x decl doc instances -> do + decl' <- renameLDecl decl + doc' <- mapM renameDoc doc + instances' <- mapM renameInstHead instances + return (ExportDecl x decl' doc' instances') + ExportNoDecl x y subs -> do + y' <- lookupRn id y + subs' <- mapM (lookupRn id) subs + return (ExportNoDecl x y' subs') + ExportDoc doc -> do + doc' <- renameDoc doc + return (ExportDoc doc') diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs new file mode 100644 index 00000000..4c4587ac --- /dev/null +++ b/src/Haddock/Types.hs @@ -0,0 +1,123 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2003 +-- +-- Ported to use the GHC API by David Waern 2006 +-- + +module Haddock.Types where + +import GHC +import Outputable + +import Data.Map + +data DocOption + = OptHide -- ^ This module should not appear in the docs + | OptPrune + | OptIgnoreExports -- ^ Pretend everything is exported + | OptNotHome -- ^ Not the best place to get docs for things + -- exported by this module. + deriving (Eq, Show) + +data ExportItem name + = ExportDecl + Name -- ^ The original name + (LHsDecl name) -- ^ A declaration + (Maybe (HsDoc name)) -- ^ Maybe a doc comment + [InstHead name] -- ^ Instances relevant to this declaration + + | ExportNoDecl -- ^ An exported entity for which we have no + -- documentation (perhaps because it resides in + -- another package) + Name -- ^ The original name + name -- ^ Where to link to + [name] -- ^ Subordinate names + + | ExportGroup -- ^ A section heading + Int -- ^ section level (1, 2, 3, ... ) + String -- ^ Section "id" (for hyperlinks) + (HsDoc name) -- ^ Section heading text + + | ExportDoc -- ^ Some documentation + (HsDoc name) + + | ExportModule -- ^ A cross-reference to another module + Module + +type InstHead name = ([HsPred name], name, [HsType name]) +type ModuleMap = Map Module HaddockModule +type DocMap = Map Name (HsDoc DocName) +type DocEnv = Map Name Name + +data DocName = Link Name | NoLink Name + +instance Outputable DocName where + ppr (Link n) = ppr n + ppr (NoLink n) = ppr n + +data HaddockModule = HM { + + -- | A value to identify the module + hmod_mod :: Module, + + -- | The original filename for this module + hmod_orig_filename :: FilePath, + + -- | Textual information about the module + hmod_info :: HaddockModInfo Name, + + -- | The documentation header for this module + hmod_doc :: Maybe (HsDoc Name), + + -- | The renamed documentation header for this module + hmod_rn_doc :: Maybe (HsDoc DocName), + + -- | The Haddock options for this module (prune, ignore-exports, etc) + hmod_options :: [DocOption], + + hmod_exported_decl_map :: Map Name (LHsDecl Name), + hmod_doc_map :: Map Name (HsDoc Name), + hmod_rn_doc_map :: Map Name (HsDoc DocName), + + hmod_export_items :: [ExportItem Name], + hmod_rn_export_items :: [ExportItem DocName], + + -- | All the names that are defined in this module + hmod_locals :: [Name], + + -- | All the names that are exported by this module + hmod_exports :: [Name], + + -- | All the visible names exported by this module + -- For a name to be visible, it has to: + -- - be exported normally, and not via a full module re-exportation. + -- - have a declaration in this module or any of it's imports, with the + -- exception that it can't be from another package. + -- Basically, a visible name is a name that will show up in the documentation + -- for this module. + hmod_visible_exports :: [Name], + + hmod_sub_map :: Map Name [Name], + + -- | The instances exported by this module + hmod_instances :: [Instance] +} + +data DocMarkup id a = Markup { + markupEmpty :: a, + markupString :: String -> a, + markupParagraph :: a -> a, + markupAppend :: a -> a -> a, + markupIdentifier :: [id] -> a, + markupModule :: String -> a, + markupEmphasis :: a -> a, + markupMonospaced :: a -> a, + markupUnorderedList :: [a] -> a, + markupOrderedList :: [a] -> a, + markupDefList :: [(a,a)] -> a, + markupCodeBlock :: a -> a, + markupURL :: String -> a, + markupAName :: String -> a +} diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs new file mode 100644 index 00000000..27f60e4a --- /dev/null +++ b/src/Haddock/Utils.hs @@ -0,0 +1,340 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) The University of Glasgow 2001-2002 +-- (c) Simon Marlow 2003 +-- + +module Haddock.Utils ( + + -- * Misc utilities + restrictTo, + toDescription, + + -- * Filename utilities + basename, dirname, splitFilename3, + moduleHtmlFile, nameHtmlRef, + contentsHtmlFile, indexHtmlFile, subIndexHtmlFile, pathJoin, + anchorNameStr, + cssFile, iconFile, jsFile, plusFile, minusFile, + + -- * Miscellaneous utilities + getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, + isConSym, isVarSym, nameOccString, moduleString, mkModuleNoPkg, + + -- * HTML cross reference mapping + html_xrefs_ref, + + -- * HsDoc markup + markup, + idMarkup, + + -- * Binary extras +-- FormatVersion, mkFormatVersion + ) where + +import Haddock.Types + +import GHC +import SrcLoc +import Name +import OccName +import Binary +import Module +import PackageConfig ( stringToPackageId ) + +import Control.Monad ( liftM, MonadPlus(..) ) +import Data.Map ( Map ) +import qualified Data.Map as Map hiding ( Map ) +import Data.Char +import Data.IORef ( IORef, newIORef, readIORef ) +import Data.List ( intersect, isSuffixOf, intersperse ) +import Data.Maybe ( maybeToList, fromMaybe, isJust, fromJust ) +import Data.Word ( Word8 ) +import Data.Bits ( testBit ) +import Network.URI +import System.Environment ( getProgName ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.IO ( hPutStr, stderr ) +import System.IO.Unsafe ( unsafePerformIO ) + +-- ----------------------------------------------------------------------------- +-- Some Utilities + +-- | extract a module's short description. +toDescription :: HaddockModule -> Maybe (HsDoc Name) +toDescription = hmi_description . hmod_info + +-- --------------------------------------------------------------------------- +-- Making abstract declarations + +restrictTo :: [Name] -> (LHsDecl Name) -> (LHsDecl Name) +restrictTo names (L loc decl) = L loc $ case decl of + TyClD d | isDataDecl d && tcdND d == DataType -> + TyClD (d { tcdCons = restrictCons names (tcdCons d) }) + TyClD d | isDataDecl d && tcdND d == NewType -> + case restrictCons names (tcdCons d) of + [] -> TyClD (d { tcdND = DataType, tcdCons = [] }) + [con] -> TyClD (d { tcdCons = [con] }) + TyClD d | isClassDecl d -> + TyClD (d { tcdSigs = restrictDecls names (tcdSigs d) }) + _ -> decl + +restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] +restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] + where + keep d | unLoc (con_name d) `elem` names = + case con_details d of + PrefixCon _ -> Just d + RecCon fields + | all field_avail fields -> Just d + | otherwise -> Just (d { con_details = PrefixCon (field_types fields) }) + -- if we have *all* the field names available, then + -- keep the record declaration. Otherwise degrade to + -- a constructor declaration. This isn't quite right, but + -- it's the best we can do. + InfixCon _ _ -> Just d + where + field_avail (HsRecField n _ _) = (unLoc n) `elem` names + field_types flds = [ ty | HsRecField n ty _ <- flds] + + keep d | otherwise = Nothing + +restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] +restrictDecls names decls = filter keep decls + where keep d = fromJust (sigName d) `elem` names + -- has to have a name, since it's a class method type signature + +-- ----------------------------------------------------------------------------- +-- Filename mangling functions stolen from s main/DriverUtil.lhs. + +type Suffix = String + +splitFilename :: String -> (String,Suffix) +splitFilename f = split_longest_prefix f (=='.') + +basename :: String -> String +basename f = base where (_dir, base, _suff) = splitFilename3 f + +dirname :: String -> String +dirname f = dir where (dir, _base, _suff) = splitFilename3 f + +-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext") +splitFilename3 :: String -> (String,String,Suffix) +splitFilename3 str + = let (dir, rest) = split_longest_prefix str isPathSeparator + (name, ext) = splitFilename rest + real_dir | null dir = "." + | otherwise = dir + in (real_dir, name, ext) + +split_longest_prefix :: String -> (Char -> Bool) -> (String,String) +split_longest_prefix s pred0 + = case pre0 of + [] -> ([], reverse suf) + (_:pre) -> (reverse pre, reverse suf) + where (suf,pre0) = break pred0 (reverse s) + +pathSeparator :: Char +#ifdef __WIN32__ +pathSeparator = '\\' +#else +pathSeparator = '/' +#endif + +isPathSeparator :: Char -> Bool +isPathSeparator ch = +#ifdef mingw32_TARGET_OS + ch == '/' || ch == '\\' +#else + ch == '/' +#endif + +moduleHtmlFile :: Module -> FilePath +moduleHtmlFile mdl = + case Map.lookup mdl html_xrefs of + Nothing -> mdl' ++ ".html" + Just fp0 -> pathJoin [fp0, mdl' ++ ".html"] + where + mdl' = map (\c -> if c == '.' then '-' else c) + (moduleNameString (moduleName mdl)) + +nameHtmlRef :: Module -> Name -> String +nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr str) + +contentsHtmlFile, indexHtmlFile :: String +contentsHtmlFile = "index.html" +indexHtmlFile = "doc-index.html" + +subIndexHtmlFile :: Char -> String +subIndexHtmlFile a = "doc-index-" ++ b ++ ".html" + where b | isAlpha a = [a] + | otherwise = show (ord a) + +anchorNameStr :: Name -> String +anchorNameStr name | isValOcc occName = "v:" ++ getOccString name + | otherwise = "t:" ++ getOccString name + where occName = nameOccName name + +pathJoin :: [FilePath] -> FilePath +pathJoin = foldr join [] + where join :: FilePath -> FilePath -> FilePath + join path1 "" = path1 + join "" path2 = path2 + join path1 path2 + | isPathSeparator (last path1) = path1++path2 + | otherwise = path1++pathSeparator:path2 + +-- ----------------------------------------------------------------------------- +-- Files we need to copy from our $libdir + +cssFile, iconFile, jsFile, plusFile,minusFile :: String +cssFile = "haddock.css" +iconFile = "haskell_icon.gif" +jsFile = "haddock.js" +plusFile = "plus.gif" +minusFile = "minus.gif" + +----------------------------------------------------------------------------- +-- misc. + +getProgramName :: IO String +getProgramName = liftM (`withoutSuffix` ".bin") getProgName + where str `withoutSuffix` suff + | suff `isSuffixOf` str = take (length str - length suff) str + | otherwise = str + +bye :: String -> IO a +bye s = putStr s >> exitWith ExitSuccess + +die :: String -> IO a +die s = hPutStr stderr s >> exitWith (ExitFailure 1) + +dieMsg :: String -> IO a +dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) + +noDieMsg :: String -> IO () +noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s) + +mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)] +mapSnd _ [] = [] +mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs + +mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) +mapMaybeM _ Nothing = return Nothing +mapMaybeM f (Just a) = f a >>= return . Just + +escapeStr :: String -> String +#if __GLASGOW_HASKELL__ < 603 +escapeStr = flip escapeString unreserved +#else +escapeStr = escapeURIString isUnreserved +#endif + +-- there should be a better way to check this using the GHC API +isConSym n = head (nameOccString n) == ':' +isVarSym n = fstChar /= '_' && not (isConSym n) && (not . isLetter) fstChar + where fstChar = head (nameOccString n) + +nameOccString = occNameString . nameOccName + +moduleString :: Module -> String +moduleString = moduleNameString . moduleName + +mkModuleNoPkg :: String -> Module +mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str) + +----------------------------------------------------------------------------- +-- HTML cross references + +-- For each module, we need to know where its HTML documentation lives +-- so that we can point hyperlinks to it. It is extremely +-- inconvenient to plumb this information to all the places that need +-- it (basically every function in HaddockHtml), and furthermore the +-- mapping is constant for any single run of Haddock. So for the time +-- being I'm going to use a write-once global variable. + +{-# NOINLINE html_xrefs_ref #-} +html_xrefs_ref :: IORef (Map Module FilePath) +html_xrefs_ref = unsafePerformIO (newIORef (error "module_map")) + +{-# NOINLINE html_xrefs #-} +html_xrefs :: Map Module FilePath +html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) + +----------------------------------------------------------------------------- +-- put here temporarily + +markup :: DocMarkup id a -> HsDoc id -> a +markup m DocEmpty = markupEmpty m +markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) +markup m (DocString s) = markupString m s +markup m (DocParagraph d) = markupParagraph m (markup m d) +markup m (DocIdentifier ids) = markupIdentifier m ids +markup m (DocModule mod0) = markupModule m mod0 +markup m (DocEmphasis d) = markupEmphasis m (markup m d) +markup m (DocMonospaced d) = markupMonospaced m (markup m d) +markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) +markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) +markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) +markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) +markup m (DocURL url) = markupURL m url +markup m (DocAName ref) = markupAName m ref + +markupPair :: DocMarkup id a -> (HsDoc id, HsDoc id) -> (a, a) +markupPair m (a,b) = (markup m a, markup m b) + +-- | The identity markup +idMarkup :: DocMarkup a (HsDoc a) +idMarkup = Markup { + markupEmpty = DocEmpty, + markupString = DocString, + markupParagraph = DocParagraph, + markupAppend = DocAppend, + markupIdentifier = DocIdentifier, + markupModule = DocModule, + markupEmphasis = DocEmphasis, + markupMonospaced = DocMonospaced, + markupUnorderedList = DocUnorderedList, + markupOrderedList = DocOrderedList, + markupDefList = DocDefList, + markupCodeBlock = DocCodeBlock, + markupURL = DocURL, + markupAName = DocAName + } + +-- | Since marking up is just a matter of mapping 'Doc' into some +-- other type, we can \'rename\' documentation by marking up 'Doc' into +-- the same thing, modifying only the identifiers embedded in it. + +mapIdent f = idMarkup { markupIdentifier = f } + +----------------------------------------------------------------------------- +-- put here temporarily + +newtype FormatVersion = FormatVersion Int deriving (Eq,Ord) + +nullFormatVersion :: FormatVersion +nullFormatVersion = mkFormatVersion 0 + +mkFormatVersion :: Int -> FormatVersion +mkFormatVersion i = FormatVersion i + +instance Binary FormatVersion where + put_ bh (FormatVersion i) = + case compare i 0 of + EQ -> return () + GT -> put_ bh (-i) + LT -> error ( + "Binary.hs: negative FormatVersion " ++ show i + ++ " is not allowed") + get bh = + do + (w8 :: Word8) <- get bh + if testBit w8 7 + then + do + i <- get bh + return (FormatVersion (-i)) + else + return nullFormatVersion diff --git a/src/Haddock/Utils/BlockTable.hs b/src/Haddock/Utils/BlockTable.hs new file mode 100644 index 00000000..ed51654e --- /dev/null +++ b/src/Haddock/Utils/BlockTable.hs @@ -0,0 +1,180 @@ +----------------------------------------------------------------------------- +-- +-- Module : Text.Html.BlockTable +-- Copyright : (c) Andy Gill, and the Oregon Graduate Institute of +-- Science and Technology, 1999-2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : Andy Gill +-- Stability : experimental +-- Portability : portable +-- +-- $Id: BlockTable.hs,v 1.2 2002/07/24 09:42:18 simonmar Exp $ +-- +-- An Html combinator library +-- +----------------------------------------------------------------------------- + +module Haddock.Utils.BlockTable ( + +-- Datatypes: + + BlockTable, -- abstract + +-- Contruction Functions: + + single, + empty, + above, + beside, + +-- Investigation Functions: + + getMatrix, + showsTable, + showTable, + + ) where + +import Prelude + +infixr 4 `beside` +infixr 3 `above` + +-- These combinators can be used to build formated 2D tables. +-- The specific target useage is for HTML table generation. + +{- + Examples of use: + + > table1 :: BlockTable String + > table1 = single "Hello" +-----+ + |Hello| + This is a 1x1 cell +-----+ + Note: single has type + + single :: a -> BlockTable a + + So the cells can contain anything. + + > table2 :: BlockTable String + > table2 = single "World" +-----+ + |World| + +-----+ + + + > table3 :: BlockTable String + > table3 = table1 %-% table2 +-----%-----+ + |Hello%World| + % is used to indicate +-----%-----+ + the join edge between + the two Tables. + + > table4 :: BlockTable String + > table4 = table3 %/% table2 +-----+-----+ + |Hello|World| + Notice the padding on the %%%%%%%%%%%%% + smaller (bottom) cell to |World | + force the table to be a +-----------+ + rectangle. + + > table5 :: BlockTable String + > table5 = table1 %-% table4 +-----%-----+-----+ + |Hello%Hello|World| + Notice the padding on the | %-----+-----+ + leftmost cell, again to | %World | + force the table to be a +-----%-----------+ + rectangle. + + Now the table can be rendered with processTable, for example: + Main> processTable table5 + [[("Hello",(1,2)), + ("Hello",(1,1)), + ("World",(1,1))], + [("World",(2,1))]] :: [[([Char],(Int,Int))]] + Main> +-} + +-- --------------------------------------------------------------------------- +-- Contruction Functions + +-- Perhaps one day I'll write the Show instance +-- to show boxes aka the above ascii renditions. + +instance (Show a) => Show (BlockTable a) where + showsPrec _ = showsTable + +type TableI a = [[(a,(Int,Int))]] -> [[(a,(Int,Int))]] + +data BlockTable a = Table (Int -> Int -> TableI a) Int Int + + +-- You can create a (1x1) table entry + +single :: a -> BlockTable a +single a = Table (\ x y r -> [(a,(x+1,y+1))] : r) 1 1 + +empty :: BlockTable a +empty = Table (\ _ _ r -> r) 0 0 + + +-- You can compose tables, horizonally and vertically + +above :: BlockTable a -> BlockTable a -> BlockTable a +beside :: BlockTable a -> BlockTable a -> BlockTable a + +t1 `above` t2 = trans (combine (trans t1) (trans t2) (.)) + +t1 `beside` t2 = combine t1 t2 (\ lst1 lst2 r -> + let + -- Note this depends on the fact that + -- that the result has the same number + -- of lines as the y dimention; one list + -- per line. This is not true in general + -- but is always true for these combinators. + -- I should assert this! + -- I should even prove this. + beside' (x:xs) (y:ys) = (x ++ y) : beside' xs ys + beside' (x:xs) [] = x : xs ++ r + beside' [] (y:ys) = y : ys ++ r + beside' [] [] = r + in + beside' (lst1 []) (lst2 [])) + +-- trans flips (transposes) over the x and y axis of +-- the table. It is only used internally, and typically +-- in pairs, ie. (flip ... munge ... (un)flip). + +trans :: BlockTable a -> BlockTable a +trans (Table f1 x1 y1) = Table (flip f1) y1 x1 + +combine :: BlockTable a + -> BlockTable b + -> (TableI a -> TableI b -> TableI c) + -> BlockTable c +combine (Table f1 x1 y1) (Table f2 x2 y2) comb = Table new_fn (x1+x2) max_y + where + max_y = max y1 y2 + new_fn x y = + case compare y1 y2 of + EQ -> comb (f1 0 y) (f2 x y) + GT -> comb (f1 0 y) (f2 x (y + y1 - y2)) + LT -> comb (f1 0 (y + y2 - y1)) (f2 x y) + +-- --------------------------------------------------------------------------- +-- Investigation Functions + +-- This is the other thing you can do with a Table; +-- turn it into a 2D list, tagged with the (x,y) +-- sizes of each cell in the table. + +getMatrix :: BlockTable a -> [[(a,(Int,Int))]] +getMatrix (Table r _ _) = r 0 0 [] + +-- You can also look at a table + +showsTable :: (Show a) => BlockTable a -> ShowS +showsTable table = shows (getMatrix table) + +showTable :: (Show a) => BlockTable a -> String +showTable table = showsTable table "" diff --git a/src/Haddock/Utils/FastMutInt2.hs b/src/Haddock/Utils/FastMutInt2.hs new file mode 100644 index 00000000..c47b514b --- /dev/null +++ b/src/Haddock/Utils/FastMutInt2.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +-- +-- (c) The University of Glasgow 2002 +-- +-- Unboxed mutable Ints + +module Haddock.Utils.FastMutInt2( + FastMutInt, newFastMutInt, + readFastMutInt, writeFastMutInt, + incFastMutInt, incFastMutIntBy + ) where + +#include "MachDeps.h" + +#ifndef SIZEOF_HSINT +#define SIZEOF_HSINT INT_SIZE_IN_BYTES +#endif + + +#if __GLASGOW_HASKELL__ < 503 +import GlaExts +import PrelIOBase +#else +import GHC.Base +import GHC.IOBase +#endif + +#if __GLASGOW_HASKELL__ < 411 +newByteArray# = newCharArray# +#endif + +#ifdef __GLASGOW_HASKELL__ +data FastMutInt = FastMutInt (MutableByteArray# RealWorld) + +newFastMutInt :: IO FastMutInt +newFastMutInt = IO $ \s0 -> + case newByteArray# size s0 of { (# s, arr #) -> + (# s, FastMutInt arr #) } + where I# size = SIZEOF_HSINT + +readFastMutInt :: FastMutInt -> IO Int +readFastMutInt (FastMutInt arr) = IO $ \s0 -> + case readIntArray# arr 0# s0 of { (# s, i #) -> + (# s, I# i #) } + +writeFastMutInt :: FastMutInt -> Int -> IO () +writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s0 -> + case writeIntArray# arr 0# i s0 of { s -> + (# s, () #) } + +incFastMutInt :: FastMutInt -> IO Int -- Returns original value +incFastMutInt (FastMutInt arr) = IO $ \s0 -> + case readIntArray# arr 0# s0 of { (# s1, i #) -> + case writeIntArray# arr 0# (i +# 1#) s1 of { s -> + (# s, I# i #) } } + +incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value +incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s0 -> + case readIntArray# arr 0# s0 of { (# s1, i #) -> + case writeIntArray# arr 0# (i +# n) s1 of { s -> + (# s, I# i #) } } +#endif + diff --git a/src/Haddock/Utils/GHC.hs b/src/Haddock/Utils/GHC.hs new file mode 100644 index 00000000..b6fb54d4 --- /dev/null +++ b/src/Haddock/Utils/GHC.hs @@ -0,0 +1,26 @@ +module Haddock.Utils.GHC where + +import Debug.Trace + +import GHC +import HsSyn +import SrcLoc +import HscTypes +import Outputable + +getMainDeclBinder :: HsDecl name -> Maybe name +getMainDeclBinder (TyClD d) = Just (tcdName d) +getMainDeclBinder (ValD d) + = case collectAcc d [] of + [] -> Nothing + (name:_) -> Just (unLoc name) +getMainDeclBinder (SigD d) = sigNameNoLoc d +getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name) +getMainDeclBinder (ForD (ForeignExport name _ _)) = Nothing +getMainDeclBinder _ = Nothing + +-- To keep if if minf_iface is re-introduced +--modInfoName = moduleName . mi_module . minf_iface +--modInfoMod = mi_module . minf_iface + +trace_ppr x y = trace (showSDoc (ppr x)) y diff --git a/src/Haddock/Utils/Html.hs b/src/Haddock/Utils/Html.hs new file mode 100644 index 00000000..dbef2112 --- /dev/null +++ b/src/Haddock/Utils/Html.hs @@ -0,0 +1,1037 @@ +----------------------------------------------------------------------------- +-- +-- Module : Text.Html +-- Copyright : (c) Andy Gill, and the Oregon Graduate Institute of +-- Science and Technology, 1999-2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : Andy Gill +-- Stability : experimental +-- Portability : portable +-- +-- An Html combinator library +-- +----------------------------------------------------------------------------- + +module Haddock.Utils.Html ( + module Haddock.Utils.Html, + ) where + +import qualified Haddock.Utils.BlockTable as BT + +import Data.Char (isAscii, ord) +import Numeric (showHex) + +infixr 2 +++ -- combining Html +infixr 7 << -- nesting Html +infixl 8 ! -- adding optional arguments + + +-- A important property of Html is that all strings inside the +-- structure are already in Html friendly format. +-- For example, use of >,etc. + +data HtmlElement +{- + - ..just..plain..normal..text... but using © and &amb;, etc. + -} + = HtmlString String +{- + - ..content.. + -} + | HtmlTag { -- tag with internal markup + markupTag :: String, + markupAttrs :: [HtmlAttr], + markupContent :: Html + } + +{- These are the index-value pairs. + - The empty string is a synonym for tags with no arguments. + - (not strictly HTML, but anyway). + -} + + +data HtmlAttr = HtmlAttr String String + + +newtype Html = Html { getHtmlElements :: [HtmlElement] } + +-- Read MARKUP as the class of things that can be validly rendered +-- inside MARKUP tag brackets. So this can be one or more Html's, +-- or a String, for example. + +class HTML a where + toHtml :: a -> Html + toHtmlFromList :: [a] -> Html + + toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs]) + +instance HTML Html where + toHtml a = a + +instance HTML Char where + toHtml a = toHtml [a] + toHtmlFromList [] = Html [] + toHtmlFromList str = Html [HtmlString (stringToHtmlString str)] + +instance (HTML a) => HTML [a] where + toHtml xs = toHtmlFromList xs + +class ADDATTRS a where + (!) :: a -> [HtmlAttr] -> a + +instance (ADDATTRS b) => ADDATTRS (a -> b) where + (!) fn attr = \ arg -> fn arg ! attr + +instance ADDATTRS Html where + (!) (Html htmls) attr = Html (map addAttrs htmls) + where + addAttrs html = + case html of + HtmlTag { markupAttrs = markupAttrs0 + , markupTag = markupTag0 + , markupContent = markupContent0 } -> + HtmlTag { markupAttrs = markupAttrs0 ++ attr + , markupTag = markupTag0 + , markupContent = markupContent0 } + _ -> html + + +(<<) :: (HTML a) => (Html -> b) -> a -> b +fn << arg = fn (toHtml arg) + + +concatHtml :: (HTML a) => [a] -> Html +concatHtml as = Html (concat (map (getHtmlElements.toHtml) as)) + +(+++) :: (HTML a,HTML b) => a -> b -> Html +a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b)) + +noHtml :: Html +noHtml = Html [] + + +isNoHtml :: Html -> Bool +isNoHtml (Html xs) = null xs + + +tag :: String -> Html -> Html +tag str htmls = + Html [ HtmlTag { markupTag = str, + markupAttrs = [], + markupContent = htmls } + ] + +itag :: String -> Html +itag str = tag str noHtml + +emptyAttr :: String -> HtmlAttr +emptyAttr s = HtmlAttr s "" + +intAttr :: String -> Int -> HtmlAttr +intAttr s i = HtmlAttr s (show i) + +strAttr :: String -> String -> HtmlAttr +strAttr s t = HtmlAttr s t + + +{- +foldHtml :: (String -> [HtmlAttr] -> [a] -> a) + -> (String -> a) + -> Html + -> a +foldHtml f g (HtmlTag str attr fmls) + = f str attr (map (foldHtml f g) fmls) +foldHtml f g (HtmlString str) + = g str + +-} +-- Processing Strings into Html friendly things. +-- This converts a String to a Html String. +stringToHtmlString :: String -> String +stringToHtmlString = concatMap fixChar + where + fixChar '<' = "<" + fixChar '>' = ">" + fixChar '&' = "&" + fixChar '"' = """ + fixChar c + | isAscii c = [c] + | otherwise = "&#x" ++ showHex (ord c) ";" + +-- --------------------------------------------------------------------------- +-- Classes + +instance Show Html where + showsPrec _ html = showString (prettyHtml html) + showList htmls = showString (concat (map show htmls)) + +instance Show HtmlAttr where + showsPrec _ (HtmlAttr str val) = + showString str . + showString "=" . + shows val + + +-- --------------------------------------------------------------------------- +-- Data types + +type URL = String + +-- --------------------------------------------------------------------------- +-- Basic primitives + +-- This is not processed for special chars. +-- use stringToHtml or lineToHtml instead, for user strings, +-- because they understand special chars, like '<'. + +primHtml :: String -> Html +primHtml x = Html [HtmlString x] + +-- --------------------------------------------------------------------------- +-- Basic Combinators + +stringToHtml :: String -> Html +stringToHtml = primHtml . stringToHtmlString + +-- This converts a string, but keeps spaces as non-line-breakable + +lineToHtml :: String -> Html +lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString + where + htmlizeChar2 ' ' = " " + htmlizeChar2 c = [c] + +-- --------------------------------------------------------------------------- +-- Html Constructors + +-- (automatically generated) + +address :: Html -> Html +anchor :: Html -> Html +applet :: Html -> Html +area :: Html +basefont :: Html +big :: Html -> Html +blockquote :: Html -> Html +body :: Html -> Html +bold :: Html -> Html +br :: Html +button :: Html -> Html +caption :: Html -> Html +center :: Html -> Html +cite :: Html -> Html +ddef :: Html -> Html +define :: Html -> Html +dlist :: Html -> Html +dterm :: Html -> Html +emphasize :: Html -> Html +fieldset :: Html -> Html +font :: Html -> Html +form :: Html -> Html +frame :: Html -> Html +frameset :: Html -> Html +h1 :: Html -> Html +h2 :: Html -> Html +h3 :: Html -> Html +h4 :: Html -> Html +h5 :: Html -> Html +h6 :: Html -> Html +header :: Html -> Html +hr :: Html +image :: Html +input :: Html +italics :: Html -> Html +keyboard :: Html -> Html +legend :: Html -> Html +li :: Html -> Html +meta :: Html +noframes :: Html -> Html +olist :: Html -> Html +option :: Html -> Html +paragraph :: Html -> Html +param :: Html +pre :: Html -> Html +sample :: Html -> Html +script :: Html -> Html +select :: Html -> Html +small :: Html -> Html +strong :: Html -> Html +style :: Html -> Html +sub :: Html -> Html +sup :: Html -> Html +table :: Html -> Html +thetd :: Html -> Html +textarea :: Html -> Html +th :: Html -> Html +thebase :: Html +thecode :: Html -> Html +thediv :: Html -> Html +thehtml :: Html -> Html +thelink :: Html +themap :: Html -> Html +thespan :: Html -> Html +thetitle :: Html -> Html +tr :: Html -> Html +tt :: Html -> Html +ulist :: Html -> Html +underline :: Html -> Html +variable :: Html -> Html + +address = tag "ADDRESS" +anchor = tag "A" +applet = tag "APPLET" +area = itag "AREA" +basefont = itag "BASEFONT" +big = tag "BIG" +blockquote = tag "BLOCKQUOTE" +body = tag "BODY" +bold = tag "B" +br = itag "BR" +button = tag "BUTTON" +caption = tag "CAPTION" +center = tag "CENTER" +cite = tag "CITE" +ddef = tag "DD" +define = tag "DFN" +dlist = tag "DL" +dterm = tag "DT" +emphasize = tag "EM" +fieldset = tag "FIELDSET" +font = tag "FONT" +form = tag "FORM" +frame = tag "FRAME" +frameset = tag "FRAMESET" +h1 = tag "H1" +h2 = tag "H2" +h3 = tag "H3" +h4 = tag "H4" +h5 = tag "H5" +h6 = tag "H6" +header = tag "HEAD" +hr = itag "HR" +image = itag "IMG" +input = itag "INPUT" +italics = tag "I" +keyboard = tag "KBD" +legend = tag "LEGEND" +li = tag "LI" +meta = itag "META" +noframes = tag "NOFRAMES" +olist = tag "OL" +option = tag "OPTION" +paragraph = tag "P" +param = itag "PARAM" +pre = tag "PRE" +sample = tag "SAMP" +script = tag "SCRIPT" +select = tag "SELECT" +small = tag "SMALL" +strong = tag "STRONG" +style = tag "STYLE" +sub = tag "SUB" +sup = tag "SUP" +table = tag "TABLE" +thetd = tag "TD" +textarea = tag "TEXTAREA" +th = tag "TH" +thebase = itag "BASE" +thecode = tag "CODE" +thediv = tag "DIV" +thehtml = tag "HTML" +thelink = itag "LINK" +themap = tag "MAP" +thespan = tag "SPAN" +thetitle = tag "TITLE" +tr = tag "TR" +tt = tag "TT" +ulist = tag "UL" +underline = tag "U" +variable = tag "VAR" + +-- --------------------------------------------------------------------------- +-- Html Attributes + +-- (automatically generated) + +action :: String -> HtmlAttr +align :: String -> HtmlAttr +alink :: String -> HtmlAttr +alt :: String -> HtmlAttr +altcode :: String -> HtmlAttr +archive :: String -> HtmlAttr +background :: String -> HtmlAttr +base :: String -> HtmlAttr +bgcolor :: String -> HtmlAttr +border :: Int -> HtmlAttr +bordercolor :: String -> HtmlAttr +cellpadding :: Int -> HtmlAttr +cellspacing :: Int -> HtmlAttr +checked :: HtmlAttr +clear :: String -> HtmlAttr +code :: String -> HtmlAttr +codebase :: String -> HtmlAttr +color :: String -> HtmlAttr +cols :: String -> HtmlAttr +colspan :: Int -> HtmlAttr +compact :: HtmlAttr +content :: String -> HtmlAttr +coords :: String -> HtmlAttr +enctype :: String -> HtmlAttr +face :: String -> HtmlAttr +frameborder :: Int -> HtmlAttr +height :: Int -> HtmlAttr +href :: String -> HtmlAttr +hspace :: Int -> HtmlAttr +httpequiv :: String -> HtmlAttr +identifier :: String -> HtmlAttr +ismap :: HtmlAttr +lang :: String -> HtmlAttr +link :: String -> HtmlAttr +marginheight :: Int -> HtmlAttr +marginwidth :: Int -> HtmlAttr +maxlength :: Int -> HtmlAttr +method :: String -> HtmlAttr +multiple :: HtmlAttr +name :: String -> HtmlAttr +nohref :: HtmlAttr +noresize :: HtmlAttr +noshade :: HtmlAttr +nowrap :: HtmlAttr +onclick :: String -> HtmlAttr +rel :: String -> HtmlAttr +rev :: String -> HtmlAttr +rows :: String -> HtmlAttr +rowspan :: Int -> HtmlAttr +rules :: String -> HtmlAttr +scrolling :: String -> HtmlAttr +selected :: HtmlAttr +shape :: String -> HtmlAttr +size :: String -> HtmlAttr +src :: String -> HtmlAttr +start :: Int -> HtmlAttr +target :: String -> HtmlAttr +text :: String -> HtmlAttr +theclass :: String -> HtmlAttr +thestyle :: String -> HtmlAttr +thetype :: String -> HtmlAttr +title :: String -> HtmlAttr +usemap :: String -> HtmlAttr +valign :: String -> HtmlAttr +value :: String -> HtmlAttr +version :: String -> HtmlAttr +vlink :: String -> HtmlAttr +vspace :: Int -> HtmlAttr +width :: String -> HtmlAttr + +action = strAttr "ACTION" +align = strAttr "ALIGN" +alink = strAttr "ALINK" +alt = strAttr "ALT" +altcode = strAttr "ALTCODE" +archive = strAttr "ARCHIVE" +background = strAttr "BACKGROUND" +base = strAttr "BASE" +bgcolor = strAttr "BGCOLOR" +border = intAttr "BORDER" +bordercolor = strAttr "BORDERCOLOR" +cellpadding = intAttr "CELLPADDING" +cellspacing = intAttr "CELLSPACING" +checked = emptyAttr "CHECKED" +clear = strAttr "CLEAR" +code = strAttr "CODE" +codebase = strAttr "CODEBASE" +color = strAttr "COLOR" +cols = strAttr "COLS" +colspan = intAttr "COLSPAN" +compact = emptyAttr "COMPACT" +content = strAttr "CONTENT" +coords = strAttr "COORDS" +enctype = strAttr "ENCTYPE" +face = strAttr "FACE" +frameborder = intAttr "FRAMEBORDER" +height = intAttr "HEIGHT" +href = strAttr "HREF" +hspace = intAttr "HSPACE" +httpequiv = strAttr "HTTP-EQUIV" +identifier = strAttr "ID" +ismap = emptyAttr "ISMAP" +lang = strAttr "LANG" +link = strAttr "LINK" +marginheight = intAttr "MARGINHEIGHT" +marginwidth = intAttr "MARGINWIDTH" +maxlength = intAttr "MAXLENGTH" +method = strAttr "METHOD" +multiple = emptyAttr "MULTIPLE" +name = strAttr "NAME" +nohref = emptyAttr "NOHREF" +noresize = emptyAttr "NORESIZE" +noshade = emptyAttr "NOSHADE" +nowrap = emptyAttr "NOWRAP" +onclick = strAttr "ONCLICK" +rel = strAttr "REL" +rev = strAttr "REV" +rows = strAttr "ROWS" +rowspan = intAttr "ROWSPAN" +rules = strAttr "RULES" +scrolling = strAttr "SCROLLING" +selected = emptyAttr "SELECTED" +shape = strAttr "SHAPE" +size = strAttr "SIZE" +src = strAttr "SRC" +start = intAttr "START" +target = strAttr "TARGET" +text = strAttr "TEXT" +theclass = strAttr "CLASS" +thestyle = strAttr "STYLE" +thetype = strAttr "TYPE" +title = strAttr "TITLE" +usemap = strAttr "USEMAP" +valign = strAttr "VALIGN" +value = strAttr "VALUE" +version = strAttr "VERSION" +vlink = strAttr "VLINK" +vspace = intAttr "VSPACE" +width = strAttr "WIDTH" + +-- --------------------------------------------------------------------------- +-- Html Constructors + +-- (automatically generated) + +validHtmlTags :: [String] +validHtmlTags = [ + "ADDRESS", + "A", + "APPLET", + "BIG", + "BLOCKQUOTE", + "BODY", + "B", + "CAPTION", + "CENTER", + "CITE", + "DD", + "DFN", + "DL", + "DT", + "EM", + "FIELDSET", + "FONT", + "FORM", + "FRAME", + "FRAMESET", + "H1", + "H2", + "H3", + "H4", + "H5", + "H6", + "HEAD", + "I", + "KBD", + "LEGEND", + "LI", + "NOFRAMES", + "OL", + "OPTION", + "P", + "PRE", + "SAMP", + "SELECT", + "SMALL", + "STRONG", + "STYLE", + "SUB", + "SUP", + "TABLE", + "TD", + "TEXTAREA", + "TH", + "CODE", + "DIV", + "HTML", + "LINK", + "MAP", + "TITLE", + "TR", + "TT", + "UL", + "U", + "VAR"] + +validHtmlITags :: [String] +validHtmlITags = [ + "AREA", + "BASEFONT", + "BR", + "HR", + "IMG", + "INPUT", + "LINK", + "META", + "PARAM", + "BASE"] + +validHtmlAttrs :: [String] +validHtmlAttrs = [ + "ACTION", + "ALIGN", + "ALINK", + "ALT", + "ALTCODE", + "ARCHIVE", + "BACKGROUND", + "BASE", + "BGCOLOR", + "BORDER", + "BORDERCOLOR", + "CELLPADDING", + "CELLSPACING", + "CHECKED", + "CLEAR", + "CODE", + "CODEBASE", + "COLOR", + "COLS", + "COLSPAN", + "COMPACT", + "CONTENT", + "COORDS", + "ENCTYPE", + "FACE", + "FRAMEBORDER", + "HEIGHT", + "HREF", + "HSPACE", + "HTTP-EQUIV", + "ID", + "ISMAP", + "LANG", + "LINK", + "MARGINHEIGHT", + "MARGINWIDTH", + "MAXLENGTH", + "METHOD", + "MULTIPLE", + "NAME", + "NOHREF", + "NORESIZE", + "NOSHADE", + "NOWRAP", + "REL", + "REV", + "ROWS", + "ROWSPAN", + "RULES", + "SCROLLING", + "SELECTED", + "SHAPE", + "SIZE", + "SRC", + "START", + "TARGET", + "TEXT", + "CLASS", + "STYLE", + "TYPE", + "TITLE", + "USEMAP", + "VALIGN", + "VALUE", + "VERSION", + "VLINK", + "VSPACE", + "WIDTH"] + +-- --------------------------------------------------------------------------- +-- Html colors + +aqua :: String +black :: String +blue :: String +fuchsia :: String +gray :: String +green :: String +lime :: String +maroon :: String +navy :: String +olive :: String +purple :: String +red :: String +silver :: String +teal :: String +yellow :: String +white :: String + +aqua = "aqua" +black = "black" +blue = "blue" +fuchsia = "fuchsia" +gray = "gray" +green = "green" +lime = "lime" +maroon = "maroon" +navy = "navy" +olive = "olive" +purple = "purple" +red = "red" +silver = "silver" +teal = "teal" +yellow = "yellow" +white = "white" + +-- --------------------------------------------------------------------------- +-- Basic Combinators + +linesToHtml :: [String] -> Html + +linesToHtml [] = noHtml +linesToHtml (x:[]) = lineToHtml x +linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs + + +-- --------------------------------------------------------------------------- +-- Html abbriviations + +primHtmlChar :: String -> Html +copyright :: Html +spaceHtml :: Html +bullet :: Html +p :: Html -> Html + +primHtmlChar = \ x -> primHtml ("&" ++ x ++ ";") +copyright = primHtmlChar "copy" +spaceHtml = primHtmlChar "nbsp" +bullet = primHtmlChar "#149" + +p = paragraph + +-- --------------------------------------------------------------------------- +-- Html tables + +cell :: Html -> HtmlTable +cell h = let + cellFn x y = h ! (add x colspan $ add y rowspan $ []) + add 1 _ rest = rest + add n fn rest = fn n : rest + r = BT.single cellFn + in + mkHtmlTable r + +-- We internally represent the Cell inside a Table with an +-- object of the type +-- \pre{ +-- Int -> Int -> Html +-- } +-- When we render it later, we find out how many columns +-- or rows this cell will span over, and can +-- include the correct colspan/rowspan command. + +newtype HtmlTable + = HtmlTable (BT.BlockTable (Int -> Int -> Html)) + +td :: Html -> HtmlTable +td = cell . thetd + +tda :: [HtmlAttr] -> Html -> HtmlTable +tda as = cell . (thetd ! as) + +above, beside :: HtmlTable -> HtmlTable -> HtmlTable +above a b = combine BT.above a b +beside a b = combine BT.beside a b + +infixr 3 -- combining table cells +infixr 4 <-> -- combining table cells +(), (<->) :: HtmlTable -> HtmlTable -> HtmlTable +() = above +(<->) = beside + +emptyTable :: HtmlTable +emptyTable = HtmlTable BT.empty + +aboves, besides :: [HtmlTable] -> HtmlTable +aboves = foldr above emptyTable +besides = foldr beside emptyTable + +mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable +mkHtmlTable r = HtmlTable r + +combine :: (BT.BlockTable (Int -> Int -> Html) + -> BT.BlockTable (Int -> Int -> Html) + -> BT.BlockTable (Int -> Int -> Html)) + -> HtmlTable -> HtmlTable -> HtmlTable +combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b) + +-- renderTable takes the HtmlTable, and renders it back into +-- and Html object. + +renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html +renderTable theTable + = concatHtml + [tr << [theCell x y | (theCell,(x,y)) <- theRow ] + | theRow <- BT.getMatrix theTable] + +instance HTML HtmlTable where + toHtml (HtmlTable tab) = renderTable tab + +instance Show HtmlTable where + showsPrec _ (HtmlTable tab) = shows (renderTable tab) + + +-- If you can't be bothered with the above, then you +-- can build simple tables with simpleTable. +-- Just provide the attributes for the whole table, +-- attributes for the cells (same for every cell), +-- and a list of lists of cell contents, +-- and this function will build the table for you. +-- It does presume that all the lists are non-empty, +-- and there is at least one list. +-- +-- Different length lists means that the last cell +-- gets padded. If you want more power, then +-- use the system above, or build tables explicitly. + +simpleTable :: HTML a => [HtmlAttr] -> [HtmlAttr] -> [[a]] -> Html +simpleTable attr cellAttr lst + = table ! attr + << (aboves + . map (besides . map (cell . (thetd ! cellAttr) . toHtml)) + ) lst + + +-- --------------------------------------------------------------------------- +-- Tree Displaying Combinators + +-- The basic idea is you render your structure in the form +-- of this tree, and then use treeHtml to turn it into a Html +-- object with the structure explicit. + +data HtmlTree + = HtmlLeaf Html + | HtmlNode Html [HtmlTree] Html + +treeHtml :: [String] -> HtmlTree -> Html +treeHtml colors h = table ! [ + border 0, + cellpadding 0, + cellspacing 2] << treeHtml' colors h + where + manycolors = scanr (:) [] + + treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable + treeHtmls c ts = aboves (zipWith treeHtml' c ts) + + treeHtml' :: [String] -> HtmlTree -> HtmlTable + treeHtml' (_:_) (HtmlLeaf leaf) = cell + (thetd ! [width "100%"] + << bold + << leaf) + treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) = + if null ts && isNoHtml hclose + then + hd + else if null ts + then + hd bar `beside` (cell . (thetd ! [bgcolor c2]) << spaceHtml) + tl + else + hd (bar `beside` treeHtmls morecolors ts) + tl + where + -- This stops a column of colors being the same + -- color as the immeduately outside nesting bar. + morecolors = filter ((/= c).head) (manycolors cs) + bar = cell (thetd ! [bgcolor c,width "10"] << spaceHtml) + hd = cell (thetd ! [bgcolor c] << hopen) + tl = cell (thetd ! [bgcolor c] << hclose) + treeHtml' _ _ = error "The imposible happens" + +instance HTML HtmlTree where + toHtml x = treeHtml treeColors x + +-- type "length treeColors" to see how many colors are here. +treeColors :: [String] +treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors + + +-- --------------------------------------------------------------------------- +-- Html Debugging Combinators + +-- This uses the above tree rendering function, and displays the +-- Html as a tree structure, allowing debugging of what is +-- actually getting produced. + +debugHtml :: (HTML a) => a -> Html +debugHtml obj = table ! [border 0] << ( + cell (th ! [bgcolor "#008888"] + << underline + << "Debugging Output") + td << (toHtml (debug' (toHtml obj))) + ) + where + + debug' :: Html -> [HtmlTree] + debug' (Html markups) = map debug markups + + debug :: HtmlElement -> HtmlTree + debug (HtmlString str) = HtmlLeaf (spaceHtml +++ + linesToHtml (lines str)) + debug (HtmlTag { + markupTag = markupTag0, + markupContent = markupContent0, + markupAttrs = markupAttrs0 + }) = + case markupContent0 of + Html [] -> HtmlNode hd [] noHtml + Html xs -> HtmlNode hd (map debug xs) tl + where + args = if null markupAttrs0 + then "" + else " " ++ unwords (map show markupAttrs0) + hd = font ! [size "1"] << ("<" ++ markupTag0 ++ args ++ ">") + tl = font ! [size "1"] << ("") + +-- --------------------------------------------------------------------------- +-- Hotlink datatype + +data HotLink = HotLink { + hotLinkURL :: URL, + hotLinkContents :: [Html], + hotLinkAttributes :: [HtmlAttr] + } deriving Show + +instance HTML HotLink where + toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl) + << hotLinkContents hl + +hotlink :: URL -> [Html] -> HotLink +hotlink url h = HotLink { + hotLinkURL = url, + hotLinkContents = h, + hotLinkAttributes = [] } + + +-- --------------------------------------------------------------------------- +-- More Combinators + +-- (Abridged from Erik Meijer's Original Html library) + +ordList :: (HTML a) => [a] -> Html +ordList items = olist << map (li <<) items + +unordList :: (HTML a) => [a] -> Html +unordList items = ulist << map (li <<) items + +defList :: (HTML a,HTML b) => [(a,b)] -> Html +defList items + = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ] + + +widget :: String -> String -> [HtmlAttr] -> Html +widget w n markupAttrs0 = input ! ([thetype w,name n] ++ markupAttrs0) + +checkbox :: String -> String -> Html +hidden :: String -> String -> Html +radio :: String -> String -> Html +reset :: String -> String -> Html +submit :: String -> String -> Html +password :: String -> Html +textfield :: String -> Html +afile :: String -> Html +clickmap :: String -> Html + +checkbox n v = widget "CHECKBOX" n [value v] +hidden n v = widget "HIDDEN" n [value v] +radio n v = widget "RADIO" n [value v] +reset n v = widget "RESET" n [value v] +submit n v = widget "SUBMIT" n [value v] +password n = widget "PASSWORD" n [] +textfield n = widget "TEXT" n [] +afile n = widget "FILE" n [] +clickmap n = widget "IMAGE" n [] + +menu :: String -> [Html] -> Html +menu n choices + = select ! [name n] << [ option << p << choice | choice <- choices ] + +gui :: String -> Html -> Html +gui act = form ! [action act,method "POST"] + +-- --------------------------------------------------------------------------- +-- Html Rendering + +-- Uses the append trick to optimize appending. +-- The output is quite messy, because space matters in +-- HTML, so we must not generate needless spaces. + +renderHtml :: (HTML html) => html -> String +renderHtml theHtml = + renderMessage ++ + foldr (.) id (map unprettyHtml + (getHtmlElements (tag "HTML" << theHtml))) "\n" + +renderMessage :: String +renderMessage = + "\n" ++ + "\n" + +unprettyHtml :: HtmlElement -> ShowS +unprettyHtml (HtmlString str) = (++) str +unprettyHtml (HtmlTag + { markupTag = name0, + markupContent = html, + markupAttrs = markupAttrs0 }) + = if isNoHtml html && elem name0 validHtmlITags + then renderTag True name0 markupAttrs0 0 + else (renderTag True name0 markupAttrs0 0 + . foldr (.) id (map unprettyHtml (getHtmlElements html)) + . renderTag False name0 [] 0) + +-- Local Utilities +prettyHtml :: (HTML html) => html -> String +prettyHtml theHtml = + unlines + $ concat + $ map prettyHtml' + $ getHtmlElements + $ toHtml theHtml + +prettyHtml' :: HtmlElement -> [String] +prettyHtml' (HtmlString str) = [str] +prettyHtml' (HtmlTag + { markupTag = name0, + markupContent = html, + markupAttrs = markupAttrs0 }) + = if isNoHtml html && elem name0 validHtmlITags + then + [rmNL (renderTag True name0 markupAttrs0 0 "")] + else + [rmNL (renderTag True name0 markupAttrs0 0 "")] ++ + shift (concat (map prettyHtml' (getHtmlElements html))) ++ + [rmNL (renderTag False name0 [] 0 "")] + where + shift = map (\x -> " " ++ x) + +rmNL :: [Char] -> [Char] +rmNL = filter (/= '\n') + +-- This prints the Tags The lack of spaces in intentunal, because Html is +-- actually space dependant. + +renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS +renderTag x name0 markupAttrs0 n r + = open ++ name0 ++ rest markupAttrs0 ++ ">" ++ r + where + open = if x then "<" else " String + showPair (HtmlAttr tag0 val) + = tag0 ++ "=\"" ++ val ++ "\"" + diff --git a/src/Haddock/Version.hs b/src/Haddock/Version.hs new file mode 100644 index 00000000..f4d02b7d --- /dev/null +++ b/src/Haddock/Version.hs @@ -0,0 +1,18 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2003 +-- + +module Haddock.Version ( + projectName, projectVersion, projectUrl + ) where + +import Paths_haddock_ghc ( version ) +import Data.Version ( showVersion ) + +projectName, projectUrl :: String +projectName = "Haddock-GHC" +projectUrl = "http://www.haskell.org/haddock/" + +projectVersion = showVersion version diff --git a/src/HaddockDB.hs b/src/HaddockDB.hs deleted file mode 100644 index bc6af5a6..00000000 --- a/src/HaddockDB.hs +++ /dev/null @@ -1,165 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- - -module HaddockDB (ppDocBook) where - -{- -import HaddockTypes -import HaddockUtil -import HsSyn2 - -import Text.PrettyPrint --} - ------------------------------------------------------------------------------ --- Printing the results in DocBook format - -ppDocBook = error "not working" -{- -ppDocBook :: FilePath -> [(Module, Interface)] -> String -ppDocBook odir mods = render (ppIfaces mods) - -ppIfaces mods - = text "" - $$ text "" - $$ text "" - $$ text "HaskellDoc version 0.0" - $$ text "" - $$ text "
    " - $$ vcat (map do_mod mods) - $$ text "
    " - where - do_mod (Module mod, iface) - = text " text mod <> text "\">" - $$ text "<literal>" - <> text mod - <> text "</literal>" - $$ text "" - <> text mod - <> text "" - $$ text "" - $$ vcat (map (do_export mod) (eltsFM (iface_decls iface))) - $$ text "" - $$ text "" - - do_export mod decl | (nm:_) <- declBinders decl - = text "" - <> do_decl decl - <> text "" - $$ text "" - $$ text "" - $$ text "" - $$ text "" - $$ text "" - do_export _ _ = empty - - do_decl (HsTypeSig _ [nm] ty _) - = ppHsName nm <> text " :: " <> ppHsType ty - do_decl (HsTypeDecl _ nm args ty _) - = hsep ([text "type", ppHsName nm ] - ++ map ppHsName args - ++ [equals, ppHsType ty]) - do_decl (HsNewTypeDecl loc ctx nm args con drv _) - = hsep ([text "data", ppHsName nm] -- data, not newtype - ++ map ppHsName args - ) <+> equals <+> ppHsConstr con -- ToDo: derivings - do_decl (HsDataDecl loc ctx nm args cons drv _) - = hsep ([text "data", {-ToDo: context-}ppHsName nm] - ++ map ppHsName args) - <+> vcat (zipWith (<+>) (equals : repeat (char '|')) - (map ppHsConstr cons)) - do_decl (HsClassDecl loc ty fds decl _) - = hsep [text "class", ppHsType ty] - do_decl decl - = empty - -ppHsConstr :: HsConDecl -> Doc -ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) = - ppHsName name - <> (braces . hsep . punctuate comma . map ppField $ fieldList) -ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = - hsep (ppHsName name : map ppHsBangType typeList) - -ppField (HsFieldDecl ns ty doc) - = hsep (punctuate comma (map ppHsName ns) ++ - [text "::", ppHsBangType ty]) - -ppHsBangType :: HsBangType -> Doc -ppHsBangType (HsBangedTy ty) = char '!' <> ppHsType ty -ppHsBangType (HsUnBangedTy ty) = ppHsType ty - -ppHsContext :: HsContext -> Doc -ppHsContext [] = empty -ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> - hsep (map ppHsAType b)) context) - -ppHsType :: HsType -> Doc -ppHsType (HsForAllType Nothing context htype) = - hsep [ ppHsContext context, text "=>", ppHsType htype] -ppHsType (HsForAllType (Just tvs) [] htype) = - hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype]) -ppHsType (HsForAllType (Just tvs) context htype) = - hsep (text "forall" : map ppHsName tvs ++ text "." : - ppHsContext context : text "=>" : [ppHsType htype]) -ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b] -ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t] -ppHsType t = ppHsBType t - -ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) - = brackets $ ppHsType b -ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b] -ppHsBType t = ppHsAType t - -ppHsAType :: HsType -> Doc -ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l -ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l --- special case -ppHsAType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) - = brackets $ ppHsType b -ppHsAType (HsTyVar name) = ppHsName name -ppHsAType (HsTyCon name) = ppHsQName name -ppHsAType t = parens $ ppHsType t - -ppHsQName :: HsQName -> Doc -ppHsQName (UnQual str) = ppHsName str -ppHsQName n@(Qual (Module mod) str) - | n == unit_con_name = ppHsName str - | isSpecial str = ppHsName str - | otherwise - = text "" - -isSpecial (HsTyClsName id) | HsSpecial _ <- id = True -isSpecial (HsVarName id) | HsSpecial _ <- id = True -isSpecial _ = False - -ppHsName :: HsName -> Doc -ppHsName (HsTyClsName id) = ppHsIdentifier id -ppHsName (HsVarName id) = ppHsIdentifier id - -ppHsIdentifier :: HsIdentifier -> Doc -ppHsIdentifier (HsIdent str) = text str -ppHsIdentifier (HsSymbol str) = text str -ppHsIdentifier (HsSpecial str) = text str - -ppLinkId :: String -> HsName -> Doc -ppLinkId mod str - = hcat [char '\"', text mod, char '.', ppHsName str, char '\"'] - --- ----------------------------------------------------------------------------- --- * Misc - -parenList :: [Doc] -> Doc -parenList = parens . fsep . punctuate comma - -ubxParenList :: [Doc] -> Doc -ubxParenList = ubxparens . fsep . punctuate comma - -ubxparens p = text "(#" <> p <> text "#)" --} diff --git a/src/HaddockDevHelp.hs b/src/HaddockDevHelp.hs deleted file mode 100644 index 8bf65d1a..00000000 --- a/src/HaddockDevHelp.hs +++ /dev/null @@ -1,75 +0,0 @@ -module HaddockDevHelp(ppDevHelpFile) where - -import HaddockModuleTree -import HaddockTypes -import HaddockUtil - -import Module ( moduleName, moduleNameString, Module, mkModule, mkModuleName ) -import PackageConfig ( stringToPackageId ) -import Name ( Name, nameModule, getOccString ) - -import Data.Maybe ( fromMaybe ) -import qualified Data.Map as Map -import Text.PrettyPrint - -ppDevHelpFile :: FilePath -> String -> Maybe String -> [HaddockModule] -> IO () -ppDevHelpFile odir doctitle maybe_package modules = do - let devHelpFile = package++".devhelp" - tree = mkModuleTree True [ (hmod_mod mod, toDescription mod) | mod <- modules ] - doc = - text "" $$ - (text "text doctitle<> - text "\" link=\""<>text contentsHtmlFile<>text"\" author=\"\" name=\""<>text package<>text "\">") $$ - text "" $$ - nest 4 (ppModuleTree [] tree) $+$ - text "" $$ - text "" $$ - nest 4 (ppList index) $+$ - text "" $$ - text "" - writeFile (pathJoin [odir, devHelpFile]) (render doc) - where - package = fromMaybe "pkg" maybe_package - - ppModuleTree :: [String] -> [ModuleTree] -> Doc - ppModuleTree ss [x] = ppNode ss x - ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs - ppModuleTree _ [] = error "HaddockHH.ppHHContents.fn: no module trees given" - - ppNode :: [String] -> ModuleTree -> Doc - ppNode ss (Node s leaf _ _short ts) = - case ts of - [] -> text "ppAttribs<>text "/>" - ts -> - text "ppAttribs<>text ">" $$ - nest 4 (ppModuleTree (s:ss) ts) $+$ - text "" - where - ppLink | leaf = text (moduleHtmlFile (mkModule (stringToPackageId "") - (mkModuleName mdl))) - | otherwise = empty - - ppAttribs = text "name="<>doubleQuotes (text s)<+>text "link="<>doubleQuotes ppLink - - mdl = foldr (++) "" (s' : map ('.':) ss') - (s':ss') = reverse (s:ss) - -- reconstruct the module name - - index :: [(Name, [Module])] - index = Map.toAscList (foldr getModuleIndex Map.empty modules) - - getModuleIndex hmod fm = - Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mod]) | name <- hmod_exports hmod, nameModule name == mod]) fm - where mod = hmod_mod hmod - - ppList :: [(Name, [Module])] -> Doc - ppList [] = empty - ppList ((name,refs):mdls) = - ppReference name refs $$ - ppList mdls - - ppReference :: Name -> [Module] -> Doc - ppReference name [] = empty - ppReference name (mod:refs) = - text "text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mod name)<>text"\"/>" $$ - ppReference name refs diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs deleted file mode 100644 index 7e6ef394..00000000 --- a/src/HaddockHH.hs +++ /dev/null @@ -1,174 +0,0 @@ -module HaddockHH(ppHHContents, ppHHIndex, ppHHProject) where - -ppHHContents = error "not yet" -ppHHIndex = error "not yet" -ppHHProject = error "not yet" - -{- -import HaddockModuleTree -import HaddockTypes -import HaddockUtil -import HsSyn2 hiding(Doc) -import qualified Map - -import Data.Char ( toUpper ) -import Data.Maybe ( fromMaybe ) -import Text.PrettyPrint - -ppHHContents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO () -ppHHContents odir doctitle maybe_package tree = do - let contentsHHFile = package++".hhc" - - html = - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - ppModuleTree tree $$ - text "" - writeFile (pathJoin [odir, contentsHHFile]) (render html) - where - package = fromMaybe "pkg" maybe_package - - ppModuleTree :: [ModuleTree] -> Doc - ppModuleTree ts = - text "" $$ - text "" $$ - text "" $$ - text "
      " $+$ - nest 4 (text "
    • " <> nest 4 - (text "" $$ - nest 4 (text "text doctitle<>text "\">" $$ - text "") $$ - text "") $+$ - text "
      • " $$ - text "
        " $+$ - nest 4 (fn [] ts) $+$ - text "
      ") $+$ - text "
    " - - fn :: [String] -> [ModuleTree] -> Doc - fn ss [x] = ppNode ss x - fn ss (x:xs) = ppNode ss x $$ fn ss xs - fn _ [] = error "HaddockHH.ppHHContents.fn: no module trees given" - - ppNode :: [String] -> ModuleTree -> Doc - ppNode ss (Node s leaf _pkg _ []) = - ppLeaf s ss leaf - ppNode ss (Node s leaf _pkg _ ts) = - ppLeaf s ss leaf $$ - text "
      " $+$ - nest 4 (fn (s:ss) ts) $+$ - text "
    " - - ppLeaf s ss isleaf = - text "
  • " <> nest 4 - (text "" $$ - text " text s <> text "\">" $$ - (if isleaf then text " text (moduleHtmlFile mdl) <> text "\">" else empty) $$ - text "") $+$ - text "
    • " - where - mdl = foldr (++) "" (s' : map ('.':) ss') - (s':ss') = reverse (s:ss) - -- reconstruct the module name - -------------------------------- -ppHHIndex :: FilePath -> Maybe String -> [Interface] -> IO () -ppHHIndex odir maybe_package ifaces = do - let indexHHFile = package++".hhk" - - html = - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "
      " $+$ - nest 4 (ppList index) $+$ - text "
    " $$ - text "" - writeFile (pathJoin [odir, indexHHFile]) (render html) - where - package = fromMaybe "pkg" maybe_package - - index :: [(HsName, [Module])] - index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces) - - getIfaceIndex iface fm = - foldl (\m (k,e) -> Map.insertWith (++) k e m) fm [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl'] - where mdl = iface_module iface - - ppList [] = empty - ppList ((name,refs):mdls) = - text "
  • " <> nest 4 - (text "" $$ - text " text (show name) <> text "\">" $$ - ppReference name refs $$ - text "") $+$ - text "
    • " $$ - ppList mdls - - ppReference name [] = empty - ppReference name (Module mdl:refs) = - text " text (nameHtmlRef mdl name) <> text "\">" $$ - ppReference name refs - - -ppHHProject :: FilePath -> String -> Maybe String -> [Interface] -> [FilePath] -> IO () -ppHHProject odir doctitle maybe_package ifaces pkg_paths = do - let projectHHFile = package++".hhp" - doc = - text "[OPTIONS]" $$ - text "Compatibility=1.1 or later" $$ - text "Compiled file=" <> text package <> text ".chm" $$ - text "Contents file=" <> text package <> text ".hhc" $$ - text "Default topic=" <> text contentsHtmlFile $$ - text "Display compile progress=No" $$ - text "Index file=" <> text package <> text ".hhk" $$ - text "Title=" <> text doctitle $$ - space $$ - text "[FILES]" $$ - ppMods ifaces $$ - text contentsHtmlFile $$ - text indexHtmlFile $$ - ppIndexFiles chars $$ - ppLibFiles ("":pkg_paths) - writeFile (pathJoin [odir, projectHHFile]) (render doc) - where - package = fromMaybe "pkg" maybe_package - - ppMods [] = empty - ppMods (iface:ifaces) = - let Module mdl = iface_module iface in - text (moduleHtmlFile mdl) $$ - ppMods ifaces - - ppIndexFiles [] = empty - ppIndexFiles (c:cs) = - text (subIndexHtmlFile c) $$ - ppIndexFiles cs - - ppLibFiles [] = empty - ppLibFiles (path:paths) = - ppLibFile cssFile $$ - ppLibFile iconFile $$ - ppLibFile jsFile $$ - ppLibFile plusFile $$ - ppLibFile minusFile $$ - ppLibFiles paths - where - toPath fname | null path = fname - | otherwise = pathJoin [path, fname] - ppLibFile fname = text (toPath fname) - - chars :: [Char] - chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces)) - - getIfaceIndex iface fm = - Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm - where mdl = iface_module iface --} diff --git a/src/HaddockHH2.hs b/src/HaddockHH2.hs deleted file mode 100644 index c329e254..00000000 --- a/src/HaddockHH2.hs +++ /dev/null @@ -1,182 +0,0 @@ -module HaddockHH2(ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where - -ppHH2Contents = error "not yet" -ppHH2Index = error "not yet" -ppHH2Files = error "not yet" -ppHH2Collection = error "not yet" - -{- -import HaddockModuleTree -import HaddockTypes -import HaddockUtil -import HsSyn2 hiding(Doc) -import qualified Map - -import Data.Char ( toUpper ) -import Data.Maybe ( fromMaybe ) -import Text.PrettyPrint - -ppHH2Contents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO () -ppHH2Contents odir doctitle maybe_package tree = do - let - contentsHH2File = package++".HxT" - - doc = - text "" $$ - text "" $$ - text "" $$ - nest 4 (text "text doctitle<>text"\" Url=\"index.html\">" $$ - nest 4 (ppModuleTree [] tree) $+$ - text "") $$ - text "" - writeFile (pathJoin [odir, contentsHH2File]) (render doc) - where - package = fromMaybe "pkg" maybe_package - - ppModuleTree :: [String] -> [ModuleTree] -> Doc - ppModuleTree ss [x] = ppNode ss x - ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs - ppModuleTree _ [] = error "HaddockHH2.ppHH2Contents.ppModuleTree: no module trees given" - - ppNode :: [String] -> ModuleTree -> Doc - ppNode ss (Node s leaf _pkg _short []) = - text " ppAttributes leaf (s:ss) <> text "/>" - ppNode ss (Node s leaf _pkg _short ts) = - text " ppAttributes leaf (s:ss) <> text ">" $$ - nest 4 (ppModuleTree (s:ss) ts) $+$ - text "" - - ppAttributes :: Bool -> [String] -> Doc - ppAttributes isleaf ss = hsep [ppId,ppTitle,ppUrl] - where - mdl = foldr (++) "" (s' : map ('.':) ss') - (s':ss') = reverse ss - -- reconstruct the module name - - ppId = text "Id=" <> doubleQuotes (text mdl) - - ppTitle = text "Title=" <> doubleQuotes (text (head ss)) - - ppUrl | isleaf = text " Url=" <> doubleQuotes (text (moduleHtmlFile mdl)) - | otherwise = empty - ------------------------------------------------------------------------------------ - -ppHH2Index :: FilePath -> Maybe String -> [Interface] -> IO () -ppHH2Index odir maybe_package ifaces = do - let - indexKHH2File = package++"K.HxK" - indexNHH2File = package++"N.HxK" - docK = - text "" $$ - text "" $$ - text "" $$ - nest 4 (ppList index) $+$ - text "" - docN = - text "" $$ - text "" $$ - text "" $$ - text "" $$ - nest 4 (text "text contentsHtmlFile<>text "\"/>") $$ - text "" $$ - text "" - writeFile (pathJoin [odir, indexKHH2File]) (render docK) - writeFile (pathJoin [odir, indexNHH2File]) (render docN) - where - package = fromMaybe "pkg" maybe_package - - index :: [(HsName, [Module])] - index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces) - - getIfaceIndex iface fm = - Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm - where mdl = iface_module iface - - ppList [] = empty - ppList ((name,mdls):vs) = - text " text (escapeStr (show name)) <> text "\">" $$ - nest 4 (vcat (map (ppJump name) mdls)) $$ - text "" $$ - ppList vs - - ppJump name (Module mdl) = text " text (nameHtmlRef mdl name) <> text "\"/>" - - ------------------------------------------------------------------------------------ - -ppHH2Files :: FilePath -> Maybe String -> [Interface] -> [FilePath] -> IO () -ppHH2Files odir maybe_package ifaces pkg_paths = do - let filesHH2File = package++".HxF" - doc = - text "" $$ - text "" $$ - text "" $$ - nest 4 (ppMods ifaces $$ - text "text contentsHtmlFile<>text "\"/>" $$ - text "text indexHtmlFile<>text "\"/>" $$ - ppIndexFiles chars $$ - ppLibFiles ("":pkg_paths)) $$ - text "" - writeFile (pathJoin [odir, filesHH2File]) (render doc) - where - package = fromMaybe "pkg" maybe_package - - ppMods [] = empty - ppMods (iface:ifaces) = - text " text (moduleHtmlFile mdl) <> text "\"/>" $$ - ppMods ifaces - where Module mdl = iface_module iface - - ppIndexFiles [] = empty - ppIndexFiles (c:cs) = - text "text (subIndexHtmlFile c)<>text "\"/>" $$ - ppIndexFiles cs - - ppLibFiles [] = empty - ppLibFiles (path:paths) = - ppLibFile cssFile $$ - ppLibFile iconFile $$ - ppLibFile jsFile $$ - ppLibFile plusFile $$ - ppLibFile minusFile $$ - ppLibFiles paths - where - toPath fname | null path = fname - | otherwise = pathJoin [path, fname] - ppLibFile fname = text "text (toPath fname)<>text "\"/>" - - chars :: [Char] - chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces)) - - getIfaceIndex iface fm = - Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm - where mdl = iface_module iface - ------------------------------------------------------------------------------------ - -ppHH2Collection :: FilePath -> String -> Maybe String -> IO () -ppHH2Collection odir doctitle maybe_package = do - let - package = fromMaybe "pkg" maybe_package - collectionHH2File = package++".HxC" - - doc = - text "" $$ - text "" $$ - text " text doctitle <> text "\">" $$ - nest 4 (text "" $$ - nest 4 (text " text package <> text ".HxF\"/>") $$ - text "" $$ - text " text package <> text ".HxT\"/>" $$ - text " text package <> text "K.HxK\"/>" $$ - text " text package <> text "N.HxK\"/>" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "") $$ - text "" - writeFile (pathJoin [odir, collectionHH2File]) (render doc) --} diff --git a/src/HaddockHoogle.hs b/src/HaddockHoogle.hs deleted file mode 100644 index da43f007..00000000 --- a/src/HaddockHoogle.hs +++ /dev/null @@ -1,184 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- --- This file, (c) Neil Mitchell 2006 --- Write out Hoogle compatible documentation --- http://www.haskell.org/hoogle/ - -module HaddockHoogle ( - ppHoogle - ) where - -ppHoogle = undefined - -{- -import HaddockTypes -import HaddockUtil -import HsSyn2 - -import Data.List ( intersperse ) - - - -prefix = ["-- Hoogle documentation, generated by Haddock", - "-- See Hoogle, http://www.haskell.org/hoogle/"] - -ppHoogle :: Maybe String -> [Interface] -> FilePath -> IO () -ppHoogle maybe_package ifaces odir = - do - let - filename = case maybe_package of - Just x -> x ++ ".txt" - Nothing -> "hoogle.txt" - - visible_ifaces = filter visible ifaces - visible i = OptHide `notElem` iface_options i - - contents = prefix : map ppModule visible_ifaces - - writeFile (pathJoin [odir, filename]) (unlines $ concat contents) - - - --- --------------------------------------------------------------------------- --- Generate the HTML page for a module - - -ppDecl :: HsDecl -> [String] -ppDecl (HsNewTypeDecl src context name args ctor unknown docs) = - ppData "newtype" context name args [ctor] - -ppDecl (HsDataDecl src context name args ctors unknown docs) = - ppData "data" context name args ctors - -ppDecl (HsTypeSig src names t doc) = map (`ppFunc` t) names - -ppDecl (HsForeignImport src _ _ _ name t doc) = ppDecl $ HsTypeSig src [name] t doc - -ppDecl (HsClassDecl src context name args fundeps members doc) = - ("class " ++ ppContext context ++ ppType typ) : concatMap f members - where - typ = foldl HsTyApp (HsTyCon $ UnQual name) (map HsTyVar args) - newcontext = (UnQual name, map HsTyVar args) - f (HsTypeSig src names t doc) = ppDecl (HsTypeSig src names (addContext newcontext t) doc) - f (HsFunBind{}) = [] - f (HsPatBind{}) = [] - f x = ["-- ERR " ++ show x] - -ppDecl (HsTypeDecl src name args t doc) = - ["type " ++ show name ++ concatMap (\x -> ' ':show x) args ++ " = " ++ ppType t] - -ppDecl x = ["-- ERR " ++ show x] - - - -addContext :: HsAsst -> HsType -> HsType -addContext ctx (HsForAllType Nothing context t) = HsForAllType Nothing (HsAssump ctx : context) t -addContext ctx x = HsForAllType Nothing [HsAssump ctx] x - - - -ppFunc :: HsName -> HsType -> String -ppFunc name typ = show name ++ " :: " ++ ppType typ - - -ppData :: String -> HsContext -> HsName -> [HsName] -> [HsConDecl] -> [String] -ppData mode context name args ctors = (mode ++ " " ++ ppType typ) : concatMap (ppCtor typ) ctors - where - typ = foldl HsTyApp (HsTyCon $ UnQual name) (map HsTyVar args) - - -deBang :: HsBangType -> HsType -deBang (HsBangedTy x) = x -deBang (HsUnBangedTy x) = x - - -ppCtor :: HsType -> HsConDecl -> [String] -ppCtor result (HsConDecl src name types context typ doc) = - [show name ++ " :: " ++ ppContext context ++ ppTypesArr (map deBang typ ++ [result])] - -ppCtor result (HsRecDecl src name types context fields doc) = - ppCtor result (HsConDecl src name types context (map snd fields2) doc) ++ - concatMap f fields2 - where - fields2 = [(name, typ) | HsFieldDecl names typ _ <- fields, name <- names] - f (name, typ) = ppDecl $ HsTypeSig src [name] (HsTyFun result (deBang typ)) doc - - -brack True x = "(" ++ x ++ ")" -brack False x = x - -ppContext :: HsContext -> String -ppContext [] = "" -ppContext xs = brack (length xs > 1) (concat $ intersperse ", " $ map ppContextItem xs) ++ " => " - -ppContextItem :: HsAsst -> String -ppContextItem (name, types) = ppQName name ++ concatMap (\x -> ' ':ppType x) types - -ppContext2 :: HsIPContext -> String -ppContext2 xs = ppContext [x | HsAssump x <- xs] - - -ppType :: HsType -> String -ppType x = f 0 x - where - f _ (HsTyTuple _ xs) = brack True $ concat $ intersperse ", " $ map (f 0) xs - f _ (HsTyCon x) = ppQName x - f _ (HsTyVar x) = show x - - -- ignore ForAll types as Hoogle does not support them - f n (HsForAllType (Just items) context t) = - -- brack (n > 1) $ - -- "forall" ++ concatMap (\x -> ' ':toStr x) items ++ " . " ++ f 0 t - f n t - - f n (HsForAllType Nothing context t) = brack (n > 1) $ - ppContext2 context ++ f 0 t - - f n (HsTyFun a b) = brack g $ f (h 3) a ++ " -> " ++ f (h 2) b - where - g = n > 2 - h x = if g then 0 else x - - f n (HsTyApp a b) | ppType a == "[]" = "[" ++ f 0 b ++ "]" - - f n (HsTyApp a b) = brack g $ f (h 3) a ++ " " ++ f (h 4) b - where - g = n > 3 - h x = if g then 0 else x - - f n (HsTyDoc x _) = f n x - - f n x = brack True $ show x - - -ppQName :: HsQName -> String -ppQName (Qual _ name) = show name -ppQName (UnQual name) = show name - - - -ppTypesArr :: [HsType] -> String -ppTypesArr xs = ppType $ foldr1 HsTyFun xs - - - -ppInst :: InstHead -> String -ppInst (context, item) = "instance " ++ ppContext context ++ ppContextItem item - - - -ppModule :: Interface -> [String] -ppModule iface = "" : ("module " ++ mdl) : concatMap ppExport (iface_exports iface) - where - Module mdl = iface_module iface - - -ppExport :: ExportItem -> [String] -ppExport (ExportDecl name decl insts) = ppDecl decl ++ map ppInst insts -ppExport _ = [] - - --} diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs deleted file mode 100644 index b42cfe6b..00000000 --- a/src/HaddockHtml.hs +++ /dev/null @@ -1,1508 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- - -module HaddockHtml ( - ppHtml, copyHtmlBits, - ppHtmlIndex, ppHtmlContents, - ppHtmlHelpFiles - ) where - -import Prelude hiding (div) - -import HaddockDevHelp -import HaddockHH -import HaddockHH2 -import HaddockModuleTree -import HaddockTypes -import HaddockUtil -import HaddockVersion -import Html -import qualified Html - -import Control.Exception ( bracket ) -import Control.Monad ( when, unless ) -import Data.Char ( isUpper, toUpper ) -import Data.List ( sortBy ) -import Data.Maybe ( fromJust, isJust, mapMaybe, fromMaybe ) -import Foreign.Marshal.Alloc ( allocaBytes ) -import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile ) -import Debug.Trace ( trace ) -import Data.Map ( Map ) -import qualified Data.Map as Map hiding ( Map ) - -import GHC -import Name -import Module -import PackageConfig ( stringToPackageId ) -import RdrName hiding ( Qual ) -import SrcLoc -import FastString ( unpackFS ) -import BasicTypes ( IPName(..), Boxity(..) ) -import Type ( Kind ) -import Outputable ( ppr, defaultUserStyle, showSDoc ) - --- the base, module and entity URLs for the source code and wiki links. -type SourceURLs = (Maybe String, Maybe String, Maybe String) -type WikiURLs = (Maybe String, Maybe String, Maybe String) - --- ----------------------------------------------------------------------------- --- Generating HTML documentation - -ppHtml :: String - -> Maybe String -- package - -> [HaddockModule] - -> FilePath -- destination directory - -> Maybe (GHC.HsDoc GHC.RdrName) -- prologue text, maybe - -> Maybe String -- the Html Help format (--html-help) - -> SourceURLs -- the source URL (--source) - -> WikiURLs -- the wiki URL (--wiki) - -> Maybe String -- the contents URL (--use-contents) - -> Maybe String -- the index URL (--use-index) - -> IO () - -ppHtml doctitle maybe_package hmods odir prologue maybe_html_help_format - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url = do - let - visible_hmods = filter visible hmods - visible i = OptHide `notElem` hmod_options i - - when (not (isJust maybe_contents_url)) $ - ppHtmlContents odir doctitle maybe_package - maybe_html_help_format maybe_index_url maybe_source_url maybe_wiki_url - visible_hmods - False -- we don't want to display the packages in a single-package contents - prologue - - when (not (isJust maybe_index_url)) $ - ppHtmlIndex odir doctitle maybe_package maybe_html_help_format - maybe_contents_url maybe_source_url maybe_wiki_url visible_hmods - - when (not (isJust maybe_contents_url && isJust maybe_index_url)) $ - ppHtmlHelpFiles doctitle maybe_package hmods odir maybe_html_help_format [] - - mapM_ (ppHtmlModule odir doctitle - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url) visible_hmods - -ppHtmlHelpFiles - :: String -- doctitle - -> Maybe String -- package - -> [HaddockModule] - -> FilePath -- destination directory - -> Maybe String -- the Html Help format (--html-help) - -> [FilePath] -- external packages paths - -> IO () -ppHtmlHelpFiles doctitle maybe_package hmods odir maybe_html_help_format pkg_paths = do - let - visible_hmods = filter visible hmods - visible i = OptHide `notElem` hmod_options i - - -- Generate index and contents page for Html Help if requested - case maybe_html_help_format of - Nothing -> return () - Just "mshelp" -> ppHHProject odir doctitle maybe_package visible_hmods pkg_paths - Just "mshelp2" -> do - ppHH2Files odir maybe_package visible_hmods pkg_paths - ppHH2Collection odir doctitle maybe_package - Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_hmods - Just format -> fail ("The "++format++" format is not implemented") - -copyFile :: FilePath -> FilePath -> IO () -copyFile fromFPath toFPath = - (bracket (openFile fromFPath ReadMode) hClose $ \hFrom -> - bracket (openFile toFPath WriteMode) hClose $ \hTo -> - allocaBytes bufferSize $ \buffer -> - copyContents hFrom hTo buffer) - where - bufferSize = 1024 - - copyContents hFrom hTo buffer = do - count <- hGetBuf hFrom buffer bufferSize - when (count > 0) $ do - hPutBuf hTo buffer count - copyContents hFrom hTo buffer - - -copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO () -copyHtmlBits odir libdir maybe_css = do - let - libhtmldir = pathJoin [libdir, "html"] - css_file = case maybe_css of - Nothing -> pathJoin [libhtmldir, cssFile] - Just f -> f - css_destination = pathJoin [odir, cssFile] - copyLibFile f = do - copyFile (pathJoin [libhtmldir, f]) (pathJoin [odir, f]) - copyFile css_file css_destination - mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile ] - -footer :: HtmlTable -footer = - tda [theclass "botbar"] << - ( toHtml "Produced by" <+> - (anchor ! [href projectUrl] << toHtml projectName) <+> - toHtml ("version " ++ projectVersion) - ) - -srcButton :: SourceURLs -> Maybe HaddockModule -> HtmlTable -srcButton (Just src_base_url, _, _) Nothing = - topButBox (anchor ! [href src_base_url] << toHtml "Source code") - -srcButton (_, Just src_module_url, _) (Just hmod) = - let url = spliceURL (Just $ hmod_orig_filename hmod) - (Just $ hmod_mod hmod) Nothing src_module_url - in topButBox (anchor ! [href url] << toHtml "Source code") - -srcButton _ _ = - Html.emptyTable - -spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> String -> String -spliceURL maybe_file maybe_mod maybe_name url = run url - where - file = fromMaybe "" maybe_file - mod = case maybe_mod of - Nothing -> "" - Just mod -> moduleString mod - - (name, kind) = - case maybe_name of - Nothing -> ("","") - Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v") - | otherwise -> (escapeStr (getOccString n), "t") - - run "" = "" - run ('%':'M':rest) = mod ++ run rest - run ('%':'F':rest) = file ++ run rest - run ('%':'N':rest) = name ++ run rest - run ('%':'K':rest) = kind ++ run rest - - run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mod ++ run rest - run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest - run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest - run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest - - run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) = - map (\x -> if x == '.' then c else x) mod ++ run rest - - run (c:rest) = c : run rest - -wikiButton :: WikiURLs -> Maybe Module -> HtmlTable -wikiButton (Just wiki_base_url, _, _) Nothing = - topButBox (anchor ! [href wiki_base_url] << toHtml "User Comments") - -wikiButton (_, Just wiki_module_url, _) (Just mod) = - let url = spliceURL Nothing (Just mod) Nothing wiki_module_url - in topButBox (anchor ! [href url] << toHtml "User Comments") - -wikiButton _ _ = - Html.emptyTable - -contentsButton :: Maybe String -> HtmlTable -contentsButton maybe_contents_url - = topButBox (anchor ! [href url] << toHtml "Contents") - where url = case maybe_contents_url of - Nothing -> contentsHtmlFile - Just url -> url - -indexButton :: Maybe String -> HtmlTable -indexButton maybe_index_url - = topButBox (anchor ! [href url] << toHtml "Index") - where url = case maybe_index_url of - Nothing -> indexHtmlFile - Just url -> url - -simpleHeader :: String -> Maybe String -> Maybe String - -> SourceURLs -> WikiURLs -> HtmlTable -simpleHeader doctitle maybe_contents_url maybe_index_url - maybe_source_url maybe_wiki_url = - (tda [theclass "topbar"] << - vanillaTable << ( - (td << - image ! [src "haskell_icon.gif", width "16", height 16, alt " " ] - ) <-> - (tda [theclass "title"] << toHtml doctitle) <-> - srcButton maybe_source_url Nothing <-> - wikiButton maybe_wiki_url Nothing <-> - contentsButton maybe_contents_url <-> indexButton maybe_index_url - )) - -pageHeader :: String -> HaddockModule -> String - -> SourceURLs -> WikiURLs - -> Maybe String -> Maybe String -> HtmlTable -pageHeader mdl hmod doctitle - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url = - (tda [theclass "topbar"] << - vanillaTable << ( - (td << - image ! [src "haskell_icon.gif", width "16", height 16, alt " "] - ) <-> - (tda [theclass "title"] << toHtml doctitle) <-> - srcButton maybe_source_url (Just hmod) <-> - wikiButton maybe_wiki_url (Just $ hmod_mod hmod) <-> - contentsButton maybe_contents_url <-> - indexButton maybe_index_url - ) - ) - tda [theclass "modulebar"] << - (vanillaTable << ( - (td << font ! [size "6"] << toHtml mdl) <-> - moduleInfo hmod - ) - ) - -moduleInfo :: HaddockModule -> HtmlTable -moduleInfo hmod = - let - info = hmod_info hmod - - doOneEntry :: (String, (GHC.HaddockModInfo GHC.Name) -> Maybe String) -> Maybe HtmlTable - doOneEntry (fieldName,field) = case field info of - Nothing -> Nothing - Just fieldValue -> - Just ((tda [theclass "infohead"] << toHtml fieldName) - <-> (tda [theclass "infoval"]) << toHtml fieldValue) - - entries :: [HtmlTable] - entries = mapMaybe doOneEntry [ - ("Portability",GHC.hmi_portability), - ("Stability",GHC.hmi_stability), - ("Maintainer",GHC.hmi_maintainer) - ] - in - case entries of - [] -> Html.emptyTable - _ -> tda [align "right"] << narrowTable << (foldl1 () entries) - --- --------------------------------------------------------------------------- --- Generate the module contents - -ppHtmlContents - :: FilePath - -> String - -> Maybe String - -> Maybe String - -> Maybe String - -> SourceURLs - -> WikiURLs - -> [HaddockModule] -> Bool -> Maybe (GHC.HsDoc GHC.RdrName) - -> IO () -ppHtmlContents odir doctitle - maybe_package maybe_html_help_format maybe_index_url - maybe_source_url maybe_wiki_url modules showPkgs prologue = do - let tree = mkModuleTree showPkgs - [(hmod_mod mod, toDescription mod) | mod <- modules] - html = - header - (documentCharacterEncoding +++ - thetitle (toHtml doctitle) +++ - styleSheet +++ - (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++ - body << vanillaTable << ( - simpleHeader doctitle Nothing maybe_index_url - maybe_source_url maybe_wiki_url - ppPrologue doctitle prologue - ppModuleTree doctitle tree - s15 - footer - ) - writeFile (pathJoin [odir, contentsHtmlFile]) (renderHtml html) - - -- Generate contents page for Html Help if requested - case maybe_html_help_format of - Nothing -> return () - Just "mshelp" -> ppHHContents odir doctitle maybe_package tree - Just "mshelp2" -> ppHH2Contents odir doctitle maybe_package tree - Just "devhelp" -> return () - Just format -> fail ("The "++format++" format is not implemented") - -ppPrologue :: String -> Maybe (GHC.HsDoc GHC.RdrName) -> HtmlTable -ppPrologue title Nothing = Html.emptyTable -ppPrologue title (Just doc) = - (tda [theclass "section1"] << toHtml title) - docBox (rdrDocToHtml doc) - -ppModuleTree :: String -> [ModuleTree] -> HtmlTable -ppModuleTree _ ts = - tda [theclass "section1"] << toHtml "Modules" - td << vanillaTable2 << htmlTable - where - genTable htmlTable id [] = (htmlTable,id) - genTable htmlTable id (x:xs) = genTable (htmlTable u) id' xs - where - (u,id') = mkNode [] x 0 id - - (htmlTable,_) = genTable emptyTable 0 ts - -mkNode :: [String] -> ModuleTree -> Int -> Int -> (HtmlTable,Int) -mkNode ss (Node s leaf pkg short ts) depth id = htmlNode - where - htmlNode = case ts of - [] -> (td_pad_w 1.25 depth << htmlModule <-> shortDescr <-> htmlPkg,id) - _ -> (td_w depth << (collapsebutton id_s +++ htmlModule) <-> shortDescr <-> htmlPkg - (td_subtree << sub_tree), id') - - mod_width = 50::Int {-em-} - - td_pad_w pad depth = - tda [thestyle ("padding-left: " ++ show pad ++ "em;" ++ - "width: " ++ show (mod_width - depth*2) ++ "em")] - - td_w depth = - tda [thestyle ("width: " ++ show (mod_width - depth*2) ++ "em")] - - td_subtree = - tda [thestyle ("padding: 0; padding-left: 2em")] - - shortDescr :: HtmlTable - shortDescr = case short of - Nothing -> td empty - Just doc -> tda [theclass "rdoc"] (origDocToHtml doc) - - htmlModule - | leaf = ppModule (mkModule (stringToPackageId pkgName) - (mkModuleName mdl)) "" - | otherwise = toHtml s - - -- ehm.. TODO: change the ModuleTree type - (htmlPkg, pkgName) = case pkg of - Nothing -> (td << empty, "") - Just p -> (td << toHtml p, p) - - mdl = foldr (++) "" (s' : map ('.':) ss') - (s':ss') = reverse (s:ss) - -- reconstruct the module name - - id_s = "n:" ++ show id - - (sub_tree,id') = genSubTree emptyTable (id+1) ts - - genSubTree :: HtmlTable -> Int -> [ModuleTree] -> (Html,Int) - genSubTree htmlTable id [] = (sub_tree,id) - where - sub_tree = collapsed vanillaTable2 id_s htmlTable - genSubTree htmlTable id (x:xs) = genSubTree (htmlTable u) id' xs - where - (u,id') = mkNode (s:ss) x (depth+1) id - --- The URL for source and wiki links, and the current module -type LinksInfo = (SourceURLs, WikiURLs, HaddockModule) - - --- --------------------------------------------------------------------------- --- Generate the index - -ppHtmlIndex :: FilePath - -> String - -> Maybe String - -> Maybe String - -> Maybe String - -> SourceURLs - -> WikiURLs - -> [HaddockModule] - -> IO () -ppHtmlIndex odir doctitle maybe_package maybe_html_help_format - maybe_contents_url maybe_source_url maybe_wiki_url modules = do - let html = - header (documentCharacterEncoding +++ - thetitle (toHtml (doctitle ++ " (Index)")) +++ - styleSheet) +++ - body << vanillaTable << ( - simpleHeader doctitle maybe_contents_url Nothing - maybe_source_url maybe_wiki_url - index_html - ) - - when split_indices $ - mapM_ (do_sub_index index) initialChars - - writeFile (pathJoin [odir, indexHtmlFile]) (renderHtml html) - - -- Generate index and contents page for Html Help if requested - case maybe_html_help_format of - Nothing -> return () - Just "mshelp" -> ppHHIndex odir maybe_package modules - Just "mshelp2" -> ppHH2Index odir maybe_package modules - Just "devhelp" -> return () - Just format -> fail ("The "++format++" format is not implemented") - where - split_indices = length index > 50 - - index_html - | split_indices = - tda [theclass "section1"] << - toHtml ("Index") - indexInitialLetterLinks - | otherwise = - td << table ! [cellpadding 0, cellspacing 5] << - aboves (map indexElt index) - - indexInitialLetterLinks = - td << table ! [cellpadding 0, cellspacing 5] << - besides [ td << anchor ! [href (subIndexHtmlFile c)] << - toHtml [c] - | c <- initialChars - , any ((==c) . toUpper . head . fst) index ] - - do_sub_index this_ix c - = unless (null index_part) $ - writeFile (pathJoin [odir, subIndexHtmlFile c]) (renderHtml html) - where - html = header (documentCharacterEncoding +++ - thetitle (toHtml (doctitle ++ " (Index)")) +++ - styleSheet) +++ - body << vanillaTable << ( - simpleHeader doctitle maybe_contents_url Nothing - maybe_source_url maybe_wiki_url - indexInitialLetterLinks - tda [theclass "section1"] << - toHtml ("Index (" ++ c:")") - td << table ! [cellpadding 0, cellspacing 5] << - aboves (map indexElt index_part) - ) - - index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c] - - index :: [(String, Map GHC.Name [(Module,Bool)])] - index = sortBy cmp (Map.toAscList full_index) - where cmp (n1,_) (n2,_) = n1 `compare` n2 - - -- for each name (a plain string), we have a number of original HsNames that - -- it can refer to, and for each of those we have a list of modules - -- that export that entity. Each of the modules exports the entity - -- in a visible or invisible way (hence the Bool). - full_index :: Map String (Map GHC.Name [(Module,Bool)]) - full_index = Map.fromListWith (flip (Map.unionWith (++))) - (concat (map getHModIndex modules)) - - getHModIndex hmod = - [ (getOccString name, - Map.fromList [(name, [(mdl, name `elem` hmod_visible_exports hmod)])]) - | name <- hmod_exports hmod ] - where mdl = hmod_mod hmod - - indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable - indexElt (str, entities) = - case Map.toAscList entities of - [(nm,entries)] -> - tda [ theclass "indexentry" ] << toHtml str <-> - indexLinks nm entries - many_entities -> - tda [ theclass "indexentry" ] << toHtml str - aboves (map doAnnotatedEntity (zip [1..] many_entities)) - - doAnnotatedEntity (j,(nm,entries)) - = tda [ theclass "indexannot" ] << - toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <-> - indexLinks nm entries - - ppAnnot n | not (isValOcc n) = toHtml "Type/Class" - | isDataOcc n = toHtml "Data Constructor" - | otherwise = toHtml "Function" - - indexLinks nm entries = - tda [ theclass "indexlinks" ] << - hsep (punctuate comma - [ if visible then - linkId mod (Just nm) << toHtml (moduleString mod) - else - toHtml (moduleString mod) - | (mod, visible) <- entries ]) - - initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" - --- --------------------------------------------------------------------------- --- Generate the HTML page for a module - -ppHtmlModule - :: FilePath -> String - -> SourceURLs -> WikiURLs - -> Maybe String -> Maybe String - -> HaddockModule -> IO () -ppHtmlModule odir doctitle - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url hmod = do - let - mod = hmod_mod hmod - mdl = moduleString mod - html = - header (documentCharacterEncoding +++ - thetitle (toHtml mdl) +++ - styleSheet +++ - (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++ - body << vanillaTable << ( - pageHeader mdl hmod doctitle - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url s15 - hmodToHtml maybe_source_url maybe_wiki_url hmod s15 - footer - ) - writeFile (pathJoin [odir, moduleHtmlFile mod]) (renderHtml html) - -hmodToHtml :: SourceURLs -> WikiURLs -> HaddockModule -> HtmlTable -hmodToHtml maybe_source_url maybe_wiki_url hmod - = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: bdy) - where - docMap = hmod_rn_doc_map hmod - - exports = numberSectionHeadings (hmod_rn_export_items hmod) - - has_doc (ExportDecl _ _ doc _) = isJust doc - has_doc (ExportNoDecl _ _ _) = False - has_doc (ExportModule _) = False - has_doc _ = True - - no_doc_at_all = not (any has_doc exports) - - contents = td << vanillaTable << ppModuleContents exports - - description - = case hmod_rn_doc hmod of - Nothing -> Html.emptyTable - Just doc -> (tda [theclass "section1"] << toHtml "Description") - docBox (docToHtml doc) - - -- omit the synopsis if there are no documentation annotations at all - synopsis - | no_doc_at_all = Html.emptyTable - | otherwise - = (tda [theclass "section1"] << toHtml "Synopsis") - s15 - (tda [theclass "body"] << vanillaTable << - abovesSep s8 (map (processExport True linksInfo docMap) - (filter forSummary exports)) - ) - - -- if the documentation doesn't begin with a section header, then - -- add one ("Documentation"). - maybe_doc_hdr - = case exports of - [] -> Html.emptyTable - ExportGroup _ _ _ : _ -> Html.emptyTable - _ -> tda [ theclass "section1" ] << toHtml "Documentation" - - bdy = map (processExport False linksInfo docMap) exports - linksInfo = (maybe_source_url, maybe_wiki_url, hmod) - -ppModuleContents :: [ExportItem DocName] -> HtmlTable -ppModuleContents exports - | length sections == 0 = Html.emptyTable - | otherwise = tda [theclass "section4"] << bold << toHtml "Contents" - td << dlist << concatHtml sections - where - (sections, _leftovers{-should be []-}) = process 0 exports - - process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName]) - process _ [] = ([], []) - process n items@(ExportGroup lev id0 doc : rest) - | lev <= n = ( [], items ) - | otherwise = ( html:secs, rest2 ) - where - html = (dterm << linkedAnchor id0 << docToHtml doc) - +++ mk_subsections ssecs - (ssecs, rest1) = process lev rest - (secs, rest2) = process n rest1 - process n (_ : rest) = process n rest - - mk_subsections [] = noHtml - mk_subsections ss = ddef << dlist << concatHtml ss - --- we need to assign a unique id to each section heading so we can hyperlink --- them from the contents: -numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName] -numberSectionHeadings exports = go 1 exports - where go :: Int -> [ExportItem DocName] -> [ExportItem DocName] - go _ [] = [] - go n (ExportGroup lev _ doc : es) - = ExportGroup lev (show n) doc : go (n+1) es - go n (other:es) - = other : go n es - -processExport :: Bool -> LinksInfo -> DocMap -> (ExportItem DocName) -> HtmlTable -processExport _ _ _ (ExportGroup lev id0 doc) - = ppDocGroup lev (namedAnchor id0 << docToHtml doc) -processExport summary links docMap (ExportDecl x decl doc insts) - = doDecl summary links x decl doc insts docMap -processExport summmary _ _ (ExportNoDecl _ y []) - = declBox (ppDocName y) -processExport summmary _ _ (ExportNoDecl _ y subs) - = declBox (ppDocName y <+> parenList (map ppDocName subs)) -processExport _ _ _ (ExportDoc doc) - = docBox (docToHtml doc) -processExport _ _ _ (ExportModule mod) - = declBox (toHtml "module" <+> ppModule mod "") - -forSummary :: (ExportItem DocName) -> Bool -forSummary (ExportGroup _ _ _) = False -forSummary (ExportDoc _) = False -forSummary _ = True - -ppDocGroup :: Int -> Html -> HtmlTable -ppDocGroup lev doc - | lev == 1 = tda [ theclass "section1" ] << doc - | lev == 2 = tda [ theclass "section2" ] << doc - | lev == 3 = tda [ theclass "section3" ] << doc - | otherwise = tda [ theclass "section4" ] << doc - -declWithDoc :: Bool -> LinksInfo -> SrcSpan -> Name -> Maybe (HsDoc DocName) -> Html -> HtmlTable -declWithDoc True _ _ _ _ html_decl = declBox html_decl -declWithDoc False links loc nm Nothing html_decl = topDeclBox links loc nm html_decl -declWithDoc False links loc nm (Just doc) html_decl = - topDeclBox links loc nm html_decl docBox (docToHtml doc) - -doDecl :: Bool -> LinksInfo -> Name -> LHsDecl DocName -> - Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> HtmlTable -doDecl summary links x (L loc d) mbDoc instances docMap = doDecl d - where - doDecl (TyClD d) = doTyClD d - doDecl (SigD s) = ppSig summary links loc mbDoc s - doDecl (ForD d) = ppFor summary links loc mbDoc d - - doTyClD d0@(TyData {}) = ppDataDecl summary links instances x loc mbDoc d0 - doTyClD d0@(TySynonym {}) = ppTySyn summary links loc mbDoc d0 - doTyClD d0@(ClassDecl {}) = ppClassDecl summary links instances x loc mbDoc docMap d0 - -ppSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> Sig DocName -> HtmlTable -ppSig summary links loc mbDoc (TypeSig lname ltype) - | summary || noArgDocs t = - declWithDoc summary links loc n mbDoc (ppTypeSig summary n t) - | otherwise = topDeclBox links loc n (ppBinder False n) - (tda [theclass "body"] << vanillaTable << ( - do_args dcolon t - (case mbDoc of - Just doc -> ndocBox (docToHtml doc) - Nothing -> Html.emptyTable) - )) - - where - t = unLoc ltype - NoLink n = unLoc lname - - noLArgDocs (L _ t) = noArgDocs t - noArgDocs (HsForAllTy _ _ _ t) = noLArgDocs t - noArgDocs (HsFunTy (L _ (HsDocTy _ _)) _) = False - noArgDocs (HsFunTy _ r) = noLArgDocs r - noArgDocs (HsDocTy _ _) = False - noArgDocs _ = True - - do_largs leader (L _ t) = do_args leader t - do_args :: Html -> (HsType DocName) -> HtmlTable - do_args leader (HsForAllTy Explicit tvs lctxt ltype) - = (argBox ( - leader <+> - hsep (keyword "forall" : ppTyVars tvs ++ [dot]) <+> - ppLContextNoArrow lctxt) - <-> rdocBox noHtml) - do_largs darrow ltype - do_args leader (HsForAllTy Implicit _ lctxt ltype) - = (argBox (leader <+> ppLContextNoArrow lctxt) - <-> rdocBox noHtml) - do_largs darrow ltype - do_args leader (HsFunTy (L _ (HsDocTy lt ldoc)) r) - = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc))) - do_largs arrow r - do_args leader (HsFunTy lt r) - = (argBox (leader <+> ppLType lt) <-> rdocBox noHtml) do_largs arrow r - do_args leader (HsDocTy lt ldoc) - = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc))) - do_args leader t - = argBox (leader <+> ppType t) <-> rdocBox (noHtml) - -ppTyVars tvs = map ppName (tyvarNames tvs) - -tyvarNames = map f - where f x = let NoLink n = hsTyVarName (unLoc x) in n - -ppFor summary links loc mbDoc (ForeignImport lname ltype _) - = ppSig summary links loc mbDoc (TypeSig lname ltype) -ppFor _ _ _ _ _ = error "ppFor" - --- we skip type patterns for now -ppTySyn summary links loc mbDoc (TySynonym lname ltyvars _ ltype) - = declWithDoc summary links loc n mbDoc ( - hsep ([keyword "type", ppBinder summary n] - ++ ppTyVars ltyvars) <+> equals <+> ppLType ltype) - where NoLink n = unLoc lname - -ppLType (L _ t) = ppType t - -ppTypeSig :: Bool -> Name -> (HsType DocName) -> Html -ppTypeSig summary nm ty = ppBinder summary nm <+> dcolon <+> ppType ty - --------------------------------------------------------------------------------- --- Contexts --------------------------------------------------------------------------------- - -ppLContext = ppContext . unLoc -ppLContextNoArrow = ppContextNoArrow . unLoc - -ppContextNoArrow :: HsContext DocName -> Html -ppContextNoArrow [] = empty -ppContextNoArrow cxt = pp_hs_context (map unLoc cxt) - -ppContextNoLocs :: [HsPred DocName] -> Html -ppContextNoLocs [] = empty -ppContextNoLocs cxt = pp_hs_context cxt <+> darrow - -ppContext :: HsContext DocName -> Html -ppContext cxt = ppContextNoLocs (map unLoc cxt) - -pp_hs_context [] = empty -pp_hs_context [p] = ppPred p -pp_hs_context cxt = parenList (map ppPred cxt) - -ppLPred = ppPred . unLoc - -ppPred (HsClassP n ts) = ppDocName n <+> hsep (map ppLType ts) --- TODO: find out what happened to the Dupable/Linear distinction -ppPred (HsIParam (IPName n) t) - = toHtml "?" +++ ppDocName n <+> dcolon <+> ppLType 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) - <+> ppFds fds - -ppFds fds = - if null fds then noHtml else - char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) - where - fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> toHtml "->" <+> - hsep (map ppDocName vars2) - -ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> DocMap -> HtmlTable -ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc docMap = - if null sigs && null ats - then (if summary then declBox else topDeclBox links loc nm) hdr - else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where") - - (tda [theclass "body"] << - vanillaTable << - aboves ([ ppAT summary at | L _ at <- ats ] ++ - [ ppSig summary links loc mbDoc sig - | L _ sig@(TypeSig (L _ (NoLink n)) ty) <- sigs, let mbDoc = Map.lookup n docMap ]) - ) - where - hdr = ppClassHdr summary lctxt nm tvs fds - NoLink nm = unLoc lname - - ppAT summary at = case at of - TyData {} -> topDeclBox links loc nm (ppDataHeader summary at) - _ -> error "associated type synonyms or type families not supported yet" - --- we skip ATs for now -ppClassDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key -> SrcSpan -> - Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName -> - HtmlTable -ppClassDecl summary links instances orig_c loc mbDoc docMap - decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ _ _) - | summary = ppShortClassDecl summary links decl loc docMap - | otherwise - = classheader - tda [theclass "body"] << vanillaTable << ( - classdoc methodsBit instancesBit - ) - where - classheader - | null lsigs = topDeclBox links loc nm hdr - | otherwise = topDeclBox links loc nm (hdr <+> keyword "where") - - NoLink nm = unLoc lname - ctxt = unLoc lctxt - - hdr = ppClassHdr summary lctxt nm ltyvars lfds - - classdoc = case mbDoc of - Nothing -> Html.emptyTable - Just d -> ndocBox (docToHtml d) - - methodsBit - | null lsigs = Html.emptyTable - | otherwise = - s8 methHdr - tda [theclass "body"] << vanillaTable << ( - abovesSep s8 [ ppSig summary links loc mbDoc sig - | L _ sig@(TypeSig n _) <- lsigs, - let mbDoc = Map.lookup (orig n) docMap ] - ) - - instId = collapseId nm - instancesBit - | null instances = Html.emptyTable - | otherwise - = s8 instHdr instId - tda [theclass "body"] << - collapsed thediv instId ( - spacedTable1 << ( - aboves (map (declBox . ppInstHead) instances) - )) - -ppInstHead :: InstHead DocName -> Html -ppInstHead ([], n, ts) = ppAsst n ts -ppInstHead (ctxt, n, ts) = ppContextNoLocs ctxt <+> ppAsst n ts - -ppAsst n ts = ppDocName n <+> hsep (map ppParendType ts) - --- ----------------------------------------------------------------------------- --- Data & newtype declarations - -orig (L _ (NoLink name)) = name -orig _ = error "orig" - --- TODO: print contexts -ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> - Maybe (HsDoc DocName) -> TyClDecl DocName -> Html -ppShortDataDecl summary links loc mbDoc dataDecl - - | [lcon] <- cons, ResTyH98 <- resTy = - ppDataHeader summary dataDecl - <+> equals <+> ppShortConstr summary (unLoc lcon) - - | [] <- cons = ppDataHeader summary dataDecl - - | otherwise = vanillaTable << ( - case resTy of - ResTyH98 -> dataHeader - tda [theclass "body"] << vanillaTable << ( - aboves (zipWith doConstr ('=':repeat '|') cons) - ) - ResTyGADT _ -> dataHeader - tda [theclass "body"] << vanillaTable << ( - aboves (map doGADTConstr cons) - ) - ) - - where - dataHeader = - (if summary then declBox else topDeclBox links loc name) - ((ppDataHeader summary dataDecl) <+> - case resTy of ResTyGADT _ -> keyword "where"; _ -> empty) - - doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con)) - doGADTConstr con = declBox (ppShortConstr summary (unLoc con)) - - name = orig (tcdLName dataDecl) - context = unLoc (tcdCtxt dataDecl) - newOrData = tcdND dataDecl - tyVars = tyvarNames (tcdTyVars dataDecl) - mbKSig = tcdKindSig dataDecl - cons = tcdCons dataDecl - resTy = (con_res . unLoc . head) cons - -ppDataDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key -> - SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> HtmlTable -ppDataDecl summary links instances x loc mbDoc dataDecl - - | summary = declWithDoc summary links loc name mbDoc - (ppShortDataDecl summary links loc mbDoc dataDecl) - - | otherwise = dataHeader - tda [theclass "body"] << vanillaTable << ( - datadoc - constrBit - instancesBit - ) - - where - name = orig (tcdLName dataDecl) - context = unLoc (tcdCtxt dataDecl) - newOrData = tcdND dataDecl - tyVars = tyvarNames (tcdTyVars dataDecl) - mbKSig = tcdKindSig dataDecl - cons = tcdCons dataDecl - resTy = (con_res . unLoc . head) cons - - dataHeader = - (if summary then declBox else topDeclBox links loc name) - ((ppDataHeader summary dataDecl) <+> whereBit) - - whereBit - | null cons = empty - | otherwise = case resTy of - ResTyGADT _ -> keyword "where" - _ -> empty - - constrTable - | any isRecCon cons = spacedTable5 - | otherwise = spacedTable1 - - datadoc = case mbDoc of - Just doc -> ndocBox (docToHtml doc) - Nothing -> Html.emptyTable - - constrBit - | null cons = Html.emptyTable - | otherwise = constrHdr ( - tda [theclass "body"] << constrTable << - aboves (map ppSideBySideConstr cons) - ) - - instId = collapseId name - - instancesBit - | null instances = Html.emptyTable - | otherwise - = instHdr instId - tda [theclass "body"] << - collapsed thediv instId ( - spacedTable1 << ( - aboves (map (declBox . ppInstHead) instances) - ) - ) - -isRecCon lcon = case con_details (unLoc lcon) of - RecCon _ -> True - _ -> False - -ppShortConstr :: Bool -> ConDecl DocName -> Html -ppShortConstr summary con = case con_res con of - - ResTyH98 -> case con_details con of - PrefixCon args -> header +++ hsep (ppBinder summary name : map ppLType args) - RecCon fields -> header +++ ppBinder summary name <+> - braces (vanillaTable << aboves (map (ppShortField summary) fields)) - InfixCon arg1 arg2 -> header +++ - hsep [ppLType arg1, ppBinder summary name, ppLType arg2] - - ResTyGADT resTy -> case con_details con of - PrefixCon args -> doGADTCon args resTy - RecCon _ -> error "GADT records not suported" - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy - - where - doGADTCon args resTy = ppBinder summary name <+> dcolon <+> hsep [ - ppForAll forall ltvs lcontext, - ppLType (foldr mkFunTy resTy args) ] - - header = ppConstrHdr forall tyVars context - name = orig (con_name con) - ltvs = con_qvars con - tyVars = tyvarNames ltvs - lcontext = con_cxt con - context = unLoc (con_cxt con) - forall = con_explicit con - mkFunTy a b = noLoc (HsFunTy a b) - -ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Html -ppConstrHdr forall tvs ctxt - = (if null tvs then noHtml else ppForall) - +++ - (if null ctxt then noHtml else ppContext ctxt <+> toHtml "=> ") - where - ppForall = case forall of - Explicit -> keyword "forall" <+> hsep (map ppName tvs) <+> toHtml ". " - Implicit -> empty - -ppSideBySideConstr :: LConDecl DocName -> HtmlTable -ppSideBySideConstr (L _ con) = case con_res con of - - ResTyH98 -> case con_details con of - - PrefixCon args -> - argBox (hsep ((header +++ ppBinder False name) : map ppLType args)) - <-> maybeRDocBox mbLDoc - - RecCon fields -> - argBox (header +++ ppBinder False name) <-> - maybeRDocBox mbLDoc - (tda [theclass "body"] << spacedTable1 << - aboves (map ppSideBySideField fields)) - - InfixCon arg1 arg2 -> - argBox (hsep [header+++ppLType arg1, ppBinder False name, ppLType arg2]) - <-> maybeRDocBox mbLDoc - - ResTyGADT resTy -> case con_details con of - PrefixCon args -> doGADTCon args resTy - RecCon _ -> error "GADT records not supported" - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy - - where - doGADTCon args resTy = argBox (ppBinder False name <+> dcolon <+> hsep [ - ppForAll forall ltvs (con_cxt con), - ppLType (foldr mkFunTy resTy args) ] - ) <-> maybeRDocBox mbLDoc - - - header = ppConstrHdr forall tyVars context - name = orig (con_name con) - ltvs = con_qvars con - tyVars = tyvarNames (con_qvars con) - context = unLoc (con_cxt con) - forall = con_explicit con - mbLDoc = con_doc con - mkFunTy a b = noLoc (HsFunTy a b) - -ppSideBySideField :: HsRecField DocName (LHsType DocName) -> HtmlTable -ppSideBySideField (HsRecField lname ltype mbLDoc) = - argBox (ppBinder False (orig lname) - <+> dcolon <+> ppLType ltype) <-> - maybeRDocBox mbLDoc - -{- -ppHsFullConstr :: HsConDecl -> Html -ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = - declWithDoc False doc ( - hsep ((ppHsConstrHdr tvs ctxt +++ - ppHsBinder False nm) : map ppHsBangType typeList) - ) -ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = - td << vanillaTable << ( - case doc of - Nothing -> aboves [hdr, fields_html] - Just _ -> aboves [hdr, constr_doc, fields_html] - ) - - where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) - - constr_doc - | isJust doc = docBox (docToHtml (fromJust doc)) - | otherwise = Html.emptyTable - - fields_html = - td << - table ! [width "100%", cellpadding 0, cellspacing 8] << ( - aboves (map ppFullField (concat (map expandField fields))) - ) --} - -ppShortField :: Bool -> HsRecField DocName (LHsType DocName)-> HtmlTable -ppShortField summary (HsRecField lname ltype mbLDoc) - = tda [theclass "recfield"] << ( - ppBinder summary (orig lname) - <+> dcolon <+> ppLType ltype - ) - -{- -ppFullField :: HsFieldDecl -> Html -ppFullField (HsFieldDecl [n] ty doc) - = declWithDoc False doc ( - ppHsBinder False n <+> dcolon <+> ppHsBangType ty - ) -ppFullField _ = error "ppFullField" - -expandField :: HsFieldDecl -> [HsFieldDecl] -expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] --} - --- | Print the LHS of a data/newtype declaration. --- Currently doesn't handle 'data instance' decls or kind signatures -ppDataHeader :: Bool -> TyClDecl DocName -> Html -ppDataHeader summary decl - | not (isDataDecl decl) = error "ppDataHeader: illegal argument" - | otherwise = - -- newtype or data - (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> - -- context - ppLContext (tcdCtxt decl) <+> - -- T a b c ..., or a :+: b - (if isConSym name - then ppName (tyvars!!0) <+> ppBinder summary name <+> ppName (tyvars!!1) - else ppBinder summary name <+> hsep (map ppName tyvars)) - where - tyvars = tyvarNames $ tcdTyVars decl - name = orig $ tcdLName decl - --- ---------------------------------------------------------------------------- --- Types and contexts - -ppKind k = toHtml $ showSDoc (ppr k) - -{- -ppForAll Implicit _ lctxt = ppCtxtPart lctxt -ppForAll Explicit ltvs lctxt = - hsep (keyword "forall" : ppTyVars ltvs ++ [dot]) <+> ppCtxtPart lctxt --} - -ppBang HsStrict = toHtml "!" -ppBang HsUnbox = toHtml "!!" - -tupleParens Boxed = parenList -tupleParens Unboxed = ubxParenList -{- -ppType :: HsType DocName -> Html -ppType t = case t of - t@(HsForAllTy expl ltvs lcontext ltype) -> ppForAllTy t <+> ppLType ltype - HsTyVar n -> ppDocName n - HsBangTy HsStrict lt -> toHtml "!" <+> ppLType lt - HsBangTy HsUnbox lt -> toHtml "!!" <+> ppLType lt - HsAppTy a b -> ppLType a <+> ppLType b - HsFunTy a b -> hsep [ppLType a, toHtml "->", ppLType b] - HsListTy t -> brackets $ ppLType t - HsPArrTy t -> toHtml "[:" +++ ppLType t +++ toHtml ":]" - HsTupleTy Boxed ts -> parenList $ map ppLType ts - HsTupleTy Unboxed ts -> ubxParenList $ map ppLType ts - HsOpTy a n b -> ppLType a <+> ppLDocName n <+> ppLType b - HsParTy t -> parens $ ppLType t - HsNumTy n -> toHtml (show n) - HsPredTy p -> ppPred p - HsKindSig t k -> hsep [ppLType t, dcolon, ppKind k] - HsSpliceTy _ -> error "ppType" - HsDocTy t _ -> ppLType t --} --------------------------------------------------------------------------------- --- Rendering of HsType --------------------------------------------------------------------------------- - -pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC -pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC - -- Used for LH arg of (->) -pREC_OP = (2 :: Int) -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = (3 :: Int) -- Used for arg of type applicn: - -- always parenthesise unless atomic - -maybeParen :: Int -- Precedence of context - -> Int -- Precedence of top-level operator - -> Html -> Html -- Wrap in parens if (ctxt >= op) -maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p - | otherwise = p - -ppType ty = ppr_mono_ty pREC_TOP (prepare ty) -ppParendType ty = ppr_mono_ty pREC_CON ty - --- Before printing a type --- (a) Remove outermost HsParTy parens --- (b) Drop top-level for-all type variables in user style --- since they are implicit in Haskell -prepare (HsParTy ty) = prepare (unLoc ty) -prepare ty = ty - -ppForAll exp tvs cxt - | show_forall = forall_part <+> ppLContext cxt - | otherwise = ppLContext cxt - where - show_forall = not (null tvs) && is_explicit - is_explicit = case exp of {Explicit -> True; Implicit -> False} - forall_part = hsep (keyword "forall" : ppTyVars tvs) +++ dot - -ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) - -ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty) - = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty] - --- gaw 2004 -ppr_mono_ty ctxt_prec (HsBangTy b ty) = ppBang b +++ ppLType ty -ppr_mono_ty ctxt_prec (HsTyVar name) = ppDocName name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2 -ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (map ppLType tys) -ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppKind kind) -ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) -ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) -ppr_mono_ty ctxt_prec (HsPredTy pred) = parens (ppPred pred) -ppr_mono_ty ctxt_prec (HsNumTy n) = toHtml (show n) -- generics only -ppr_mono_ty ctxt_prec (HsSpliceTy s) = error "ppr_mono_ty-haddock" - -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) - = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty] - -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) - = maybeParen ctxt_prec pREC_OP $ - ppr_mono_lty pREC_OP ty1 <+> ppLDocName op <+> ppr_mono_lty pREC_OP ty2 - -ppr_mono_ty ctxt_prec (HsParTy ty) - = parens (ppr_mono_lty pREC_TOP ty) - -ppr_mono_ty ctxt_prec (HsDocTy ty doc) - = ppLType ty - -ppr_fun_ty ctxt_prec ty1 ty2 - = let p1 = ppr_mono_lty pREC_FUN ty1 - p2 = ppr_mono_lty pREC_TOP ty2 - in - maybeParen ctxt_prec pREC_FUN $ - hsep [p1, arrow <+> p2] - --- ---------------------------------------------------------------------------- --- Names - -ppOccName :: OccName -> Html -ppOccName name = toHtml $ occNameString name - -ppRdrName :: RdrName -> Html -ppRdrName = ppOccName . rdrNameOcc - -ppLDocName (L _ d) = ppDocName d - -ppDocName :: DocName -> Html -ppDocName (Link name) = linkId (nameModule name) (Just name) << ppName name -ppDocName (NoLink name) = toHtml (getOccString name) - -linkTarget :: Name -> Html -linkTarget name = namedAnchor (anchorNameStr name) << toHtml "" - -ppName :: Name -> Html -ppName name = toHtml (getOccString name) - -ppBinder :: Bool -> Name -> Html --- The Bool indicates whether we are generating the summary, in which case --- the binder will be a link to the full definition. -ppBinder True nm = linkedAnchor (anchorNameStr nm) << ppBinder' nm -ppBinder False nm = linkTarget nm +++ bold << ppBinder' nm - -ppBinder' :: Name -> Html -ppBinder' name - | isVarSym name = parens $ toHtml (getOccString name) - | otherwise = toHtml (getOccString name) - -linkId :: Module -> Maybe Name -> Html -> Html -linkId mod mbName = anchor ! [href hr] - where - hr = case mbName of - Nothing -> moduleHtmlFile mod - Just name -> nameHtmlRef mod name - -ppModule :: Module -> String -> Html -ppModule mod ref = anchor ! [href ((moduleHtmlFile mod) ++ ref)] - << toHtml (moduleString mod) - --- ----------------------------------------------------------------------------- --- * Doc Markup - -parHtmlMarkup :: (a -> Html) -> DocMarkup a Html -parHtmlMarkup ppId = Markup { - markupParagraph = paragraph, - markupEmpty = toHtml "", - markupString = toHtml, - markupAppend = (+++), - markupIdentifier = tt . ppId . head, - markupModule = \m -> ppModule (mkModuleNoPkg m) "", - markupEmphasis = emphasize . toHtml, - markupMonospaced = tt . toHtml, - markupUnorderedList = ulist . concatHtml . map (li <<), - markupOrderedList = olist . concatHtml . map (li <<), - markupDefList = dlist . concatHtml . map markupDef, - markupCodeBlock = pre, - markupURL = \url -> anchor ! [href url] << toHtml url, - markupAName = \aname -> namedAnchor aname << toHtml "" - } - -markupDef (a,b) = dterm << a +++ ddef << b - -htmlMarkup = parHtmlMarkup ppDocName -htmlOrigMarkup = parHtmlMarkup ppName -htmlRdrMarkup = parHtmlMarkup ppRdrName - --- If the doc is a single paragraph, don't surround it with

    (this causes --- ugly extra whitespace with some browsers). -docToHtml :: GHC.HsDoc DocName -> Html -docToHtml doc = markup htmlMarkup (unParagraph (markup htmlCleanup doc)) - -origDocToHtml :: GHC.HsDoc GHC.Name -> Html -origDocToHtml doc = markup htmlOrigMarkup (unParagraph (markup htmlCleanup doc)) - -rdrDocToHtml doc = markup htmlRdrMarkup (unParagraph (markup htmlCleanup doc)) - --- If there is a single paragraph, then surrounding it with

    ..

    --- can add too much whitespace in some browsers (eg. IE). However if --- we have multiple paragraphs, then we want the extra whitespace to --- separate them. So we catch the single paragraph case and transform it --- here. -unParagraph (GHC.DocParagraph d) = d ---NO: This eliminates line breaks in the code block: (SDM, 6/5/2003) ---unParagraph (DocCodeBlock d) = (DocMonospaced d) -unParagraph doc = doc - -htmlCleanup :: DocMarkup a (GHC.HsDoc a) -htmlCleanup = idMarkup { - markupUnorderedList = GHC.DocUnorderedList . map unParagraph, - markupOrderedList = GHC.DocOrderedList . map unParagraph - } - --- ----------------------------------------------------------------------------- --- * Misc - -hsep :: [Html] -> Html -hsep [] = noHtml -hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls - -infixr 8 <+> -(<+>) :: Html -> Html -> Html -a <+> b = Html (getHtmlElements (toHtml a) ++ HtmlString " ": getHtmlElements (toHtml b)) - -keyword :: String -> Html -keyword s = thespan ! [theclass "keyword"] << toHtml s - -equals, comma :: Html -equals = char '=' -comma = char ',' - -char :: Char -> Html -char c = toHtml [c] - -empty :: Html -empty = noHtml - -parens, brackets, braces :: Html -> Html -parens h = char '(' +++ h +++ char ')' -brackets h = char '[' +++ h +++ char ']' -pabrackets h = toHtml "[:" +++ h +++ toHtml ":]" -braces h = char '{' +++ h +++ char '}' - -punctuate :: Html -> [Html] -> [Html] -punctuate _ [] = [] -punctuate h (d0:ds) = go d0 ds - where - go d [] = [d] - go d (e:es) = (d +++ h) : go e es - -abovesSep :: HtmlTable -> [HtmlTable] -> HtmlTable -abovesSep _ [] = Html.emptyTable -abovesSep h (d0:ds) = go d0 ds - where - go d [] = d - go d (e:es) = d h go e es - -parenList :: [Html] -> Html -parenList = parens . hsep . punctuate comma - -ubxParenList :: [Html] -> Html -ubxParenList = ubxparens . hsep . punctuate comma - -ubxparens :: Html -> Html -ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" - -{- -text :: Html -text = strAttr "TEXT" --} - --- a box for displaying code -declBox :: Html -> HtmlTable -declBox html = tda [theclass "decl"] << html - --- a box for top level documented names --- it adds a source and wiki link at the right hand side of the box -topDeclBox :: LinksInfo -> SrcSpan -> Name -> Html -> HtmlTable -topDeclBox ((_,_,Nothing), (_,_,Nothing), _) _ _ html = declBox html -topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url), hmod) - loc name html = - tda [theclass "topdecl"] << - ( table ! [theclass "declbar"] << - ((tda [theclass "declname"] << html) - <-> srcLink - <-> wikiLink) - ) - where srcLink = - case maybe_source_url of - Nothing -> Html.emptyTable - Just url -> tda [theclass "declbut"] << - let url' = spliceURL (Just fname) (Just mod) - (Just name) url - in anchor ! [href url'] << toHtml "Source" - wikiLink = - case maybe_wiki_url of - Nothing -> Html.emptyTable - Just url -> tda [theclass "declbut"] << - let url' = spliceURL (Just fname) (Just mod) - (Just name) url - in anchor ! [href url'] << toHtml "Comments" - - mod = hmod_mod hmod - fname = unpackFS (srcSpanFile loc) - --- a box for displaying an 'argument' (some code which has text to the --- right of it). Wrapping is not allowed in these boxes, whereas it is --- in a declBox. -argBox :: Html -> HtmlTable -argBox html = tda [theclass "arg"] << html - --- a box for displaying documentation, --- indented and with a little padding at the top -docBox :: Html -> HtmlTable -docBox html = tda [theclass "doc"] << html - --- a box for displaying documentation, not indented. -ndocBox :: Html -> HtmlTable -ndocBox html = tda [theclass "ndoc"] << html - --- a box for displaying documentation, padded on the left a little -rdocBox :: Html -> HtmlTable -rdocBox html = tda [theclass "rdoc"] << html - -maybeRDocBox :: Maybe (GHC.LHsDoc DocName) -> HtmlTable -maybeRDocBox Nothing = rdocBox (noHtml) -maybeRDocBox (Just ldoc) = rdocBox (docToHtml (unLoc ldoc)) - --- a box for the buttons at the top of the page -topButBox :: Html -> HtmlTable -topButBox html = tda [theclass "topbut"] << html - --- a vanilla table has width 100%, no border, no padding, no spacing --- a narrow table is the same but without width 100%. -vanillaTable, narrowTable :: Html -> Html -vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0] -vanillaTable2 = table ! [theclass "vanilla2", cellspacing 0, cellpadding 0] -narrowTable = table ! [theclass "narrow", cellspacing 0, cellpadding 0] - -spacedTable1, spacedTable5 :: Html -> Html -spacedTable1 = table ! [theclass "vanilla", cellspacing 1, cellpadding 0] -spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0] - -constrHdr, methHdr :: HtmlTable -constrHdr = tda [ theclass "section4" ] << toHtml "Constructors" -methHdr = tda [ theclass "section4" ] << toHtml "Methods" - -instHdr :: String -> HtmlTable -instHdr id = - tda [ theclass "section4" ] << (collapsebutton id +++ toHtml " Instances") - -dcolon, arrow, darrow :: Html -dcolon = toHtml "::" -arrow = toHtml "->" -darrow = toHtml "=>" -dot = toHtml "." - -s8, s15 :: HtmlTable -s8 = tda [ theclass "s8" ] << noHtml -s15 = tda [ theclass "s15" ] << noHtml - -namedAnchor :: String -> Html -> Html -namedAnchor n = anchor ! [name (escapeStr n)] - --- --- A section of HTML which is collapsible via a +/- button. --- - --- TODO: Currently the initial state is non-collapsed. Change the 'minusFile' --- below to a 'plusFile' and the 'display:block;' to a 'display:none;' when we --- use cookies from JavaScript to have a more persistent state. - -collapsebutton :: String -> Html -collapsebutton id = - image ! [ src minusFile, theclass "coll", onclick ("toggle(this,'" ++ id ++ "')"), alt "show/hide" ] - -collapsed :: (HTML a) => (Html -> Html) -> String -> a -> Html -collapsed fn id html = - fn ! [identifier id, thestyle "display:block;"] << html - --- A quote is a valid part of a Haskell identifier, but it would interfere with --- the ECMA script string delimiter used in collapsebutton above. -collapseId :: Name -> String -collapseId nm = "i:" ++ escapeStr (getOccString nm) - -linkedAnchor :: String -> Html -> Html -linkedAnchor frag = anchor ! [href hr] - where hr | null frag = "" - | otherwise = '#': escapeStr frag - -documentCharacterEncoding :: Html -documentCharacterEncoding = - meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"] - -styleSheet :: Html -styleSheet = - thelink ! [href cssFile, rel "stylesheet", thetype "text/css"] diff --git a/src/HaddockModuleTree.hs b/src/HaddockModuleTree.hs deleted file mode 100644 index e32cb960..00000000 --- a/src/HaddockModuleTree.hs +++ /dev/null @@ -1,38 +0,0 @@ -module HaddockModuleTree ( ModuleTree(..), mkModuleTree ) where - -import HaddockTypes ( DocName ) -import GHC ( HsDoc, Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageId ) -import PackageConfig ( packageIdString ) - -data ModuleTree = Node String Bool (Maybe String) (Maybe (HsDoc Name)) [ModuleTree] - -mkModuleTree :: Bool -> [(Module, Maybe (HsDoc Name))] -> [ModuleTree] -mkModuleTree showPkgs mods = - foldr fn [] [ (splitModule mod, modPkg mod, short) | (mod, short) <- mods ] - where - modPkg mod | showPkgs = Just (packageIdString (modulePackageId mod)) - | otherwise = Nothing - fn (mod,pkg,short) trees = addToTrees mod pkg short trees - -addToTrees :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree] -> [ModuleTree] -addToTrees [] pkg short ts = ts -addToTrees ss pkg short [] = mkSubTree ss pkg short -addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) - | s1 > s2 = t : addToTrees (s1:ss) pkg short ts - | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts - | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts - where - this_pkg = if null ss then pkg else node_pkg - this_short = if null ss then short else node_short - -mkSubTree :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree] -mkSubTree [] pkg short = [] -mkSubTree [s] pkg short = [Node s True pkg short []] -mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)] - -splitModule :: Module -> [String] -splitModule mod = split (moduleNameString (moduleName mod)) - where split mod0 = case break (== '.') mod0 of - (s1, '.':s2) -> s1 : split s2 - (s1, _) -> [s1] diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs deleted file mode 100644 index f5c5f99c..00000000 --- a/src/HaddockRename.hs +++ /dev/null @@ -1,320 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- - -module HaddockRename ( - runRnFM, -- the monad (instance of Monad) - renameDoc, renameMaybeDoc, renameExportItems, -) where - -import HaddockTypes - -import GHC -import BasicTypes -import SrcLoc -import Bag ( emptyBag ) - -import Data.Map ( Map ) -import qualified Data.Map as Map hiding ( Map ) -import Prelude hiding ( mapM ) -import Data.Traversable ( mapM ) - --- ----------------------------------------------------------------------------- --- Monad for renaming - --- The monad does two things for us: it passes around the environment for --- renaming, and it returns a list of names which couldn't be found in --- the environment. - -newtype GenRnM n a = - RnM { unRn :: (n -> (Bool, DocName)) -- name lookup function - -> (a,[n]) - } - -type RnM a = GenRnM Name a - -instance Monad (GenRnM n) where - (>>=) = thenRn - return = returnRn - -returnRn :: a -> GenRnM n a -returnRn a = RnM (\_ -> (a,[])) -thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b -m `thenRn` k = RnM (\lkp -> case unRn m lkp of - (a,out1) -> case unRn (k a) lkp of - (b,out2) -> (b,out1++out2)) - -getLookupRn :: RnM (Name -> (Bool, DocName)) -getLookupRn = RnM (\lkp -> (lkp,[])) -outRn :: Name -> RnM () -outRn name = RnM (\_ -> ((),[name])) - -lookupRn :: (DocName -> a) -> Name -> RnM a -lookupRn and_then name = do - lkp <- getLookupRn - case lkp name of - (False,maps_to) -> do outRn name; return (and_then maps_to) - (True, maps_to) -> return (and_then maps_to) - -runRnFM :: Map Name Name -> RnM a -> (a,[Name]) -runRnFM env rn = unRn rn lkp - where lkp n = case Map.lookup n env of - Nothing -> (False, NoLink n) - Just q -> (True, Link q) - -runRn :: (n -> (Bool,DocName)) -> GenRnM n a -> (a,[n]) -runRn lkp rn = unRn rn lkp - --- ----------------------------------------------------------------------------- --- Renaming - -keep n = NoLink n -keepL (L loc n) = L loc (NoLink n) - -rename = lookupRn id -renameL (L loc name) = return . L loc =<< rename name - -renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] -renameExportItems items = mapM renameExportItem items - -renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName)) -renameMaybeDoc mbDoc = mapM renameDoc mbDoc - -renameLDoc (L loc doc) = return . L loc =<< renameDoc doc - -renameDoc :: HsDoc Name -> RnM (HsDoc DocName) -renameDoc doc = case doc of - DocEmpty -> return DocEmpty - DocAppend a b -> do - a' <- renameDoc a - b' <- renameDoc b - return (DocAppend a' b') - DocString str -> return (DocString str) - DocParagraph doc -> do - doc' <- renameDoc doc - return (DocParagraph doc') - DocIdentifier ids -> do - lkp <- getLookupRn - case [ n | (True, n) <- map lkp ids ] of - ids'@(_:_) -> return (DocIdentifier ids') - [] -> return (DocIdentifier (map NoLink ids)) - DocModule str -> return (DocModule str) - DocEmphasis doc -> do - doc' <- renameDoc doc - return (DocEmphasis doc') - DocMonospaced doc -> do - doc' <- renameDoc doc - return (DocMonospaced doc') - DocUnorderedList docs -> do - docs' <- mapM renameDoc docs - return (DocUnorderedList docs') - DocOrderedList docs -> do - docs' <- mapM renameDoc docs - return (DocOrderedList docs') - DocDefList docs -> do - docs' <- mapM (\(a,b) -> do - a' <- renameDoc a - b' <- renameDoc b - return (a',b')) docs - return (DocDefList docs') - DocCodeBlock doc -> do - doc' <- renameDoc doc - return (DocCodeBlock doc') - DocURL str -> return (DocURL str) - DocAName str -> return (DocAName str) - -renameLPred (L loc p) = return . L loc =<< renamePred p - -renamePred :: HsPred Name -> RnM (HsPred DocName) -renamePred (HsClassP name types) = do - name' <- rename name - types' <- mapM renameLType types - return (HsClassP name' types') -renamePred (HsIParam (IPName name) t) = do - name' <- rename name - t' <- renameLType t - return (HsIParam (IPName name') t') - -renameLType (L loc t) = return . L loc =<< renameType t - -renameType t = case t of - HsForAllTy expl tyvars lcontext ltype -> do - tyvars' <- mapM renameLTyVarBndr tyvars - lcontext' <- renameLContext lcontext - ltype' <- renameLType ltype - return (HsForAllTy expl tyvars' lcontext' ltype') - - HsTyVar n -> return . HsTyVar =<< rename n - HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype - - HsAppTy a b -> do - a' <- renameLType a - b' <- renameLType b - return (HsAppTy a' b') - - HsFunTy a b -> do - a' <- renameLType a - b' <- renameLType b - return (HsFunTy a' b') - - HsListTy t -> return . HsListTy =<< renameLType t - HsPArrTy t -> return . HsPArrTy =<< renameLType t - - HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - - HsOpTy a (L loc op) b -> do - op' <- rename op - a' <- renameLType a - b' <- renameLType b - return (HsOpTy a' (L loc op') b') - - HsParTy t -> return . HsParTy =<< renameLType t - - HsNumTy n -> return (HsNumTy n) - - HsPredTy p -> return . HsPredTy =<< renamePred p - - HsKindSig t k -> do - t' <- renameLType t - return (HsKindSig t' k) - - HsDocTy t doc -> do - t' <- renameLType t - doc' <- renameLDoc doc - return (HsDocTy t' doc') - - _ -> error "renameType" - -renameLTyVarBndr (L loc tv) = do - name' <- rename (hsTyVarName tv) - return $ L loc (replaceTyVarName tv name') - -renameLContext (L loc context) = do - context' <- mapM renameLPred context - return (L loc context') - -renameInstHead :: InstHead Name -> RnM (InstHead DocName) -renameInstHead (preds, className, types) = do - preds' <- mapM renamePred preds - className' <- rename className - types' <- mapM renameType types - return (preds', className', types') - -renameLDecl (L loc d) = return . L loc =<< renameDecl d - -renameDecl d = case d of - TyClD d -> do - d' <- renameTyClD d - return (TyClD d') - SigD s -> do - s' <- renameSig s - return (SigD s') - ForD d -> do - d' <- renameForD d - return (ForD d') - _ -> error "renameDecl" - -renameTyClD d = case d of - ForeignType _ _ _ -> error "renameTyClD" -- I'm guessing these can't be exported - -- ForeignType name a b -> do - -- name' <- renameL name - -- return (ForeignType name' a b) - - TyData x lcontext lname ltyvars _ k cons _ -> do - lcontext' <- renameLContext lcontext - ltyvars' <- mapM renameLTyVarBndr ltyvars - cons' <- mapM renameLCon cons - -- I don't think we need the derivings, so we return Nothing - -- We skip the type patterns too. TODO: find out what they are :-) - return (TyData x lcontext' (keepL lname) ltyvars' Nothing k cons' Nothing) - - TySynonym lname ltyvars typat ltype -> do - ltyvars' <- mapM renameLTyVarBndr ltyvars - ltype' <- renameLType ltype - -- We skip type patterns here as well. - return (TySynonym (keepL lname) ltyvars' Nothing ltype') - - ClassDecl lcontext lname ltyvars lfundeps lsigs _ _ _ -> do - lcontext' <- renameLContext lcontext - ltyvars' <- mapM renameLTyVarBndr ltyvars - lfundeps' <- mapM renameLFunDep lfundeps - lsigs' <- mapM renameLSig lsigs - -- we don't need the default methods or the already collected doc entities - -- we skip the ATs for now. - return (ClassDecl lcontext' (keepL lname) ltyvars' lfundeps' lsigs' emptyBag [] []) - - where - renameLCon (L loc con) = return . L loc =<< renameCon con - renameCon (ConDecl lname expl ltyvars lcontext details restype mbldoc) = do - ltyvars' <- mapM renameLTyVarBndr ltyvars - lcontext' <- renameLContext lcontext - details' <- renameDetails details - restype' <- renameResType restype - mbldoc' <- mapM renameLDoc mbldoc - return (ConDecl (keepL lname) expl ltyvars' lcontext' details' restype' mbldoc') - - renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields - renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps - renameDetails (InfixCon a b) = do - a' <- renameLType a - b' <- renameLType b - return (InfixCon a' b') - - renameField (HsRecField id arg doc) = do - arg' <- renameLType arg - doc' <- mapM renameLDoc doc - return (HsRecField (keepL id) arg' doc') - - renameResType (ResTyH98) = return ResTyH98 - renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t - - renameLFunDep (L loc (xs, ys)) = return (L loc (map keep xs, map keep ys)) - - renameLSig (L loc sig) = return . L loc =<< renameSig sig - -renameSig sig = case sig of - TypeSig (L loc name) ltype -> do - ltype' <- renameLType ltype - return (TypeSig (L loc (keep name)) ltype') -{- SpecSig lname ltype x -> do - lname' <- renameL lname - ltype' <- renameLType ltype - return (SpecSig lname' ltype' x) - InlineSig lname x -> do - lname' <- renameL lname - return (InlineSig lname' x) - SpecInstSig t -> return . SpecInstSig =<< renameLType t - FixSig fsig -> return . FixSig =<< renameFixitySig fsig - where - renameFixitySig (FixitySig lname x) = do - lname' <- renameL lname - return (FixitySig lname' x) --} - -renameForD (ForeignImport lname ltype x) = do - ltype' <- renameLType ltype - return (ForeignImport (keepL lname) ltype' x) -renameForD (ForeignExport lname ltype x) = do - ltype' <- renameLType ltype - return (ForeignExport (keepL lname) ltype' x) - -renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) -renameExportItem item = case item of - ExportModule mod -> return (ExportModule mod) - ExportGroup lev id doc -> do - doc' <- renameDoc doc - return (ExportGroup lev id doc') - ExportDecl x decl doc instances -> do - decl' <- renameLDecl decl - doc' <- mapM renameDoc doc - instances' <- mapM renameInstHead instances - return (ExportDecl x decl' doc' instances') - ExportNoDecl x y subs -> do - y' <- lookupRn id y - subs' <- mapM (lookupRn id) subs - return (ExportNoDecl x y' subs') - ExportDoc doc -> do - doc' <- renameDoc doc - return (ExportDoc doc') diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs deleted file mode 100644 index bdc2d9cd..00000000 --- a/src/HaddockTypes.hs +++ /dev/null @@ -1,123 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- --- Ported to use the GHC API by David Waern 2006 --- - -module HaddockTypes where - -import GHC -import Outputable - -import Data.Map - -data DocOption - = OptHide -- ^ This module should not appear in the docs - | OptPrune - | OptIgnoreExports -- ^ Pretend everything is exported - | OptNotHome -- ^ Not the best place to get docs for things - -- exported by this module. - deriving (Eq, Show) - -data ExportItem name - = ExportDecl - Name -- ^ The original name - (LHsDecl name) -- ^ A declaration - (Maybe (HsDoc name)) -- ^ Maybe a doc comment - [InstHead name] -- ^ Instances relevant to this declaration - - | ExportNoDecl -- ^ An exported entity for which we have no - -- documentation (perhaps because it resides in - -- another package) - Name -- ^ The original name - name -- ^ Where to link to - [name] -- ^ Subordinate names - - | ExportGroup -- ^ A section heading - Int -- ^ section level (1, 2, 3, ... ) - String -- ^ Section "id" (for hyperlinks) - (HsDoc name) -- ^ Section heading text - - | ExportDoc -- ^ Some documentation - (HsDoc name) - - | ExportModule -- ^ A cross-reference to another module - Module - -type InstHead name = ([HsPred name], name, [HsType name]) -type ModuleMap = Map Module HaddockModule -type DocMap = Map Name (HsDoc DocName) -type DocEnv = Map Name Name - -data DocName = Link Name | NoLink Name - -instance Outputable DocName where - ppr (Link n) = ppr n - ppr (NoLink n) = ppr n - -data HaddockModule = HM { - - -- | A value to identify the module - hmod_mod :: Module, - - -- | The original filename for this module - hmod_orig_filename :: FilePath, - - -- | Textual information about the module - hmod_info :: HaddockModInfo Name, - - -- | The documentation header for this module - hmod_doc :: Maybe (HsDoc Name), - - -- | The renamed documentation header for this module - hmod_rn_doc :: Maybe (HsDoc DocName), - - -- | The Haddock options for this module (prune, ignore-exports, etc) - hmod_options :: [DocOption], - - hmod_exported_decl_map :: Map Name (LHsDecl Name), - hmod_doc_map :: Map Name (HsDoc Name), - hmod_rn_doc_map :: Map Name (HsDoc DocName), - - hmod_export_items :: [ExportItem Name], - hmod_rn_export_items :: [ExportItem DocName], - - -- | All the names that are defined in this module - hmod_locals :: [Name], - - -- | All the names that are exported by this module - hmod_exports :: [Name], - - -- | All the visible names exported by this module - -- For a name to be visible, it has to: - -- - be exported normally, and not via a full module re-exportation. - -- - have a declaration in this module or any of it's imports, with the - -- exception that it can't be from another package. - -- Basically, a visible name is a name that will show up in the documentation - -- for this module. - hmod_visible_exports :: [Name], - - hmod_sub_map :: Map Name [Name], - - -- | The instances exported by this module - hmod_instances :: [Instance] -} - -data DocMarkup id a = Markup { - markupEmpty :: a, - markupString :: String -> a, - markupParagraph :: a -> a, - markupAppend :: a -> a -> a, - markupIdentifier :: [id] -> a, - markupModule :: String -> a, - markupEmphasis :: a -> a, - markupMonospaced :: a -> a, - markupUnorderedList :: [a] -> a, - markupOrderedList :: [a] -> a, - markupDefList :: [(a,a)] -> a, - markupCodeBlock :: a -> a, - markupURL :: String -> a, - markupAName :: String -> a -} diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs deleted file mode 100644 index 1d962c82..00000000 --- a/src/HaddockUtil.hs +++ /dev/null @@ -1,340 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) The University of Glasgow 2001-2002 --- (c) Simon Marlow 2003 --- - -module HaddockUtil ( - - -- * Misc utilities - restrictTo, - toDescription, - - -- * Filename utilities - basename, dirname, splitFilename3, - moduleHtmlFile, nameHtmlRef, - contentsHtmlFile, indexHtmlFile, subIndexHtmlFile, pathJoin, - anchorNameStr, - cssFile, iconFile, jsFile, plusFile, minusFile, - - -- * Miscellaneous utilities - getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, - isConSym, isVarSym, nameOccString, moduleString, mkModuleNoPkg, - - -- * HTML cross reference mapping - html_xrefs_ref, - - -- * HsDoc markup - markup, - idMarkup, - - -- * Binary extras --- FormatVersion, mkFormatVersion - ) where - -import HaddockTypes -import Data.Map ( Map ) -import qualified Data.Map as Map hiding ( Map ) - -import GHC -import SrcLoc -import Name -import OccName -import Binary -import Module -import PackageConfig ( stringToPackageId ) - -import Control.Monad ( liftM, MonadPlus(..) ) -import Data.Char -import Data.IORef ( IORef, newIORef, readIORef ) -import Data.List ( intersect, isSuffixOf, intersperse ) -import Data.Maybe ( maybeToList, fromMaybe, isJust, fromJust ) -import Data.Word ( Word8 ) -import Data.Bits ( testBit ) -import Network.URI -import System.Environment ( getProgName ) -import System.Exit ( exitWith, ExitCode(..) ) -import System.IO ( hPutStr, stderr ) -import System.IO.Unsafe ( unsafePerformIO ) - --- ----------------------------------------------------------------------------- --- Some Utilities - --- | extract a module's short description. -toDescription :: HaddockModule -> Maybe (HsDoc Name) -toDescription = hmi_description . hmod_info - --- --------------------------------------------------------------------------- --- Making abstract declarations - -restrictTo :: [Name] -> (LHsDecl Name) -> (LHsDecl Name) -restrictTo names (L loc decl) = L loc $ case decl of - TyClD d | isDataDecl d && tcdND d == DataType -> - TyClD (d { tcdCons = restrictCons names (tcdCons d) }) - TyClD d | isDataDecl d && tcdND d == NewType -> - case restrictCons names (tcdCons d) of - [] -> TyClD (d { tcdND = DataType, tcdCons = [] }) - [con] -> TyClD (d { tcdCons = [con] }) - TyClD d | isClassDecl d -> - TyClD (d { tcdSigs = restrictDecls names (tcdSigs d) }) - _ -> decl - -restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] -restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] - where - keep d | unLoc (con_name d) `elem` names = - case con_details d of - PrefixCon _ -> Just d - RecCon fields - | all field_avail fields -> Just d - | otherwise -> Just (d { con_details = PrefixCon (field_types fields) }) - -- if we have *all* the field names available, then - -- keep the record declaration. Otherwise degrade to - -- a constructor declaration. This isn't quite right, but - -- it's the best we can do. - InfixCon _ _ -> Just d - where - field_avail (HsRecField n _ _) = (unLoc n) `elem` names - field_types flds = [ ty | HsRecField n ty _ <- flds] - - keep d | otherwise = Nothing - -restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] -restrictDecls names decls = filter keep decls - where keep d = fromJust (sigName d) `elem` names - -- has to have a name, since it's a class method type signature - --- ----------------------------------------------------------------------------- --- Filename mangling functions stolen from s main/DriverUtil.lhs. - -type Suffix = String - -splitFilename :: String -> (String,Suffix) -splitFilename f = split_longest_prefix f (=='.') - -basename :: String -> String -basename f = base where (_dir, base, _suff) = splitFilename3 f - -dirname :: String -> String -dirname f = dir where (dir, _base, _suff) = splitFilename3 f - --- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext") -splitFilename3 :: String -> (String,String,Suffix) -splitFilename3 str - = let (dir, rest) = split_longest_prefix str isPathSeparator - (name, ext) = splitFilename rest - real_dir | null dir = "." - | otherwise = dir - in (real_dir, name, ext) - -split_longest_prefix :: String -> (Char -> Bool) -> (String,String) -split_longest_prefix s pred0 - = case pre0 of - [] -> ([], reverse suf) - (_:pre) -> (reverse pre, reverse suf) - where (suf,pre0) = break pred0 (reverse s) - -pathSeparator :: Char -#ifdef __WIN32__ -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif - -isPathSeparator :: Char -> Bool -isPathSeparator ch = -#ifdef mingw32_TARGET_OS - ch == '/' || ch == '\\' -#else - ch == '/' -#endif - -moduleHtmlFile :: Module -> FilePath -moduleHtmlFile mdl = - case Map.lookup mdl html_xrefs of - Nothing -> mdl' ++ ".html" - Just fp0 -> pathJoin [fp0, mdl' ++ ".html"] - where - mdl' = map (\c -> if c == '.' then '-' else c) - (moduleNameString (moduleName mdl)) - -nameHtmlRef :: Module -> Name -> String -nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr str) - -contentsHtmlFile, indexHtmlFile :: String -contentsHtmlFile = "index.html" -indexHtmlFile = "doc-index.html" - -subIndexHtmlFile :: Char -> String -subIndexHtmlFile a = "doc-index-" ++ b ++ ".html" - where b | isAlpha a = [a] - | otherwise = show (ord a) - -anchorNameStr :: Name -> String -anchorNameStr name | isValOcc occName = "v:" ++ getOccString name - | otherwise = "t:" ++ getOccString name - where occName = nameOccName name - -pathJoin :: [FilePath] -> FilePath -pathJoin = foldr join [] - where join :: FilePath -> FilePath -> FilePath - join path1 "" = path1 - join "" path2 = path2 - join path1 path2 - | isPathSeparator (last path1) = path1++path2 - | otherwise = path1++pathSeparator:path2 - --- ----------------------------------------------------------------------------- --- Files we need to copy from our $libdir - -cssFile, iconFile, jsFile, plusFile,minusFile :: String -cssFile = "haddock.css" -iconFile = "haskell_icon.gif" -jsFile = "haddock.js" -plusFile = "plus.gif" -minusFile = "minus.gif" - ------------------------------------------------------------------------------ --- misc. - -getProgramName :: IO String -getProgramName = liftM (`withoutSuffix` ".bin") getProgName - where str `withoutSuffix` suff - | suff `isSuffixOf` str = take (length str - length suff) str - | otherwise = str - -bye :: String -> IO a -bye s = putStr s >> exitWith ExitSuccess - -die :: String -> IO a -die s = hPutStr stderr s >> exitWith (ExitFailure 1) - -dieMsg :: String -> IO a -dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) - -noDieMsg :: String -> IO () -noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s) - -mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)] -mapSnd _ [] = [] -mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs - -mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) -mapMaybeM _ Nothing = return Nothing -mapMaybeM f (Just a) = f a >>= return . Just - -escapeStr :: String -> String -#if __GLASGOW_HASKELL__ < 603 -escapeStr = flip escapeString unreserved -#else -escapeStr = escapeURIString isUnreserved -#endif - --- there should be a better way to check this using the GHC API -isConSym n = head (nameOccString n) == ':' -isVarSym n = fstChar /= '_' && not (isConSym n) && (not . isLetter) fstChar - where fstChar = head (nameOccString n) - -nameOccString = occNameString . nameOccName - -moduleString :: Module -> String -moduleString = moduleNameString . moduleName - -mkModuleNoPkg :: String -> Module -mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str) - ------------------------------------------------------------------------------ --- HTML cross references - --- For each module, we need to know where its HTML documentation lives --- so that we can point hyperlinks to it. It is extremely --- inconvenient to plumb this information to all the places that need --- it (basically every function in HaddockHtml), and furthermore the --- mapping is constant for any single run of Haddock. So for the time --- being I'm going to use a write-once global variable. - -{-# NOINLINE html_xrefs_ref #-} -html_xrefs_ref :: IORef (Map Module FilePath) -html_xrefs_ref = unsafePerformIO (newIORef (error "module_map")) - -{-# NOINLINE html_xrefs #-} -html_xrefs :: Map Module FilePath -html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) - ------------------------------------------------------------------------------ --- put here temporarily - -markup :: DocMarkup id a -> HsDoc id -> a -markup m DocEmpty = markupEmpty m -markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) -markup m (DocString s) = markupString m s -markup m (DocParagraph d) = markupParagraph m (markup m d) -markup m (DocIdentifier ids) = markupIdentifier m ids -markup m (DocModule mod0) = markupModule m mod0 -markup m (DocEmphasis d) = markupEmphasis m (markup m d) -markup m (DocMonospaced d) = markupMonospaced m (markup m d) -markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) -markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) -markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) -markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocURL url) = markupURL m url -markup m (DocAName ref) = markupAName m ref - -markupPair :: DocMarkup id a -> (HsDoc id, HsDoc id) -> (a, a) -markupPair m (a,b) = (markup m a, markup m b) - --- | The identity markup -idMarkup :: DocMarkup a (HsDoc a) -idMarkup = Markup { - markupEmpty = DocEmpty, - markupString = DocString, - markupParagraph = DocParagraph, - markupAppend = DocAppend, - markupIdentifier = DocIdentifier, - markupModule = DocModule, - markupEmphasis = DocEmphasis, - markupMonospaced = DocMonospaced, - markupUnorderedList = DocUnorderedList, - markupOrderedList = DocOrderedList, - markupDefList = DocDefList, - markupCodeBlock = DocCodeBlock, - markupURL = DocURL, - markupAName = DocAName - } - --- | Since marking up is just a matter of mapping 'Doc' into some --- other type, we can \'rename\' documentation by marking up 'Doc' into --- the same thing, modifying only the identifiers embedded in it. - -mapIdent f = idMarkup { markupIdentifier = f } - ------------------------------------------------------------------------------ --- put here temporarily - -newtype FormatVersion = FormatVersion Int deriving (Eq,Ord) - -nullFormatVersion :: FormatVersion -nullFormatVersion = mkFormatVersion 0 - -mkFormatVersion :: Int -> FormatVersion -mkFormatVersion i = FormatVersion i - -instance Binary FormatVersion where - put_ bh (FormatVersion i) = - case compare i 0 of - EQ -> return () - GT -> put_ bh (-i) - LT -> error ( - "Binary.hs: negative FormatVersion " ++ show i - ++ " is not allowed") - get bh = - do - (w8 :: Word8) <- get bh - if testBit w8 7 - then - do - i <- get bh - return (FormatVersion (-i)) - else - return nullFormatVersion diff --git a/src/HaddockVersion.hs b/src/HaddockVersion.hs deleted file mode 100644 index ad2bfa3f..00000000 --- a/src/HaddockVersion.hs +++ /dev/null @@ -1,18 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- - -module HaddockVersion ( - projectName, projectVersion, projectUrl - ) where - -import Paths_haddock_ghc ( version ) -import Data.Version ( showVersion ) - -projectName, projectUrl :: String -projectName = "Haddock-GHC" -projectUrl = "http://www.haskell.org/haddock/" - -projectVersion = showVersion version diff --git a/src/Html.hs b/src/Html.hs deleted file mode 100644 index 530df829..00000000 --- a/src/Html.hs +++ /dev/null @@ -1,1037 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Text.Html --- Copyright : (c) Andy Gill, and the Oregon Graduate Institute of --- Science and Technology, 1999-2001 --- License : BSD-style (see the file libraries/core/LICENSE) --- --- Maintainer : Andy Gill --- Stability : experimental --- Portability : portable --- --- An Html combinator library --- ------------------------------------------------------------------------------ - -module Html ( - module Html, - ) where - -import qualified BlockTable as BT - -import Data.Char (isAscii, ord) -import Numeric (showHex) - -infixr 2 +++ -- combining Html -infixr 7 << -- nesting Html -infixl 8 ! -- adding optional arguments - - --- A important property of Html is that all strings inside the --- structure are already in Html friendly format. --- For example, use of >,etc. - -data HtmlElement -{- - - ..just..plain..normal..text... but using © and &amb;, etc. - -} - = HtmlString String -{- - - ..content.. - -} - | HtmlTag { -- tag with internal markup - markupTag :: String, - markupAttrs :: [HtmlAttr], - markupContent :: Html - } - -{- These are the index-value pairs. - - The empty string is a synonym for tags with no arguments. - - (not strictly HTML, but anyway). - -} - - -data HtmlAttr = HtmlAttr String String - - -newtype Html = Html { getHtmlElements :: [HtmlElement] } - --- Read MARKUP as the class of things that can be validly rendered --- inside MARKUP tag brackets. So this can be one or more Html's, --- or a String, for example. - -class HTML a where - toHtml :: a -> Html - toHtmlFromList :: [a] -> Html - - toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs]) - -instance HTML Html where - toHtml a = a - -instance HTML Char where - toHtml a = toHtml [a] - toHtmlFromList [] = Html [] - toHtmlFromList str = Html [HtmlString (stringToHtmlString str)] - -instance (HTML a) => HTML [a] where - toHtml xs = toHtmlFromList xs - -class ADDATTRS a where - (!) :: a -> [HtmlAttr] -> a - -instance (ADDATTRS b) => ADDATTRS (a -> b) where - (!) fn attr = \ arg -> fn arg ! attr - -instance ADDATTRS Html where - (!) (Html htmls) attr = Html (map addAttrs htmls) - where - addAttrs html = - case html of - HtmlTag { markupAttrs = markupAttrs0 - , markupTag = markupTag0 - , markupContent = markupContent0 } -> - HtmlTag { markupAttrs = markupAttrs0 ++ attr - , markupTag = markupTag0 - , markupContent = markupContent0 } - _ -> html - - -(<<) :: (HTML a) => (Html -> b) -> a -> b -fn << arg = fn (toHtml arg) - - -concatHtml :: (HTML a) => [a] -> Html -concatHtml as = Html (concat (map (getHtmlElements.toHtml) as)) - -(+++) :: (HTML a,HTML b) => a -> b -> Html -a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b)) - -noHtml :: Html -noHtml = Html [] - - -isNoHtml :: Html -> Bool -isNoHtml (Html xs) = null xs - - -tag :: String -> Html -> Html -tag str htmls = - Html [ HtmlTag { markupTag = str, - markupAttrs = [], - markupContent = htmls } - ] - -itag :: String -> Html -itag str = tag str noHtml - -emptyAttr :: String -> HtmlAttr -emptyAttr s = HtmlAttr s "" - -intAttr :: String -> Int -> HtmlAttr -intAttr s i = HtmlAttr s (show i) - -strAttr :: String -> String -> HtmlAttr -strAttr s t = HtmlAttr s t - - -{- -foldHtml :: (String -> [HtmlAttr] -> [a] -> a) - -> (String -> a) - -> Html - -> a -foldHtml f g (HtmlTag str attr fmls) - = f str attr (map (foldHtml f g) fmls) -foldHtml f g (HtmlString str) - = g str - --} --- Processing Strings into Html friendly things. --- This converts a String to a Html String. -stringToHtmlString :: String -> String -stringToHtmlString = concatMap fixChar - where - fixChar '<' = "<" - fixChar '>' = ">" - fixChar '&' = "&" - fixChar '"' = """ - fixChar c - | isAscii c = [c] - | otherwise = "&#x" ++ showHex (ord c) ";" - --- --------------------------------------------------------------------------- --- Classes - -instance Show Html where - showsPrec _ html = showString (prettyHtml html) - showList htmls = showString (concat (map show htmls)) - -instance Show HtmlAttr where - showsPrec _ (HtmlAttr str val) = - showString str . - showString "=" . - shows val - - --- --------------------------------------------------------------------------- --- Data types - -type URL = String - --- --------------------------------------------------------------------------- --- Basic primitives - --- This is not processed for special chars. --- use stringToHtml or lineToHtml instead, for user strings, --- because they understand special chars, like '<'. - -primHtml :: String -> Html -primHtml x = Html [HtmlString x] - --- --------------------------------------------------------------------------- --- Basic Combinators - -stringToHtml :: String -> Html -stringToHtml = primHtml . stringToHtmlString - --- This converts a string, but keeps spaces as non-line-breakable - -lineToHtml :: String -> Html -lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString - where - htmlizeChar2 ' ' = " " - htmlizeChar2 c = [c] - --- --------------------------------------------------------------------------- --- Html Constructors - --- (automatically generated) - -address :: Html -> Html -anchor :: Html -> Html -applet :: Html -> Html -area :: Html -basefont :: Html -big :: Html -> Html -blockquote :: Html -> Html -body :: Html -> Html -bold :: Html -> Html -br :: Html -button :: Html -> Html -caption :: Html -> Html -center :: Html -> Html -cite :: Html -> Html -ddef :: Html -> Html -define :: Html -> Html -dlist :: Html -> Html -dterm :: Html -> Html -emphasize :: Html -> Html -fieldset :: Html -> Html -font :: Html -> Html -form :: Html -> Html -frame :: Html -> Html -frameset :: Html -> Html -h1 :: Html -> Html -h2 :: Html -> Html -h3 :: Html -> Html -h4 :: Html -> Html -h5 :: Html -> Html -h6 :: Html -> Html -header :: Html -> Html -hr :: Html -image :: Html -input :: Html -italics :: Html -> Html -keyboard :: Html -> Html -legend :: Html -> Html -li :: Html -> Html -meta :: Html -noframes :: Html -> Html -olist :: Html -> Html -option :: Html -> Html -paragraph :: Html -> Html -param :: Html -pre :: Html -> Html -sample :: Html -> Html -script :: Html -> Html -select :: Html -> Html -small :: Html -> Html -strong :: Html -> Html -style :: Html -> Html -sub :: Html -> Html -sup :: Html -> Html -table :: Html -> Html -thetd :: Html -> Html -textarea :: Html -> Html -th :: Html -> Html -thebase :: Html -thecode :: Html -> Html -thediv :: Html -> Html -thehtml :: Html -> Html -thelink :: Html -themap :: Html -> Html -thespan :: Html -> Html -thetitle :: Html -> Html -tr :: Html -> Html -tt :: Html -> Html -ulist :: Html -> Html -underline :: Html -> Html -variable :: Html -> Html - -address = tag "ADDRESS" -anchor = tag "A" -applet = tag "APPLET" -area = itag "AREA" -basefont = itag "BASEFONT" -big = tag "BIG" -blockquote = tag "BLOCKQUOTE" -body = tag "BODY" -bold = tag "B" -br = itag "BR" -button = tag "BUTTON" -caption = tag "CAPTION" -center = tag "CENTER" -cite = tag "CITE" -ddef = tag "DD" -define = tag "DFN" -dlist = tag "DL" -dterm = tag "DT" -emphasize = tag "EM" -fieldset = tag "FIELDSET" -font = tag "FONT" -form = tag "FORM" -frame = tag "FRAME" -frameset = tag "FRAMESET" -h1 = tag "H1" -h2 = tag "H2" -h3 = tag "H3" -h4 = tag "H4" -h5 = tag "H5" -h6 = tag "H6" -header = tag "HEAD" -hr = itag "HR" -image = itag "IMG" -input = itag "INPUT" -italics = tag "I" -keyboard = tag "KBD" -legend = tag "LEGEND" -li = tag "LI" -meta = itag "META" -noframes = tag "NOFRAMES" -olist = tag "OL" -option = tag "OPTION" -paragraph = tag "P" -param = itag "PARAM" -pre = tag "PRE" -sample = tag "SAMP" -script = tag "SCRIPT" -select = tag "SELECT" -small = tag "SMALL" -strong = tag "STRONG" -style = tag "STYLE" -sub = tag "SUB" -sup = tag "SUP" -table = tag "TABLE" -thetd = tag "TD" -textarea = tag "TEXTAREA" -th = tag "TH" -thebase = itag "BASE" -thecode = tag "CODE" -thediv = tag "DIV" -thehtml = tag "HTML" -thelink = itag "LINK" -themap = tag "MAP" -thespan = tag "SPAN" -thetitle = tag "TITLE" -tr = tag "TR" -tt = tag "TT" -ulist = tag "UL" -underline = tag "U" -variable = tag "VAR" - --- --------------------------------------------------------------------------- --- Html Attributes - --- (automatically generated) - -action :: String -> HtmlAttr -align :: String -> HtmlAttr -alink :: String -> HtmlAttr -alt :: String -> HtmlAttr -altcode :: String -> HtmlAttr -archive :: String -> HtmlAttr -background :: String -> HtmlAttr -base :: String -> HtmlAttr -bgcolor :: String -> HtmlAttr -border :: Int -> HtmlAttr -bordercolor :: String -> HtmlAttr -cellpadding :: Int -> HtmlAttr -cellspacing :: Int -> HtmlAttr -checked :: HtmlAttr -clear :: String -> HtmlAttr -code :: String -> HtmlAttr -codebase :: String -> HtmlAttr -color :: String -> HtmlAttr -cols :: String -> HtmlAttr -colspan :: Int -> HtmlAttr -compact :: HtmlAttr -content :: String -> HtmlAttr -coords :: String -> HtmlAttr -enctype :: String -> HtmlAttr -face :: String -> HtmlAttr -frameborder :: Int -> HtmlAttr -height :: Int -> HtmlAttr -href :: String -> HtmlAttr -hspace :: Int -> HtmlAttr -httpequiv :: String -> HtmlAttr -identifier :: String -> HtmlAttr -ismap :: HtmlAttr -lang :: String -> HtmlAttr -link :: String -> HtmlAttr -marginheight :: Int -> HtmlAttr -marginwidth :: Int -> HtmlAttr -maxlength :: Int -> HtmlAttr -method :: String -> HtmlAttr -multiple :: HtmlAttr -name :: String -> HtmlAttr -nohref :: HtmlAttr -noresize :: HtmlAttr -noshade :: HtmlAttr -nowrap :: HtmlAttr -onclick :: String -> HtmlAttr -rel :: String -> HtmlAttr -rev :: String -> HtmlAttr -rows :: String -> HtmlAttr -rowspan :: Int -> HtmlAttr -rules :: String -> HtmlAttr -scrolling :: String -> HtmlAttr -selected :: HtmlAttr -shape :: String -> HtmlAttr -size :: String -> HtmlAttr -src :: String -> HtmlAttr -start :: Int -> HtmlAttr -target :: String -> HtmlAttr -text :: String -> HtmlAttr -theclass :: String -> HtmlAttr -thestyle :: String -> HtmlAttr -thetype :: String -> HtmlAttr -title :: String -> HtmlAttr -usemap :: String -> HtmlAttr -valign :: String -> HtmlAttr -value :: String -> HtmlAttr -version :: String -> HtmlAttr -vlink :: String -> HtmlAttr -vspace :: Int -> HtmlAttr -width :: String -> HtmlAttr - -action = strAttr "ACTION" -align = strAttr "ALIGN" -alink = strAttr "ALINK" -alt = strAttr "ALT" -altcode = strAttr "ALTCODE" -archive = strAttr "ARCHIVE" -background = strAttr "BACKGROUND" -base = strAttr "BASE" -bgcolor = strAttr "BGCOLOR" -border = intAttr "BORDER" -bordercolor = strAttr "BORDERCOLOR" -cellpadding = intAttr "CELLPADDING" -cellspacing = intAttr "CELLSPACING" -checked = emptyAttr "CHECKED" -clear = strAttr "CLEAR" -code = strAttr "CODE" -codebase = strAttr "CODEBASE" -color = strAttr "COLOR" -cols = strAttr "COLS" -colspan = intAttr "COLSPAN" -compact = emptyAttr "COMPACT" -content = strAttr "CONTENT" -coords = strAttr "COORDS" -enctype = strAttr "ENCTYPE" -face = strAttr "FACE" -frameborder = intAttr "FRAMEBORDER" -height = intAttr "HEIGHT" -href = strAttr "HREF" -hspace = intAttr "HSPACE" -httpequiv = strAttr "HTTP-EQUIV" -identifier = strAttr "ID" -ismap = emptyAttr "ISMAP" -lang = strAttr "LANG" -link = strAttr "LINK" -marginheight = intAttr "MARGINHEIGHT" -marginwidth = intAttr "MARGINWIDTH" -maxlength = intAttr "MAXLENGTH" -method = strAttr "METHOD" -multiple = emptyAttr "MULTIPLE" -name = strAttr "NAME" -nohref = emptyAttr "NOHREF" -noresize = emptyAttr "NORESIZE" -noshade = emptyAttr "NOSHADE" -nowrap = emptyAttr "NOWRAP" -onclick = strAttr "ONCLICK" -rel = strAttr "REL" -rev = strAttr "REV" -rows = strAttr "ROWS" -rowspan = intAttr "ROWSPAN" -rules = strAttr "RULES" -scrolling = strAttr "SCROLLING" -selected = emptyAttr "SELECTED" -shape = strAttr "SHAPE" -size = strAttr "SIZE" -src = strAttr "SRC" -start = intAttr "START" -target = strAttr "TARGET" -text = strAttr "TEXT" -theclass = strAttr "CLASS" -thestyle = strAttr "STYLE" -thetype = strAttr "TYPE" -title = strAttr "TITLE" -usemap = strAttr "USEMAP" -valign = strAttr "VALIGN" -value = strAttr "VALUE" -version = strAttr "VERSION" -vlink = strAttr "VLINK" -vspace = intAttr "VSPACE" -width = strAttr "WIDTH" - --- --------------------------------------------------------------------------- --- Html Constructors - --- (automatically generated) - -validHtmlTags :: [String] -validHtmlTags = [ - "ADDRESS", - "A", - "APPLET", - "BIG", - "BLOCKQUOTE", - "BODY", - "B", - "CAPTION", - "CENTER", - "CITE", - "DD", - "DFN", - "DL", - "DT", - "EM", - "FIELDSET", - "FONT", - "FORM", - "FRAME", - "FRAMESET", - "H1", - "H2", - "H3", - "H4", - "H5", - "H6", - "HEAD", - "I", - "KBD", - "LEGEND", - "LI", - "NOFRAMES", - "OL", - "OPTION", - "P", - "PRE", - "SAMP", - "SELECT", - "SMALL", - "STRONG", - "STYLE", - "SUB", - "SUP", - "TABLE", - "TD", - "TEXTAREA", - "TH", - "CODE", - "DIV", - "HTML", - "LINK", - "MAP", - "TITLE", - "TR", - "TT", - "UL", - "U", - "VAR"] - -validHtmlITags :: [String] -validHtmlITags = [ - "AREA", - "BASEFONT", - "BR", - "HR", - "IMG", - "INPUT", - "LINK", - "META", - "PARAM", - "BASE"] - -validHtmlAttrs :: [String] -validHtmlAttrs = [ - "ACTION", - "ALIGN", - "ALINK", - "ALT", - "ALTCODE", - "ARCHIVE", - "BACKGROUND", - "BASE", - "BGCOLOR", - "BORDER", - "BORDERCOLOR", - "CELLPADDING", - "CELLSPACING", - "CHECKED", - "CLEAR", - "CODE", - "CODEBASE", - "COLOR", - "COLS", - "COLSPAN", - "COMPACT", - "CONTENT", - "COORDS", - "ENCTYPE", - "FACE", - "FRAMEBORDER", - "HEIGHT", - "HREF", - "HSPACE", - "HTTP-EQUIV", - "ID", - "ISMAP", - "LANG", - "LINK", - "MARGINHEIGHT", - "MARGINWIDTH", - "MAXLENGTH", - "METHOD", - "MULTIPLE", - "NAME", - "NOHREF", - "NORESIZE", - "NOSHADE", - "NOWRAP", - "REL", - "REV", - "ROWS", - "ROWSPAN", - "RULES", - "SCROLLING", - "SELECTED", - "SHAPE", - "SIZE", - "SRC", - "START", - "TARGET", - "TEXT", - "CLASS", - "STYLE", - "TYPE", - "TITLE", - "USEMAP", - "VALIGN", - "VALUE", - "VERSION", - "VLINK", - "VSPACE", - "WIDTH"] - --- --------------------------------------------------------------------------- --- Html colors - -aqua :: String -black :: String -blue :: String -fuchsia :: String -gray :: String -green :: String -lime :: String -maroon :: String -navy :: String -olive :: String -purple :: String -red :: String -silver :: String -teal :: String -yellow :: String -white :: String - -aqua = "aqua" -black = "black" -blue = "blue" -fuchsia = "fuchsia" -gray = "gray" -green = "green" -lime = "lime" -maroon = "maroon" -navy = "navy" -olive = "olive" -purple = "purple" -red = "red" -silver = "silver" -teal = "teal" -yellow = "yellow" -white = "white" - --- --------------------------------------------------------------------------- --- Basic Combinators - -linesToHtml :: [String] -> Html - -linesToHtml [] = noHtml -linesToHtml (x:[]) = lineToHtml x -linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs - - --- --------------------------------------------------------------------------- --- Html abbriviations - -primHtmlChar :: String -> Html -copyright :: Html -spaceHtml :: Html -bullet :: Html -p :: Html -> Html - -primHtmlChar = \ x -> primHtml ("&" ++ x ++ ";") -copyright = primHtmlChar "copy" -spaceHtml = primHtmlChar "nbsp" -bullet = primHtmlChar "#149" - -p = paragraph - --- --------------------------------------------------------------------------- --- Html tables - -cell :: Html -> HtmlTable -cell h = let - cellFn x y = h ! (add x colspan $ add y rowspan $ []) - add 1 _ rest = rest - add n fn rest = fn n : rest - r = BT.single cellFn - in - mkHtmlTable r - --- We internally represent the Cell inside a Table with an --- object of the type --- \pre{ --- Int -> Int -> Html --- } --- When we render it later, we find out how many columns --- or rows this cell will span over, and can --- include the correct colspan/rowspan command. - -newtype HtmlTable - = HtmlTable (BT.BlockTable (Int -> Int -> Html)) - -td :: Html -> HtmlTable -td = cell . thetd - -tda :: [HtmlAttr] -> Html -> HtmlTable -tda as = cell . (thetd ! as) - -above, beside :: HtmlTable -> HtmlTable -> HtmlTable -above a b = combine BT.above a b -beside a b = combine BT.beside a b - -infixr 3 -- combining table cells -infixr 4 <-> -- combining table cells -(), (<->) :: HtmlTable -> HtmlTable -> HtmlTable -() = above -(<->) = beside - -emptyTable :: HtmlTable -emptyTable = HtmlTable BT.empty - -aboves, besides :: [HtmlTable] -> HtmlTable -aboves = foldr above emptyTable -besides = foldr beside emptyTable - -mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable -mkHtmlTable r = HtmlTable r - -combine :: (BT.BlockTable (Int -> Int -> Html) - -> BT.BlockTable (Int -> Int -> Html) - -> BT.BlockTable (Int -> Int -> Html)) - -> HtmlTable -> HtmlTable -> HtmlTable -combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b) - --- renderTable takes the HtmlTable, and renders it back into --- and Html object. - -renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html -renderTable theTable - = concatHtml - [tr << [theCell x y | (theCell,(x,y)) <- theRow ] - | theRow <- BT.getMatrix theTable] - -instance HTML HtmlTable where - toHtml (HtmlTable tab) = renderTable tab - -instance Show HtmlTable where - showsPrec _ (HtmlTable tab) = shows (renderTable tab) - - --- If you can't be bothered with the above, then you --- can build simple tables with simpleTable. --- Just provide the attributes for the whole table, --- attributes for the cells (same for every cell), --- and a list of lists of cell contents, --- and this function will build the table for you. --- It does presume that all the lists are non-empty, --- and there is at least one list. --- --- Different length lists means that the last cell --- gets padded. If you want more power, then --- use the system above, or build tables explicitly. - -simpleTable :: HTML a => [HtmlAttr] -> [HtmlAttr] -> [[a]] -> Html -simpleTable attr cellAttr lst - = table ! attr - << (aboves - . map (besides . map (cell . (thetd ! cellAttr) . toHtml)) - ) lst - - --- --------------------------------------------------------------------------- --- Tree Displaying Combinators - --- The basic idea is you render your structure in the form --- of this tree, and then use treeHtml to turn it into a Html --- object with the structure explicit. - -data HtmlTree - = HtmlLeaf Html - | HtmlNode Html [HtmlTree] Html - -treeHtml :: [String] -> HtmlTree -> Html -treeHtml colors h = table ! [ - border 0, - cellpadding 0, - cellspacing 2] << treeHtml' colors h - where - manycolors = scanr (:) [] - - treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable - treeHtmls c ts = aboves (zipWith treeHtml' c ts) - - treeHtml' :: [String] -> HtmlTree -> HtmlTable - treeHtml' (_:_) (HtmlLeaf leaf) = cell - (thetd ! [width "100%"] - << bold - << leaf) - treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) = - if null ts && isNoHtml hclose - then - hd - else if null ts - then - hd bar `beside` (cell . (thetd ! [bgcolor c2]) << spaceHtml) - tl - else - hd (bar `beside` treeHtmls morecolors ts) - tl - where - -- This stops a column of colors being the same - -- color as the immeduately outside nesting bar. - morecolors = filter ((/= c).head) (manycolors cs) - bar = cell (thetd ! [bgcolor c,width "10"] << spaceHtml) - hd = cell (thetd ! [bgcolor c] << hopen) - tl = cell (thetd ! [bgcolor c] << hclose) - treeHtml' _ _ = error "The imposible happens" - -instance HTML HtmlTree where - toHtml x = treeHtml treeColors x - --- type "length treeColors" to see how many colors are here. -treeColors :: [String] -treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors - - --- --------------------------------------------------------------------------- --- Html Debugging Combinators - --- This uses the above tree rendering function, and displays the --- Html as a tree structure, allowing debugging of what is --- actually getting produced. - -debugHtml :: (HTML a) => a -> Html -debugHtml obj = table ! [border 0] << ( - cell (th ! [bgcolor "#008888"] - << underline - << "Debugging Output") - td << (toHtml (debug' (toHtml obj))) - ) - where - - debug' :: Html -> [HtmlTree] - debug' (Html markups) = map debug markups - - debug :: HtmlElement -> HtmlTree - debug (HtmlString str) = HtmlLeaf (spaceHtml +++ - linesToHtml (lines str)) - debug (HtmlTag { - markupTag = markupTag0, - markupContent = markupContent0, - markupAttrs = markupAttrs0 - }) = - case markupContent0 of - Html [] -> HtmlNode hd [] noHtml - Html xs -> HtmlNode hd (map debug xs) tl - where - args = if null markupAttrs0 - then "" - else " " ++ unwords (map show markupAttrs0) - hd = font ! [size "1"] << ("<" ++ markupTag0 ++ args ++ ">") - tl = font ! [size "1"] << ("") - --- --------------------------------------------------------------------------- --- Hotlink datatype - -data HotLink = HotLink { - hotLinkURL :: URL, - hotLinkContents :: [Html], - hotLinkAttributes :: [HtmlAttr] - } deriving Show - -instance HTML HotLink where - toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl) - << hotLinkContents hl - -hotlink :: URL -> [Html] -> HotLink -hotlink url h = HotLink { - hotLinkURL = url, - hotLinkContents = h, - hotLinkAttributes = [] } - - --- --------------------------------------------------------------------------- --- More Combinators - --- (Abridged from Erik Meijer's Original Html library) - -ordList :: (HTML a) => [a] -> Html -ordList items = olist << map (li <<) items - -unordList :: (HTML a) => [a] -> Html -unordList items = ulist << map (li <<) items - -defList :: (HTML a,HTML b) => [(a,b)] -> Html -defList items - = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ] - - -widget :: String -> String -> [HtmlAttr] -> Html -widget w n markupAttrs0 = input ! ([thetype w,name n] ++ markupAttrs0) - -checkbox :: String -> String -> Html -hidden :: String -> String -> Html -radio :: String -> String -> Html -reset :: String -> String -> Html -submit :: String -> String -> Html -password :: String -> Html -textfield :: String -> Html -afile :: String -> Html -clickmap :: String -> Html - -checkbox n v = widget "CHECKBOX" n [value v] -hidden n v = widget "HIDDEN" n [value v] -radio n v = widget "RADIO" n [value v] -reset n v = widget "RESET" n [value v] -submit n v = widget "SUBMIT" n [value v] -password n = widget "PASSWORD" n [] -textfield n = widget "TEXT" n [] -afile n = widget "FILE" n [] -clickmap n = widget "IMAGE" n [] - -menu :: String -> [Html] -> Html -menu n choices - = select ! [name n] << [ option << p << choice | choice <- choices ] - -gui :: String -> Html -> Html -gui act = form ! [action act,method "POST"] - --- --------------------------------------------------------------------------- --- Html Rendering - --- Uses the append trick to optimize appending. --- The output is quite messy, because space matters in --- HTML, so we must not generate needless spaces. - -renderHtml :: (HTML html) => html -> String -renderHtml theHtml = - renderMessage ++ - foldr (.) id (map unprettyHtml - (getHtmlElements (tag "HTML" << theHtml))) "\n" - -renderMessage :: String -renderMessage = - "\n" ++ - "\n" - -unprettyHtml :: HtmlElement -> ShowS -unprettyHtml (HtmlString str) = (++) str -unprettyHtml (HtmlTag - { markupTag = name0, - markupContent = html, - markupAttrs = markupAttrs0 }) - = if isNoHtml html && elem name0 validHtmlITags - then renderTag True name0 markupAttrs0 0 - else (renderTag True name0 markupAttrs0 0 - . foldr (.) id (map unprettyHtml (getHtmlElements html)) - . renderTag False name0 [] 0) - --- Local Utilities -prettyHtml :: (HTML html) => html -> String -prettyHtml theHtml = - unlines - $ concat - $ map prettyHtml' - $ getHtmlElements - $ toHtml theHtml - -prettyHtml' :: HtmlElement -> [String] -prettyHtml' (HtmlString str) = [str] -prettyHtml' (HtmlTag - { markupTag = name0, - markupContent = html, - markupAttrs = markupAttrs0 }) - = if isNoHtml html && elem name0 validHtmlITags - then - [rmNL (renderTag True name0 markupAttrs0 0 "")] - else - [rmNL (renderTag True name0 markupAttrs0 0 "")] ++ - shift (concat (map prettyHtml' (getHtmlElements html))) ++ - [rmNL (renderTag False name0 [] 0 "")] - where - shift = map (\x -> " " ++ x) - -rmNL :: [Char] -> [Char] -rmNL = filter (/= '\n') - --- This prints the Tags The lack of spaces in intentunal, because Html is --- actually space dependant. - -renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS -renderTag x name0 markupAttrs0 n r - = open ++ name0 ++ rest markupAttrs0 ++ ">" ++ r - where - open = if x then "<" else " String - showPair (HtmlAttr tag0 val) - = tag0 ++ "=\"" ++ val ++ "\"" - diff --git a/src/Main.hs b/src/Main.hs index 11b2a646..2f7e4bf0 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -8,15 +8,15 @@ module Main (main) where -import HaddockHtml -import HaddockHoogle -import HaddockRename -import HaddockTypes -import HaddockUtil -import HaddockVersion +import Haddock.Html +import Haddock.Hoogle +import Haddock.Rename +import Haddock.Types +import Haddock.Utils +import Haddock.Version import Haddock.InterfaceFile import Haddock.Exception -import GHCUtils +import Haddock.Utils.GHC import Paths_haddock_ghc ( getDataDir ) import Prelude hiding ( catch ) -- cgit v1.2.3