diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/HaddockDB.hs | 170 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 331 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 1221 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 690 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 885 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 143 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 235 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 171 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Themes.hs | 209 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Types.hs | 37 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 218 |
11 files changed, 4310 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Backends/HaddockDB.hs b/haddock-api/src/Haddock/Backends/HaddockDB.hs new file mode 100644 index 00000000..1c248bfb --- /dev/null +++ b/haddock-api/src/Haddock/Backends/HaddockDB.hs @@ -0,0 +1,170 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.HaddockDB +-- Copyright : (c) Simon Marlow 2003 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.HaddockDB (ppDocBook) where + +{- +import HaddockTypes +import HaddockUtil +import HsSyn2 + +import Text.PrettyPrint +-} + +----------------------------------------------------------------------------- +-- Printing the results in DocBook format + +ppDocBook :: a +ppDocBook = error "not working" +{- +ppDocBook :: FilePath -> [(Module, Interface)] -> String +ppDocBook odir mods = render (ppIfaces mods) + +ppIfaces mods + = text "<!DOCTYPE BOOK PUBLIC \"-//OASIS//DTD DocBook V3.1//EN\" [" + $$ text "]>" + $$ text "<book>" + $$ text "<bookinfo>" + $$ text "<author><othername>HaskellDoc version 0.0</othername></author>" + $$ text "</bookinfo>" + $$ text "<article>" + $$ vcat (map do_mod mods) + $$ text "</article></book>" + where + do_mod (Module mod, iface) + = text "<sect1 id=\"sec-" <> text mod <> text "\">" + $$ text "<title><literal>" + <> text mod + <> text "</literal></title>" + $$ text "<indexterm><primary><literal>" + <> text mod + <> text "</literal></primary></indexterm>" + $$ text "<variablelist>" + $$ vcat (map (do_export mod) (eltsFM (iface_decls iface))) + $$ text "</variablelist>" + $$ text "</sect1>" + + do_export mod decl | (nm:_) <- declBinders decl + = text "<varlistentry id=" <> ppLinkId mod nm <> char '>' + $$ text "<term><literal>" + <> do_decl decl + <> text "</literal></term>" + $$ text "<listitem>" + $$ text "<para>" + $$ text "</para>" + $$ text "</listitem>" + $$ text "</varlistentry>" + 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 "<link linkend=" <> ppLinkId mod str <> char '>' + <> ppHsName str + <> text "</link>" + +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/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs new file mode 100644 index 00000000..628e1cd0 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -0,0 +1,331 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Hoogle +-- Copyright : (c) Neil Mitchell 2006-2008 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Write out Hoogle compatible documentation +-- http://www.haskell.org/hoogle/ +----------------------------------------------------------------------------- +module Haddock.Backends.Hoogle ( + ppHoogle + ) where + + +import Haddock.GhcUtils +import Haddock.Types +import Haddock.Utils hiding (out) +import GHC +import Outputable + +import Data.Char +import Data.List +import Data.Maybe +import System.FilePath +import System.IO + +prefix :: [String] +prefix = ["-- Hoogle documentation, generated by Haddock" + ,"-- See Hoogle, http://www.haskell.org/hoogle/" + ,""] + + +ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () +ppHoogle dflags package version synopsis prologue ifaces odir = do + let filename = package ++ ".txt" + contents = prefix ++ + docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ + ["@package " ++ package] ++ + ["@version " ++ version | version /= ""] ++ + concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i] + h <- openFile (odir </> filename) WriteMode + hSetEncoding h utf8 + hPutStr h (unlines contents) + hClose h + +ppModule :: DynFlags -> Interface -> [String] +ppModule dflags iface = + "" : ppDocumentation dflags (ifaceDoc iface) ++ + ["module " ++ moduleString (ifaceMod iface)] ++ + concatMap (ppExport dflags) (ifaceExportItems iface) ++ + concatMap (ppInstance dflags) (ifaceInstances iface) + + +--------------------------------------------------------------------- +-- Utility functions + +dropHsDocTy :: HsType a -> HsType a +dropHsDocTy = f + where + g (L src x) = L src (f x) + f (HsForAllTy a b c d) = HsForAllTy a b c (g d) + f (HsBangTy a b) = HsBangTy a (g b) + f (HsAppTy a b) = HsAppTy (g a) (g b) + f (HsFunTy a b) = HsFunTy (g a) (g b) + f (HsListTy a) = HsListTy (g a) + f (HsPArrTy a) = HsPArrTy (g a) + f (HsTupleTy a b) = HsTupleTy a (map g b) + f (HsOpTy a b c) = HsOpTy (g a) b (g c) + f (HsParTy a) = HsParTy (g a) + f (HsKindSig a b) = HsKindSig (g a) b + f (HsDocTy a _) = f $ unL a + f x = x + +outHsType :: OutputableBndr a => DynFlags -> HsType a -> String +outHsType dflags = out dflags . dropHsDocTy + + +makeExplicit :: HsType a -> HsType a +makeExplicit (HsForAllTy _ a b c) = HsForAllTy Explicit a b c +makeExplicit x = x + +makeExplicitL :: LHsType a -> LHsType a +makeExplicitL (L src x) = L src (makeExplicit x) + + +dropComment :: String -> String +dropComment (' ':'-':'-':' ':_) = [] +dropComment (x:xs) = x : dropComment xs +dropComment [] = [] + + +out :: Outputable a => DynFlags -> a -> String +out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr + where + f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs + f (x:xs) = x : f xs + f [] = [] + + +operator :: String -> String +operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" +operator x = x + + +--------------------------------------------------------------------- +-- How to print each export + +ppExport :: DynFlags -> ExportItem Name -> [String] +ppExport dflags ExportDecl { expItemDecl = L _ decl + , expItemMbDoc = (dc, _) + , expItemSubDocs = subdocs + } = ppDocumentation dflags dc ++ f decl + where + f (TyClD d@DataDecl{}) = ppData dflags d subdocs + f (TyClD d@SynDecl{}) = ppSynonym dflags d + f (TyClD d@ClassDecl{}) = ppClass dflags d + f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ + f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ + f (SigD sig) = ppSig dflags sig + f _ = [] +ppExport _ _ = [] + + +ppSig :: DynFlags -> Sig Name -> [String] +ppSig dflags (TypeSig names sig) + = [operator prettyNames ++ " :: " ++ outHsType dflags typ] + where + prettyNames = intercalate ", " $ map (out dflags) names + typ = case unL sig of + HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c + x -> x +ppSig _ _ = [] + + +-- note: does not yet output documentation for class methods +ppClass :: DynFlags -> TyClDecl Name -> [String] +ppClass dflags x = out dflags x{tcdSigs=[]} : + concatMap (ppSig dflags . addContext . unL) (tcdSigs x) + where + addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig) + addContext (MinimalSig sig) = MinimalSig sig + addContext _ = error "expected TypeSig" + + f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d + f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t) + + context = nlHsTyConApp (tcdName x) + (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) + + +ppInstance :: DynFlags -> ClsInst -> [String] +ppInstance dflags x = [dropComment $ out dflags x] + + +ppSynonym :: DynFlags -> TyClDecl Name -> [String] +ppSynonym dflags x = [out dflags x] + +ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs + = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} : + concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn) + where + + -- GHC gives out "data Bar =", we want to delete the equals + -- also writes data : a b, when we want data (:) a b + showData d = unwords $ map f $ if last xs == "=" then init xs else xs + where + xs = words $ out dflags d + nam = out dflags $ tyClDeclLName d + f w = if w == nam then operator nam else w +ppData _ _ _ = panic "ppData" + +-- | for constructors, and named-fields... +lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String] +lookupCon dflags subdocs (L _ name) = case lookup name subdocs of + Just (d, _) -> ppDocumentation dflags d + _ -> [] + +ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] +ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con) + ++ f (con_details con) + where + f (PrefixCon args) = [typeSig name $ args ++ [resType]] + f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] + f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat + [lookupCon dflags subdocs (cd_fld_name r) ++ + [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]] + | r <- recs] + + funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) + apps = foldl1 (\x y -> reL $ HsAppTy x y) + + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) + name = out dflags $ unL $ con_name con + + resType = case con_res con of + ResTyH98 -> apps $ map (reL . HsTyVar) $ + (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] + ResTyGADT x -> x + + +--------------------------------------------------------------------- +-- DOCUMENTATION + +ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String] +ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w + + +doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String] +doc dflags = docWith dflags "" + + +docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String] +docWith _ [] Nothing = [] +docWith dflags header d + = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $ + [header | header /= ""] ++ ["" | header /= "" && isJust d] ++ + maybe [] (showTags . markup (markupTag dflags)) d + + +data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String + deriving Show + +type Tags = [Tag] + +box :: (a -> b) -> a -> [b] +box f x = [f x] + +str :: String -> [Tag] +str a = [Str a] + +-- want things like paragraph, pre etc to be handled by blank lines in the source document +-- and things like \n and \t converted away +-- much like blogger in HTML mode +-- everything else wants to be included as tags, neatly nested for some (ul,li,ol) +-- or inlne for others (a,i,tt) +-- entities (&,>,<) should always be appropriately escaped + +markupTag :: Outputable o => DynFlags -> DocMarkup o [Tag] +markupTag dflags = Markup { + markupParagraph = box TagP, + markupEmpty = str "", + markupString = str, + markupAppend = (++), + markupIdentifier = box (TagInline "a") . str . out dflags, + markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd, + markupModule = box (TagInline "a") . str, + markupWarning = box (TagInline "i"), + markupEmphasis = box (TagInline "i"), + markupBold = box (TagInline "b"), + markupMonospaced = box (TagInline "tt"), + markupPic = const $ str " ", + markupUnorderedList = box (TagL 'u'), + markupOrderedList = box (TagL 'o'), + markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), + markupCodeBlock = box TagPre, + markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel), + markupAName = const $ str "", + markupProperty = box TagPre . str, + markupExample = box TagPre . str . unlines . map exampleToString, + markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h + } + + +showTags :: [Tag] -> [String] +showTags = intercalate [""] . map showBlock + + +showBlock :: Tag -> [String] +showBlock (TagP xs) = showInline xs +showBlock (TagL t xs) = ['<':t:"l>"] ++ mid ++ ['<':'/':t:"l>"] + where mid = concatMap (showInline . box (TagInline "li")) xs +showBlock (TagPre xs) = ["<pre>"] ++ showPre xs ++ ["</pre>"] +showBlock x = showInline [x] + + +asInline :: Tag -> Tags +asInline (TagP xs) = xs +asInline (TagPre xs) = [TagInline "pre" xs] +asInline (TagL t xs) = [TagInline (t:"l") $ map (TagInline "li") xs] +asInline x = [x] + + +showInline :: [Tag] -> [String] +showInline = unwordsWrap 70 . words . concatMap f + where + fs = concatMap f + f (Str x) = escape x + f (TagInline s xs) = "<"++s++">" ++ (if s == "li" then trim else id) (fs xs) ++ "</"++s++">" + f x = fs $ asInline x + + trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse + + +showPre :: [Tag] -> [String] +showPre = trimFront . trimLines . lines . concatMap f + where + trimLines = dropWhile null . reverse . dropWhile null . reverse + trimFront xs = map (drop i) xs + where + ns = [length a | x <- xs, let (a,b) = span isSpace x, b /= ""] + i = if null ns then 0 else minimum ns + + fs = concatMap f + f (Str x) = escape x + f (TagInline s xs) = "<"++s++">" ++ fs xs ++ "</"++s++">" + f x = fs $ asInline x + + +unwordsWrap :: Int -> [String] -> [String] +unwordsWrap n = f n [] + where + f _ s [] = [g s | s /= []] + f i s (x:xs) | nx > i = g s : f (n - nx - 1) [x] xs + | otherwise = f (i - nx - 1) (x:s) xs + where nx = length x + + g = unwords . reverse + + +escape :: String -> String +escape = concatMap f + where + f '<' = "<" + f '>' = ">" + f '&' = "&" + f x = [x] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs new file mode 100644 index 00000000..7b72c030 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -0,0 +1,1221 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.LaTeX +-- Copyright : (c) Simon Marlow 2010, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.LaTeX ( + ppLaTeX +) where + + +import Haddock.Types +import Haddock.Utils +import Haddock.GhcUtils +import Pretty hiding (Doc, quote) +import qualified Pretty + +import GHC +import OccName +import Name ( nameOccName ) +import RdrName ( rdrNameOcc ) +import FastString ( unpackFS, unpackLitString, zString ) + +import qualified Data.Map as Map +import System.Directory +import System.FilePath +import Data.Char +import Control.Monad +import Data.Maybe +import Data.List + +import Haddock.Doc (combineDocumentation) + +-- import Debug.Trace + +{- SAMPLE OUTPUT + +\haddockmoduleheading{\texttt{Data.List}} +\hrulefill +{\haddockverb\begin{verbatim} +module Data.List ( + (++), head, last, tail, init, null, length, map, reverse, + ) where\end{verbatim}} +\hrulefill + +\section{Basic functions} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +head\ ::\ {\char 91}a{\char 93}\ ->\ a +\end{tabular}]\haddockbegindoc +Extract the first element of a list, which must be non-empty. +\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +last\ ::\ {\char 91}a{\char 93}\ ->\ a +\end{tabular}]\haddockbegindoc +Extract the last element of a list, which must be finite and non-empty. +\par + +\end{haddockdesc} +-} + + +{- TODO + * don't forget fixity!! +-} + +ppLaTeX :: String -- Title + -> Maybe String -- Package name + -> [Interface] + -> FilePath -- destination directory + -> Maybe (Doc GHC.RdrName) -- prologue text, maybe + -> Maybe String -- style file + -> FilePath + -> IO () + +ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir + = do + createDirectoryIfMissing True odir + when (isNothing maybe_style) $ + copyFile (libdir </> "latex" </> haddockSty) (odir </> haddockSty) + ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces + mapM_ (ppLaTeXModule title odir) visible_ifaces + + +haddockSty :: FilePath +haddockSty = "haddock.sty" + + +type LaTeX = Pretty.Doc + + +ppLaTeXTop + :: String + -> Maybe String + -> FilePath + -> Maybe (Doc GHC.RdrName) + -> Maybe String + -> [Interface] + -> IO () + +ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do + + let tex = vcat [ + text "\\documentclass{book}", + text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style), + text "\\begin{document}", + text "\\begin{titlepage}", + text "\\begin{haddocktitle}", + text doctitle, + text "\\end{haddocktitle}", + case prologue of + Nothing -> empty + Just d -> vcat [text "\\begin{haddockprologue}", + rdrDocToLaTeX d, + text "\\end{haddockprologue}"], + text "\\end{titlepage}", + text "\\tableofcontents", + vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ], + text "\\end{document}" + ] + + mods = sort (map (moduleBasename.ifaceMod) ifaces) + + filename = odir </> (fromMaybe "haddock" packageStr <.> "tex") + + writeFile filename (show tex) + + +ppLaTeXModule :: String -> FilePath -> Interface -> IO () +ppLaTeXModule _title odir iface = do + createDirectoryIfMissing True odir + let + mdl = ifaceMod iface + mdl_str = moduleString mdl + + exports = ifaceRnExportItems iface + + tex = vcat [ + text "\\haddockmoduleheading" <> braces (text mdl_str), + text "\\label{module:" <> text mdl_str <> char '}', + text "\\haddockbeginheader", + verb $ vcat [ + text "module" <+> text mdl_str <+> lparen, + text " " <> fsep (punctuate (text ", ") $ + map exportListItem $ + filter forSummary exports), + text " ) where" + ], + text "\\haddockendheader" $$ text "", + description, + body + ] + + description + = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface + + body = processExports exports + -- + writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex) + + +string_txt :: TextDetails -> String -> String +string_txt (Chr c) s = c:s +string_txt (Str s1) s2 = s1 ++ s2 +string_txt (PStr s1) s2 = unpackFS s1 ++ s2 +string_txt (ZStr s1) s2 = zString s1 ++ s2 +string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 + + +exportListItem :: ExportItem DocName -> LaTeX +exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs } + = sep (punctuate comma . map ppDocBinder $ declNames decl) <> + case subdocs of + [] -> empty + _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) +exportListItem (ExportNoDecl y []) + = ppDocBinder y +exportListItem (ExportNoDecl y subs) + = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs))) +exportListItem (ExportModule mdl) + = text "module" <+> text (moduleString mdl) +exportListItem _ + = error "exportListItem" + + +-- Deal with a group of undocumented exports together, to avoid lots +-- of blank vertical space between them. +processExports :: [ExportItem DocName] -> LaTeX +processExports [] = empty +processExports (decl : es) + | Just sig <- isSimpleSig decl + = multiDecl [ ppTypeSig (map getName names) typ False + | (names,typ) <- sig:sigs ] $$ + processExports es' + where (sigs, es') = spanWith isSimpleSig es +processExports (ExportModule mdl : es) + = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$ + processExports es' + where (mdls, es') = spanWith isExportModule es +processExports (e : es) = + processExport e $$ processExports es + + +isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t))) + , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } + | Map.null argDocs = Just (map unLoc lnames, t) +isSimpleSig _ = Nothing + + +isExportModule :: ExportItem DocName -> Maybe Module +isExportModule (ExportModule m) = Just m +isExportModule _ = Nothing + + +processExport :: ExportItem DocName -> LaTeX +processExport (ExportGroup lev _id0 doc) + = ppDocGroup lev (docToLaTeX doc) +processExport (ExportDecl decl doc subdocs insts fixities _splice) + = ppDecl decl doc insts subdocs fixities +processExport (ExportNoDecl y []) + = ppDocName y +processExport (ExportNoDecl y subs) + = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs))) +processExport (ExportModule mdl) + = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing +processExport (ExportDoc doc) + = docToLaTeX doc + + +ppDocGroup :: Int -> LaTeX -> LaTeX +ppDocGroup lev doc = sec lev <> braces doc + where sec 1 = text "\\section" + sec 2 = text "\\subsection" + sec 3 = text "\\subsubsection" + sec _ = text "\\paragraph" + + +declNames :: LHsDecl DocName -> [DocName] +declNames (L _ decl) = case decl of + TyClD d -> [tcdName d] + SigD (TypeSig lnames _) -> map unLoc lnames + SigD (PatSynSig lname _ _ _ _) -> [unLoc lname] + ForD (ForeignImport (L _ n) _ _ _) -> [n] + ForD (ForeignExport (L _ n) _ _ _) -> [n] + _ -> error "declaration not supported by declNames" + + +forSummary :: (ExportItem DocName) -> Bool +forSummary (ExportGroup _ _ _) = False +forSummary (ExportDoc _) = False +forSummary _ = True + + +moduleLaTeXFile :: Module -> FilePath +moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex" + + +moduleBasename :: Module -> FilePath +moduleBasename mdl = map (\c -> if c == '.' then '-' else c) + (moduleNameString (moduleName mdl)) + + +------------------------------------------------------------------------------- +-- * Decls +------------------------------------------------------------------------------- + + +ppDecl :: LHsDecl DocName + -> DocForDecl DocName + -> [DocInstance DocName] + -> [(DocName, DocForDecl DocName)] + -> [(DocName, Fixity)] + -> LaTeX + +ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of + TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode + TyClD d@(DataDecl {}) + -> ppDataDecl instances subdocs loc (Just doc) d unicode + TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode +-- Family instances happen via FamInst now +-- TyClD d@(TySynonym {}) +-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode +-- Family instances happen via FamInst now + TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode + SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode + SigD (PatSynSig lname args ty prov req) -> + ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode + ForD d -> ppFor loc (doc, fnArgsDoc) d unicode + InstD _ -> empty + _ -> error "declaration not supported by ppDecl" + where + unicode = False + + +ppTyFam :: Bool -> SrcSpan -> Documentation DocName -> + TyClDecl DocName -> Bool -> LaTeX +ppTyFam _ _ _ _ _ = + error "type family declarations are currently not supported by --latex" + + +ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX +ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode = + ppFunSig loc doc [name] typ unicode +ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" +-- error "foreign declarations are currently not supported by --latex" + + +------------------------------------------------------------------------------- +-- * Type Synonyms +------------------------------------------------------------------------------- + + +-- we skip type patterns for now +ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX + +ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars + , tcdRhs = ltype }) unicode + = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode + where + hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) + full = hdr <+> char '=' <+> ppLType unicode ltype + +ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" + + +------------------------------------------------------------------------------- +-- * Function signatures +------------------------------------------------------------------------------- + + +ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName + -> Bool -> LaTeX +ppFunSig loc doc docnames typ unicode = + ppTypeOrFunSig loc docnames typ doc + ( ppTypeSig names typ False + , hsep . punctuate comma $ map ppSymName names + , dcolon unicode) + unicode + where + names = map getName docnames + +ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName + -> HsPatSynDetails (LHsType DocName) -> LHsType DocName + -> LHsContext DocName -> LHsContext DocName + -> Bool -> LaTeX +ppLPatSig loc doc docname args typ prov req unicode = + ppPatSig loc doc (unLoc docname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode + +ppPatSig :: SrcSpan -> DocForDecl DocName -> DocName + -> HsPatSynDetails (HsType DocName) -> HsType DocName + -> HsContext DocName -> HsContext DocName + -> Bool -> LaTeX +ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc) + where + pref1 = hsep [ keyword "pattern" + , pp_ctx prov + , pp_head + , dcolon unicode + , pp_ctx req + , ppType unicode typ + ] + + pp_head = case args of + PrefixPatSyn typs -> hsep $ ppDocBinder docname : map pp_type typs + InfixPatSyn left right -> hsep [pp_type left, ppDocBinderInfix docname, pp_type right] + + pp_type = ppParendType unicode + pp_ctx ctx = ppContext ctx unicode + +ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName + -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) + -> Bool -> LaTeX +ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) + unicode + | Map.null argDocs = + declWithDoc pref1 (documentationToLaTeX doc) + | otherwise = + declWithDoc pref2 $ Just $ + text "\\haddockbeginargs" $$ + do_args 0 sep0 typ $$ + text "\\end{tabulary}\\par" $$ + fromMaybe empty (documentationToLaTeX doc) + where + do_largs n leader (L _ t) = do_args n leader t + + arg_doc n = rDoc (Map.lookup n argDocs) + + do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX + do_args n leader (HsForAllTy Explicit tvs lctxt ltype) + = decltt leader <-> + decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> + ppLContextNoArrow lctxt unicode) <+> nl $$ + do_largs n (darrow unicode) ltype + + do_args n leader (HsForAllTy Implicit _ lctxt ltype) + | not (null (unLoc lctxt)) + = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ + do_largs n (darrow unicode) ltype + -- if we're not showing any 'forall' or class constraints or + -- anything, skip having an empty line for the context. + | otherwise + = do_largs n leader ltype + do_args n leader (HsFunTy lt r) + = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ + do_largs (n+1) (arrow unicode) r + do_args n leader t + = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl + + +ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX +ppTypeSig nms ty unicode = + hsep (punctuate comma $ map ppSymName nms) + <+> dcolon unicode + <+> ppType unicode ty + + +ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX] +ppTyVars tvs = map ppSymName (tyvarNames tvs) + + +tyvarNames :: LHsTyVarBndrs DocName -> [Name] +tyvarNames = map getName . hsLTyVarNames + + +declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX +declWithDoc decl doc = + text "\\begin{haddockdesc}" $$ + text "\\item[\\begin{tabular}{@{}l}" $$ + text (latexMonoFilter (show decl)) $$ + text "\\end{tabular}]" <> + (if isNothing doc then empty else text "\\haddockbegindoc") $$ + maybe empty id doc $$ + text "\\end{haddockdesc}" + + +-- in a group of decls, we don't put them all in the same tabular, +-- because that would prevent the group being broken over a page +-- boundary (breaks Foreign.C.Error for example). +multiDecl :: [LaTeX] -> LaTeX +multiDecl decls = + text "\\begin{haddockdesc}" $$ + vcat [ + text "\\item[" $$ + text (latexMonoFilter (show decl)) $$ + text "]" + | decl <- decls ] $$ + text "\\end{haddockdesc}" + + +------------------------------------------------------------------------------- +-- * Rendering Doc +------------------------------------------------------------------------------- + + +maybeDoc :: Maybe (Doc DocName) -> LaTeX +maybeDoc = maybe empty docToLaTeX + + +-- for table cells, we strip paragraphs out to avoid extra vertical space +-- and don't add a quote environment. +rDoc :: Maybe (Doc DocName) -> LaTeX +rDoc = maybeDoc . fmap latexStripTrailingWhitespace + + +------------------------------------------------------------------------------- +-- * Class declarations +------------------------------------------------------------------------------- + + +ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName + -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] + -> Bool -> LaTeX +ppClassHdr summ lctxt n tvs fds unicode = + keyword "class" + <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) + <+> ppAppDocNameNames summ n (tyvarNames $ tvs) + <+> ppFds fds unicode + + +ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX +ppFds fds unicode = + if null fds then empty else + char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) + where + fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+> + hsep (map ppDocName vars2) + + +ppClassDecl :: [DocInstance DocName] -> SrcSpan + -> Documentation DocName -> [(DocName, DocForDecl DocName)] + -> TyClDecl DocName -> Bool -> LaTeX +ppClassDecl instances loc doc subdocs + (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds + , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode + = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ + instancesBit + where + classheader + | null lsigs = hdr unicode + | otherwise = hdr unicode <+> keyword "where" + + hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds + + body = catMaybes [documentationToLaTeX doc, body_] + + body_ + | null lsigs, null ats, null at_defs = Nothing + | null ats, null at_defs = Just methodTable +--- | otherwise = atTable $$ methodTable + | otherwise = error "LaTeX.ppClassDecl" + + methodTable = + text "\\haddockpremethods{}\\textbf{Methods}" $$ + vcat [ ppFunSig loc doc names typ unicode + | L _ (TypeSig lnames (L _ typ)) <- lsigs + , let doc = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames ] + -- FIXME: is taking just the first name ok? Is it possible that + -- there are different subdocs for different names in a single + -- type signature? + + instancesBit = ppDocInstances unicode instances + +ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + +ppDocInstances :: Bool -> [DocInstance DocName] -> LaTeX +ppDocInstances _unicode [] = empty +ppDocInstances unicode (i : rest) + | Just ihead <- isUndocdInstance i + = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$ + ppDocInstances unicode rest' + | otherwise + = ppDocInstance unicode i $$ ppDocInstances unicode rest + where + (is, rest') = spanWith isUndocdInstance rest + +isUndocdInstance :: DocInstance a -> Maybe (InstHead a) +isUndocdInstance (i,Nothing) = Just i +isUndocdInstance _ = Nothing + +-- | Print a possibly commented instance. The instance header is printed inside +-- an 'argBox'. The comment is printed to the right of the box in normal comment +-- style. +ppDocInstance :: Bool -> DocInstance DocName -> LaTeX +ppDocInstance unicode (instHead, doc) = + declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc) + + +ppInstDecl :: Bool -> InstHead DocName -> LaTeX +ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead + + +ppInstHead :: Bool -> InstHead DocName -> LaTeX +ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode +ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type" + <+> ppAppNameTypes n ks ts unicode + <+> maybe empty (\t -> equals <+> ppType unicode t) rhs +ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) = + error "data instances not supported by --latex yet" + +lookupAnySubdoc :: (Eq name1) => + name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 +lookupAnySubdoc n subdocs = case lookup n subdocs of + Nothing -> noDocForDecl + Just docs -> docs + + +------------------------------------------------------------------------------- +-- * Data & newtype declarations +------------------------------------------------------------------------------- + + +ppDataDecl :: [DocInstance DocName] -> + [(DocName, DocForDecl DocName)] -> SrcSpan -> + Maybe (Documentation DocName) -> TyClDecl DocName -> Bool -> + LaTeX +ppDataDecl instances subdocs _loc doc dataDecl unicode + + = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) + (if null body then Nothing else Just (vcat body)) + $$ instancesBit + + where + cons = dd_cons (tcdDataDefn dataDecl) + resTy = (con_res . unLoc . head) cons + + body = catMaybes [constrBit, doc >>= documentationToLaTeX] + + (whereBit, leaders) + | null cons = (empty,[]) + | otherwise = case resTy of + ResTyGADT _ -> (decltt (keyword "where"), repeat empty) + _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) + + constrBit + | null cons = Nothing + | otherwise = Just $ + text "\\haddockbeginconstrs" $$ + vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$ + text "\\end{tabulary}\\par" + + instancesBit = ppDocInstances unicode instances + + +-- ppConstrHdr is for (non-GADT) existentials constructors' syntax +ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX +ppConstrHdr forall tvs ctxt unicode + = (if null tvs then empty else ppForall) + <+> + (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") + where + ppForall = case forall of + Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " + Implicit -> empty + + +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX + -> LConDecl DocName -> LaTeX +ppSideBySideConstr subdocs unicode leader (L _ con) = + leader <-> + case con_res con of + ResTyH98 -> case con_details con of + + PrefixCon args -> + decltt (hsep ((header_ unicode <+> ppBinder occ) : + map (ppLParendType unicode) args)) + <-> rDoc mbDoc <+> nl + + RecCon fields -> + (decltt (header_ unicode <+> ppBinder occ) + <-> rDoc mbDoc <+> nl) + $$ + doRecordFields fields + + InfixCon arg1 arg2 -> + decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, + ppBinder occ, + ppLParendType unicode arg2 ]) + <-> rDoc mbDoc <+> nl + + ResTyGADT resTy -> case con_details con of + -- prefix & infix could also use hsConDeclArgTys if it seemed to + -- simplify the code. + PrefixCon args -> doGADTCon args resTy + cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ + doRecordFields fields + InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + + where + doRecordFields fields = + vcat (map (ppSideBySideField subdocs unicode) fields) + + doGADTCon args resTy = decltt (ppBinder occ <+> dcolon unicode <+> hsep [ + ppForAll forall ltvs (con_cxt con) unicode, + ppLType unicode (foldr mkFunTy resTy args) ] + ) <-> rDoc mbDoc + + + header_ = ppConstrHdr forall tyVars context + occ = nameOccName . getName . unLoc . con_name $ con + ltvs = con_qvars con + tyVars = tyvarNames (con_qvars con) + context = unLoc (con_cxt con) + forall = con_explicit con + -- don't use "con_doc con", in case it's reconstructed from a .hi file, + -- or also because we want Haddock to do the doc-parsing, not GHC. + mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst + mkFunTy a b = noLoc (HsFunTy a b) + + +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX +ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = + decltt (ppBinder (nameOccName . getName $ name) + <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc + where + -- don't use cd_fld_doc for same reason we don't use con_doc above + mbDoc = lookup name subdocs >>= combineDocumentation . fst + +-- {- +-- ppHsFullConstr :: HsConDecl -> LaTeX +-- 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 (docToLaTeX (fromJust doc)) +-- | otherwise = LaTeX.emptyTable +-- +-- fields_html = +-- td << +-- table ! [width "100%", cellpadding 0, cellspacing 8] << ( +-- aboves (map ppFullField (concat (map expandField fields))) +-- ) +-- -} +-- +-- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX +-- ppShortField summary unicode (ConDeclField (L _ name) ltype _) +-- = tda [theclass "recfield"] << ( +-- ppBinder summary (docNameOcc name) +-- <+> dcolon unicode <+> ppLType unicode ltype +-- ) +-- +-- {- +-- ppFullField :: HsFieldDecl -> LaTeX +-- 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 :: TyClDecl DocName -> Bool -> LaTeX +ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars + , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode + = -- newtype or data + (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> + -- context + ppLContext ctxt unicode <+> + -- T a b c ..., or a :+: b + ppAppDocNameNames False name (tyvarNames tyvars) +ppDataHeader _ _ = error "ppDataHeader: illegal argument" + +-------------------------------------------------------------------------------- +-- * Type applications +-------------------------------------------------------------------------------- + + +-- | Print an application of a DocName and two lists of HsTypes (kinds, types) +ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX +ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode) + + +-- | Print an application of a DocName and a list of Names +ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX +ppAppDocNameNames _summ n ns = + ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName + + +-- | General printing of type applications +ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX +ppTypeApp n [] (t1:t2:rest) ppDN ppT + | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) + | operator = opApp + where + operator = isNameSym . getName $ n + opApp = ppT t1 <+> ppDN n <+> ppT t2 + +ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts) + + +------------------------------------------------------------------------------- +-- * Contexts +------------------------------------------------------------------------------- + + +ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX +ppLContext = ppContext . unLoc +ppLContextNoArrow = ppContextNoArrow . unLoc + + +ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX +ppContextNoArrow [] _ = empty +ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode + + +ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX +ppContextNoLocs [] _ = empty +ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode + + +ppContext :: HsContext DocName -> Bool -> LaTeX +ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode + + +pp_hs_context :: [HsType DocName] -> Bool -> LaTeX +pp_hs_context [] _ = empty +pp_hs_context [p] unicode = ppType unicode p +pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) + + +------------------------------------------------------------------------------- +-- * Types and contexts +------------------------------------------------------------------------------- + + +ppBang :: HsBang -> LaTeX +ppBang HsNoBang = empty +ppBang _ = char '!' -- Unpacked args is an implementation detail, + + +tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX +tupleParens HsUnboxedTuple = ubxParenList +tupleParens _ = parenList + + +------------------------------------------------------------------------------- +-- * Rendering of HsType +-- +-- Stolen from Html and tweaked for LaTeX generation +------------------------------------------------------------------------------- + + +pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int + +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 + -> LaTeX -> LaTeX -- Wrap in parens if (ctxt >= op) +maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p + | otherwise = p + + +ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX +ppLType unicode y = ppType unicode (unLoc y) +ppLParendType unicode y = ppParendType unicode (unLoc y) +ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) + + +ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX +ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode +ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode +ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode + +ppLKind :: Bool -> LHsKind DocName -> LaTeX +ppLKind unicode y = ppKind unicode (unLoc y) + +ppKind :: Bool -> HsKind DocName -> LaTeX +ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode + + +-- Drop top-level for-all type variables in user style +-- since they are implicit in Haskell + +ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName + -> Located (HsContext DocName) -> Bool -> LaTeX +ppForAll expl tvs cxt unicode + | show_forall = forall_part <+> ppLContext cxt unicode + | otherwise = ppLContext cxt unicode + where + show_forall = not (null (hsQTvBndrs tvs)) && is_explicit + is_explicit = case expl of {Explicit -> True; Implicit -> False} + forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot + + +ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX +ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode + + +ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX +ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode + = maybeParen ctxt_prec pREC_FUN $ + hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode] + +ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty +ppr_mono_ty _ (HsTyVar name) _ = ppDocName name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u +ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) +ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) +ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" +ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys +ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy" + +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode + = maybeParen ctxt_prec pREC_OP $ + ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode + +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode + = maybeParen ctxt_prec pREC_CON $ + hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] + +ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode + = maybeParen ctxt_prec pREC_FUN $ + ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode + where + ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op + occName = nameOccName . getName . unLoc $ op + +ppr_mono_ty ctxt_prec (HsParTy ty) unicode +-- = parens (ppr_mono_lty pREC_TOP ty) + = ppr_mono_lty ctxt_prec ty unicode + +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode + = ppr_mono_lty ctxt_prec ty unicode + +ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u + + +ppr_tylit :: HsTyLit -> Bool -> LaTeX +ppr_tylit (HsNumTy n) _ = integer n +ppr_tylit (HsStrTy s) _ = text (show s) + -- XXX: Ok in verbatim, but not otherwise + -- XXX: Do something with Unicode parameter? + + +ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX +ppr_fun_ty ctxt_prec ty1 ty2 unicode + = let p1 = ppr_mono_lty pREC_FUN ty1 unicode + p2 = ppr_mono_lty pREC_TOP ty2 unicode + in + maybeParen ctxt_prec pREC_FUN $ + sep [p1, arrow unicode <+> p2] + + +------------------------------------------------------------------------------- +-- * Names +------------------------------------------------------------------------------- + + +ppBinder :: OccName -> LaTeX +ppBinder n + | isInfixName n = parens $ ppOccName n + | otherwise = ppOccName n + +ppBinderInfix :: OccName -> LaTeX +ppBinderInfix n + | isInfixName n = ppOccName n + | otherwise = quotes $ ppOccName n + +isInfixName :: OccName -> Bool +isInfixName n = isVarSym n || isConSym n + +ppSymName :: Name -> LaTeX +ppSymName name + | isNameSym name = parens $ ppName name + | otherwise = ppName name + + +ppVerbOccName :: OccName -> LaTeX +ppVerbOccName = text . latexFilter . occNameString + +ppIPName :: HsIPName -> LaTeX +ppIPName ip = text $ unpackFS $ hsIPNameFS ip + +ppOccName :: OccName -> LaTeX +ppOccName = text . occNameString + + +ppVerbDocName :: DocName -> LaTeX +ppVerbDocName = ppVerbOccName . nameOccName . getName + + +ppVerbRdrName :: RdrName -> LaTeX +ppVerbRdrName = ppVerbOccName . rdrNameOcc + + +ppDocName :: DocName -> LaTeX +ppDocName = ppOccName . nameOccName . getName + + +ppLDocName :: Located DocName -> LaTeX +ppLDocName (L _ d) = ppDocName d + + +ppDocBinder :: DocName -> LaTeX +ppDocBinder = ppBinder . nameOccName . getName + +ppDocBinderInfix :: DocName -> LaTeX +ppDocBinderInfix = ppBinderInfix . nameOccName . getName + + +ppName :: Name -> LaTeX +ppName = ppOccName . nameOccName + + +latexFilter :: String -> String +latexFilter = foldr latexMunge "" + + +latexMonoFilter :: String -> String +latexMonoFilter = foldr latexMonoMunge "" + + +latexMunge :: Char -> String -> String +latexMunge '#' s = "{\\char '43}" ++ s +latexMunge '$' s = "{\\char '44}" ++ s +latexMunge '%' s = "{\\char '45}" ++ s +latexMunge '&' s = "{\\char '46}" ++ s +latexMunge '~' s = "{\\char '176}" ++ s +latexMunge '_' s = "{\\char '137}" ++ s +latexMunge '^' s = "{\\char '136}" ++ s +latexMunge '\\' s = "{\\char '134}" ++ s +latexMunge '{' s = "{\\char '173}" ++ s +latexMunge '}' s = "{\\char '175}" ++ s +latexMunge '[' s = "{\\char 91}" ++ s +latexMunge ']' s = "{\\char 93}" ++ s +latexMunge c s = c : s + + +latexMonoMunge :: Char -> String -> String +latexMonoMunge ' ' s = '\\' : ' ' : s +latexMonoMunge '\n' s = '\\' : '\\' : s +latexMonoMunge c s = latexMunge c s + + +------------------------------------------------------------------------------- +-- * Doc Markup +------------------------------------------------------------------------------- + + +parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX) +parLatexMarkup ppId = Markup { + markupParagraph = \p v -> p v <> text "\\par" $$ text "", + markupEmpty = \_ -> empty, + markupString = \s v -> text (fixString v s), + markupAppend = \l r v -> l v <> r v, + markupIdentifier = markupId ppId, + markupIdentifierUnchecked = markupId (ppVerbOccName . snd), + markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), + markupWarning = \p v -> emph (p v), + markupEmphasis = \p v -> emph (p v), + markupBold = \p v -> bold (p v), + markupMonospaced = \p _ -> tt (p Mono), + markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", + markupPic = \p _ -> markupPic p, + markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", + markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), + markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", + markupHyperlink = \l _ -> markupLink l, + markupAName = \_ _ -> empty, + markupProperty = \p _ -> quote $ verb $ text p, + markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e, + markupHeader = \(Header l h) p -> header l (h p) + } + where + header 1 d = text "\\section*" <> braces d + header 2 d = text "\\subsection*" <> braces d + header l d + | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d + header l _ = error $ "impossible header level in LaTeX generation: " ++ show l + + fixString Plain s = latexFilter s + fixString Verb s = s + fixString Mono s = latexMonoFilter s + + markupLink (Hyperlink url mLabel) = case mLabel of + Just label -> text "\\href" <> braces (text url) <> braces (text label) + Nothing -> text "\\url" <> braces (text url) + + -- Is there a better way of doing this? Just a space is an aribtrary choice. + markupPic (Picture uri title) = parens (imageText title) + where + imageText Nothing = beg + imageText (Just t) = beg <> text " " <> text t + + beg = text "image: " <> text uri + + markupId ppId_ id v = + case v of + Verb -> theid + Mono -> theid + Plain -> text "\\haddockid" <> braces theid + where theid = ppId_ id + + +latexMarkup :: DocMarkup DocName (StringContext -> LaTeX) +latexMarkup = parLatexMarkup ppVerbDocName + + +rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX) +rdrLatexMarkup = parLatexMarkup ppVerbRdrName + + +docToLaTeX :: Doc DocName -> LaTeX +docToLaTeX doc = markup latexMarkup doc Plain + + +documentationToLaTeX :: Documentation DocName -> Maybe LaTeX +documentationToLaTeX = fmap docToLaTeX . combineDocumentation + + +rdrDocToLaTeX :: Doc RdrName -> LaTeX +rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain + + +data StringContext = Plain | Verb | Mono + + +latexStripTrailingWhitespace :: Doc a -> Doc a +latexStripTrailingWhitespace (DocString s) + | null s' = DocEmpty + | otherwise = DocString s + where s' = reverse (dropWhile isSpace (reverse s)) +latexStripTrailingWhitespace (DocAppend l r) + | DocEmpty <- r' = latexStripTrailingWhitespace l + | otherwise = DocAppend l r' + where + r' = latexStripTrailingWhitespace r +latexStripTrailingWhitespace (DocParagraph p) = + latexStripTrailingWhitespace p +latexStripTrailingWhitespace other = other + + +------------------------------------------------------------------------------- +-- * LaTeX utils +------------------------------------------------------------------------------- + + +itemizedList :: [LaTeX] -> LaTeX +itemizedList items = + text "\\begin{itemize}" $$ + vcat (map (text "\\item" $$) items) $$ + text "\\end{itemize}" + + +enumeratedList :: [LaTeX] -> LaTeX +enumeratedList items = + text "\\begin{enumerate}" $$ + vcat (map (text "\\item " $$) items) $$ + text "\\end{enumerate}" + + +descriptionList :: [(LaTeX,LaTeX)] -> LaTeX +descriptionList items = + text "\\begin{description}" $$ + vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$ + text "\\end{description}" + + +tt :: LaTeX -> LaTeX +tt ltx = text "\\haddocktt" <> braces ltx + + +decltt :: LaTeX -> LaTeX +decltt ltx = text "\\haddockdecltt" <> braces ltx + + +emph :: LaTeX -> LaTeX +emph ltx = text "\\emph" <> braces ltx + +bold :: LaTeX -> LaTeX +bold ltx = text "\\textbf" <> braces ltx + +verb :: LaTeX -> LaTeX +verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}" + -- NB. swallow a trailing \n in the verbatim text by appending the + -- \end{verbatim} directly, otherwise we get spurious blank lines at the + -- end of code blocks. + + +quote :: LaTeX -> LaTeX +quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" + + +dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX +dcolon unicode = text (if unicode then "∷" else "::") +arrow unicode = text (if unicode then "→" else "->") +darrow unicode = text (if unicode then "⇒" else "=>") +forallSymbol unicode = text (if unicode then "∀" else "forall") + + +dot :: LaTeX +dot = char '.' + + +parenList :: [LaTeX] -> LaTeX +parenList = parens . hsep . punctuate comma + + +ubxParenList :: [LaTeX] -> LaTeX +ubxParenList = ubxparens . hsep . punctuate comma + + +ubxparens :: LaTeX -> LaTeX +ubxparens h = text "(#" <> h <> text "#)" + + +pabrackets :: LaTeX -> LaTeX +pabrackets h = text "[:" <> h <> text ":]" + + +nl :: LaTeX +nl = text "\\\\" + + +keyword :: String -> LaTeX +keyword = text + + +infixr 4 <-> -- combining table cells +(<->) :: LaTeX -> LaTeX -> LaTeX +a <-> b = a <+> char '&' <+> b diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs new file mode 100644 index 00000000..9628a33d --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -0,0 +1,690 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +module Haddock.Backends.Xhtml ( + ppHtml, copyHtmlBits, + ppHtmlIndex, ppHtmlContents, +) where + + +import Prelude hiding (div) + +import Haddock.Backends.Xhtml.Decl +import Haddock.Backends.Xhtml.DocMarkup +import Haddock.Backends.Xhtml.Layout +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Themes +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils +import Haddock.ModuleTree +import Haddock.Types +import Haddock.Version +import Haddock.Utils +import Text.XHtml hiding ( name, title, p, quote ) +import Haddock.GhcUtils + +import Control.Monad ( when, unless ) +#if !MIN_VERSION_base(4,7,0) +import Control.Monad.Instances ( ) -- for Functor Either a +#endif +import Data.Char ( toUpper ) +import Data.Functor ( (<$>) ) +import Data.List ( sortBy, groupBy, intercalate, isPrefixOf ) +import Data.Maybe +import System.FilePath hiding ( (</>) ) +import System.Directory +import Data.Map ( Map ) +import qualified Data.Map as Map hiding ( Map ) +import qualified Data.Set as Set hiding ( Set ) +import Data.Function +import Data.Ord ( comparing ) + +import DynFlags (Language(..)) +import GHC hiding ( NoLink, moduleInfo ) +import Name +import Module + +-------------------------------------------------------------------------------- +-- * Generating HTML documentation +-------------------------------------------------------------------------------- + + +ppHtml :: String + -> Maybe String -- ^ Package + -> [Interface] + -> FilePath -- ^ Destination directory + -> Maybe (Doc GHC.RdrName) -- ^ Prologue text, maybe + -> Themes -- ^ Themes + -> SourceURLs -- ^ The source URL (--source) + -> WikiURLs -- ^ The wiki URL (--wiki) + -> Maybe String -- ^ The contents URL (--use-contents) + -> Maybe String -- ^ The index URL (--use-index) + -> Bool -- ^ Whether to use unicode in output (--use-unicode) + -> QualOption -- ^ How to qualify names + -> Bool -- ^ Output pretty html (newlines and indenting) + -> IO () + +ppHtml doctitle maybe_package ifaces odir prologue + themes maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode + qual debug = do + let + visible_ifaces = filter visible ifaces + visible i = OptHide `notElem` ifaceOptions i + + when (isNothing maybe_contents_url) $ + ppHtmlContents odir doctitle maybe_package + themes maybe_index_url maybe_source_url maybe_wiki_url + (map toInstalledIface visible_ifaces) + False -- we don't want to display the packages in a single-package contents + prologue debug (makeContentsQual qual) + + when (isNothing maybe_index_url) $ + ppHtmlIndex odir doctitle maybe_package + themes maybe_contents_url maybe_source_url maybe_wiki_url + (map toInstalledIface visible_ifaces) debug + + mapM_ (ppHtmlModule odir doctitle themes + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces + + +copyHtmlBits :: FilePath -> FilePath -> Themes -> IO () +copyHtmlBits odir libdir themes = do + let + libhtmldir = joinPath [libdir, "html"] + copyCssFile f = copyFile f (combine odir (takeFileName f)) + copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) + mapM_ copyCssFile (cssFiles themes) + mapM_ copyLibFile [ jsFile, framesFile ] + + +headHtml :: String -> Maybe String -> Themes -> Html +headHtml docTitle miniPage themes = + header << [ + meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], + thetitle << docTitle, + styleSheet themes, + script ! [src jsFile, thetype "text/javascript"] << noHtml, + script ! [thetype "text/javascript"] + -- NB: Within XHTML, the content of script tags needs to be + -- a <![CDATA[ section. Will break if the miniPage name could + -- have "]]>" in it! + << primHtml ( + "//<![CDATA[\nwindow.onload = function () {pageLoad();" + ++ setSynopsis ++ "};\n//]]>\n") + ] + where + setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage + + +srcButton :: SourceURLs -> Maybe Interface -> Maybe Html +srcButton (Just src_base_url, _, _, _) Nothing = + Just (anchor ! [href src_base_url] << "Source") +srcButton (_, Just src_module_url, _, _) (Just iface) = + let url = spliceURL (Just $ ifaceOrigFilename iface) + (Just $ ifaceMod iface) Nothing Nothing src_module_url + in Just (anchor ! [href url] << "Source") +srcButton _ _ = + Nothing + + +wikiButton :: WikiURLs -> Maybe Module -> Maybe Html +wikiButton (Just wiki_base_url, _, _) Nothing = + Just (anchor ! [href wiki_base_url] << "User Comments") + +wikiButton (_, Just wiki_module_url, _) (Just mdl) = + let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url + in Just (anchor ! [href url] << "User Comments") + +wikiButton _ _ = + Nothing + + +contentsButton :: Maybe String -> Maybe Html +contentsButton maybe_contents_url + = Just (anchor ! [href url] << "Contents") + where url = fromMaybe contentsHtmlFile maybe_contents_url + + +indexButton :: Maybe String -> Maybe Html +indexButton maybe_index_url + = Just (anchor ! [href url] << "Index") + where url = fromMaybe indexHtmlFile maybe_index_url + + +bodyHtml :: String -> Maybe Interface + -> SourceURLs -> WikiURLs + -> Maybe String -> Maybe String + -> Html -> Html +bodyHtml doctitle iface + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url + pageContent = + body << [ + divPackageHeader << [ + unordList (catMaybes [ + srcButton maybe_source_url iface, + wikiButton maybe_wiki_url (ifaceMod <$> iface), + contentsButton maybe_contents_url, + indexButton maybe_index_url]) + ! [theclass "links", identifier "page-menu"], + nonEmptySectionName << doctitle + ], + divContent << pageContent, + divFooter << paragraph << ( + "Produced by " +++ + (anchor ! [href projectUrl] << toHtml projectName) +++ + (" version " ++ projectVersion) + ) + ] + + +moduleInfo :: Interface -> Html +moduleInfo iface = + let + info = ifaceInfo iface + + doOneEntry :: (String, HaddockModInfo GHC.Name -> Maybe String) -> Maybe HtmlTable + doOneEntry (fieldName, field) = + field info >>= \a -> return (th << fieldName <-> td << a) + + entries :: [HtmlTable] + entries = mapMaybe doOneEntry [ + ("Copyright",hmi_copyright), + ("License",hmi_license), + ("Maintainer",hmi_maintainer), + ("Stability",hmi_stability), + ("Portability",hmi_portability), + ("Safe Haskell",hmi_safety), + ("Language", lg) + ] ++ extsForm + where + lg inf = case hmi_language inf of + Nothing -> Nothing + Just Haskell98 -> Just "Haskell98" + Just Haskell2010 -> Just "Haskell2010" + + extsForm + | OptShowExtensions `elem` ifaceOptions iface = + let fs = map (dropOpt . show) (hmi_extensions info) + in case map stringToHtml fs of + [] -> [] + [x] -> extField x -- don't use a list for a single extension + xs -> extField $ unordList xs ! [theclass "extension-list"] + | otherwise = [] + where + extField x = return $ th << "Extensions" <-> td << x + dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x + in + case entries of + [] -> noHtml + _ -> table ! [theclass "info"] << aboves entries + + +-------------------------------------------------------------------------------- +-- * Generate the module contents +-------------------------------------------------------------------------------- + + +ppHtmlContents + :: FilePath + -> String + -> Maybe String + -> Themes + -> Maybe String + -> SourceURLs + -> WikiURLs + -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName) + -> Bool + -> Qualification -- ^ How to qualify names + -> IO () +ppHtmlContents odir doctitle _maybe_package + themes maybe_index_url + maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do + let tree = mkModuleTree showPkgs + [(instMod iface, toInstalledDescription iface) | iface <- ifaces] + html = + headHtml doctitle Nothing themes +++ + bodyHtml doctitle Nothing + maybe_source_url maybe_wiki_url + Nothing maybe_index_url << [ + ppPrologue qual doctitle prologue, + ppModuleTree qual tree + ] + createDirectoryIfMissing True odir + writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + + -- XXX: think of a better place for this? + ppHtmlContentsFrame odir doctitle themes ifaces debug + + +ppPrologue :: Qualification -> String -> Maybe (Doc GHC.RdrName) -> Html +ppPrologue _ _ Nothing = noHtml +ppPrologue qual title (Just doc) = + divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc)) + + +ppModuleTree :: Qualification -> [ModuleTree] -> Html +ppModuleTree qual ts = + divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts) + + +mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html +mkNodeList qual ss p ts = case ts of + [] -> noHtml + _ -> unordList (zipWith (mkNode qual ss) ps ts) + where + ps = [ p ++ '.' : show i | i <- [(1::Int)..]] + + +mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html +mkNode qual ss p (Node s leaf pkg short ts) = + htmlModule <+> shortDescr +++ htmlPkg +++ subtree + where + modAttrs = case (ts, leaf) of + (_:_, False) -> collapseControl p True "module" + (_, _ ) -> [theclass "module"] + + cBtn = case (ts, leaf) of + (_:_, True) -> thespan ! collapseControl p True "" << spaceHtml + (_, _ ) -> noHtml + -- We only need an explicit collapser button when the module name + -- is also a leaf, and so is a link to a module page. Indeed, the + -- spaceHtml is a minor hack and does upset the layout a fraction. + + htmlModule = thespan ! modAttrs << (cBtn +++ + if leaf + then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg)) + (mkModuleName mdl)) + else toHtml s + ) + + mdl = intercalate "." (reverse (s:ss)) + + shortDescr = maybe noHtml (origDocToHtml qual) short + htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg + + subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True "" + + +-- | Turn a module tree into a flat list of full module names. E.g., +-- @ +-- A +-- +-B +-- +-C +-- @ +-- becomes +-- @["A", "A.B", "A.B.C"]@ +flatModuleTree :: [InstalledInterface] -> [Html] +flatModuleTree ifaces = + map (uncurry ppModule' . head) + . groupBy ((==) `on` fst) + . sortBy (comparing fst) + $ mods + where + mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ] + ppModule' txt mdl = + anchor ! [href (moduleHtmlFile mdl), target mainFrameName] + << toHtml txt + + +ppHtmlContentsFrame :: FilePath -> String -> Themes + -> [InstalledInterface] -> Bool -> IO () +ppHtmlContentsFrame odir doctitle themes ifaces debug = do + let mods = flatModuleTree ifaces + html = + headHtml doctitle Nothing themes +++ + miniBody << divModuleList << + (sectionName << "Modules" +++ + ulist << [ li ! [theclass "module"] << m | m <- mods ]) + createDirectoryIfMissing True odir + writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString debug html) + + +-------------------------------------------------------------------------------- +-- * Generate the index +-------------------------------------------------------------------------------- + + +ppHtmlIndex :: FilePath + -> String + -> Maybe String + -> Themes + -> Maybe String + -> SourceURLs + -> WikiURLs + -> [InstalledInterface] + -> Bool + -> IO () +ppHtmlIndex odir doctitle _maybe_package themes + maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do + let html = indexPage split_indices Nothing + (if split_indices then [] else index) + + createDirectoryIfMissing True odir + + when split_indices $ do + mapM_ (do_sub_index index) initialChars + -- Let's add a single large index as well for those who don't know exactly what they're looking for: + let mergedhtml = indexPage False Nothing index + writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) + + writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html) + + where + indexPage showLetters ch items = + headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes +++ + bodyHtml doctitle Nothing + maybe_source_url maybe_wiki_url + maybe_contents_url Nothing << [ + if showLetters then indexInitialLetterLinks else noHtml, + if null items then noHtml else + divIndex << [sectionName << indexName ch, buildIndex items] + ] + + indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch + merged_name = "All" + + buildIndex items = table << aboves (map indexElt items) + + -- an arbitrary heuristic: + -- too large, and a single-page will be slow to load + -- too small, and we'll have lots of letter-indexes with only one + -- or two members in them, which seems inefficient or + -- unnecessarily hard to use. + split_indices = length index > 150 + + indexInitialLetterLinks = + divAlphabet << + unordList (map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $ + [ [c] | c <- initialChars + , any ((==c) . toUpper . head . fst) index ] ++ + [merged_name]) + + -- todo: what about names/operators that start with Unicode + -- characters? + -- Exports beginning with '_' can be listed near the end, + -- presumably they're not as important... but would be listed + -- with non-split index! + initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_" + + do_sub_index this_ix c + = unless (null index_part) $ + writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) + where + html = indexPage True (Just c) 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,_) = comparing (map toUpper) n1 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 (++))) + (concatMap getIfaceIndex ifaces) + + getIfaceIndex iface = + [ (getOccString name + , Map.fromList [(name, [(mdl, name `Set.member` visible)])]) + | name <- instExports iface ] + where + mdl = instMod iface + visible = Set.fromList (instVisibleExports iface) + + indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable + indexElt (str, entities) = + case Map.toAscList entities of + [(nm,entries)] -> + td ! [ theclass "src" ] << toHtml str <-> + indexLinks nm entries + many_entities -> + td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </> + aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities) + + doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable + doAnnotatedEntity (j,(nm,entries)) + = td ! [ theclass "alt" ] << + 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 = + td ! [ theclass "module" ] << + hsep (punctuate comma + [ if visible then + linkId mdl (Just nm) << toHtml (moduleString mdl) + else + toHtml (moduleString mdl) + | (mdl, visible) <- entries ]) + + +-------------------------------------------------------------------------------- +-- * Generate the HTML page for a module +-------------------------------------------------------------------------------- + + +ppHtmlModule + :: FilePath -> String -> Themes + -> SourceURLs -> WikiURLs + -> Maybe String -> Maybe String -> Bool -> QualOption + -> Bool -> Interface -> IO () +ppHtmlModule odir doctitle themes + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode qual debug iface = do + let + mdl = ifaceMod iface + aliases = ifaceModuleAliases iface + mdl_str = moduleString mdl + real_qual = makeModuleQual qual aliases mdl + html = + headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++ + bodyHtml doctitle (Just iface) + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url << [ + divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)), + ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual + ] + + createDirectoryIfMissing True odir + writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) + ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug + +ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes + -> Interface -> Bool -> Qualification -> Bool -> IO () +ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do + let mdl = ifaceMod iface + html = + headHtml (moduleString mdl) Nothing themes +++ + miniBody << + (divModuleHeader << sectionName << moduleString mdl +++ + miniSynopsis mdl iface unicode qual) + createDirectoryIfMissing True odir + writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html) + + +ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html +ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual + = ppModuleContents qual exports +++ + description +++ + synopsis +++ + divInterface (maybe_doc_hdr +++ bdy) + where + exports = numberSectionHeadings (ifaceRnExportItems iface) + + -- todo: if something has only sub-docs, or fn-args-docs, should + -- it be measured here and thus prevent omitting the synopsis? + has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning + has_doc (ExportNoDecl _ _) = False + has_doc (ExportModule _) = False + has_doc _ = True + + no_doc_at_all = not (any has_doc exports) + + description | isNoHtml doc = doc + | otherwise = divDescription $ sectionName << "Description" +++ doc + where doc = docSection qual (ifaceRnDoc iface) + + -- omit the synopsis if there are no documentation annotations at all + synopsis + | no_doc_at_all = noHtml + | otherwise + = divSynposis $ + paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ + shortDeclList ( + mapMaybe (processExport True linksInfo unicode qual) exports + ) ! (collapseSection "syn" False "" ++ collapseToggle "syn") + + -- if the documentation doesn't begin with a section header, then + -- add one ("Documentation"). + maybe_doc_hdr + = case exports of + [] -> noHtml + ExportGroup {} : _ -> noHtml + _ -> h1 << "Documentation" + + bdy = + foldr (+++) noHtml $ + mapMaybe (processExport False linksInfo unicode qual) exports + + linksInfo = (maybe_source_url, maybe_wiki_url) + + +miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html +miniSynopsis mdl iface unicode qual = + divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports + where + exports = numberSectionHeadings (ifaceRnExportItems iface) + + +processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName + -> [Html] +processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } = + ((divTopDecl <<).(declElem <<)) <$> case decl0 of + TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of + (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual] + (DataDecl{}) -> [keyword "data" <+> b] + (SynDecl{}) -> [keyword "type" <+> b] + (ClassDecl {}) -> [keyword "class" <+> b] + _ -> [] + SigD (TypeSig lnames (L _ _)) -> + map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames + _ -> [] +processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = + [groupTag lvl << docToHtml qual txt] +processForMiniSynopsis _ _ _ _ = [] + + +ppNameMini :: Notation -> Module -> OccName -> Html +ppNameMini notation mdl nm = + anchor ! [ href (moduleNameUrl mdl nm) + , target mainFrameName ] + << ppBinder' notation nm + + +ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html +ppTyClBinderWithVarsMini mdl decl = + let n = tcdName decl + ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above + in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName + + +ppModuleContents :: Qualification -> [ExportItem DocName] -> Html +ppModuleContents qual exports + | null sections = noHtml + | otherwise = contentsDiv + where + contentsDiv = divTableOfContents << ( + sectionName << "Contents" +++ + unordList sections) + + (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 = linkedAnchor (groupId id0) + << docToHtmlNoAnchors qual 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 = unordList 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 = go 1 + 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 -> Bool -> Qualification + -> ExportItem DocName -> Maybe Html +processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances +processExport summary _ _ qual (ExportGroup lev id0 doc) + = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc +processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice) + = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual +processExport summary _ _ qual (ExportNoDecl y []) + = processDeclOneLiner summary $ ppDocName qual Prefix True y +processExport summary _ _ qual (ExportNoDecl y subs) + = processDeclOneLiner summary $ + ppDocName qual Prefix True y + +++ parenList (map (ppDocName qual Prefix True) subs) +processExport summary _ _ qual (ExportDoc doc) + = nothingIf summary $ docSection_ qual doc +processExport summary _ _ _ (ExportModule mdl) + = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl + + +nothingIf :: Bool -> a -> Maybe a +nothingIf True _ = Nothing +nothingIf False a = Just a + + +processDecl :: Bool -> Html -> Maybe Html +processDecl True = Just +processDecl False = Just . divTopDecl + + +processDeclOneLiner :: Bool -> Html -> Maybe Html +processDeclOneLiner True = Just +processDeclOneLiner False = Just . divTopDecl . declElem + +groupHeading :: Int -> String -> Html -> Html +groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)] + +groupTag :: Int -> Html -> Html +groupTag lev + | lev == 1 = h1 + | lev == 2 = h2 + | lev == 3 = h3 + | otherwise = h4 diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs new file mode 100644 index 00000000..8884f69f --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -0,0 +1,885 @@ +{-# LANGUAGE TransformListComp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Decl +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Decl ( + ppDecl, + + ppTyName, ppTyFamHeader, ppTypeApp, + tyvarNames +) where + + +import Haddock.Backends.Xhtml.DocMarkup +import Haddock.Backends.Xhtml.Layout +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils +import Haddock.GhcUtils +import Haddock.Types +import Haddock.Doc (combineDocumentation) + +import Data.List ( intersperse, sort ) +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid ( mempty ) +import Text.XHtml hiding ( name, title, p, quote ) + +import GHC +import GHC.Exts +import Name +import BooleanFormula + +ppDecl :: Bool -> LinksInfo -> LHsDecl DocName + -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] + -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html +ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of + TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual + TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual + TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual + SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual + SigD (PatSynSig lname args ty prov req) -> + ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual + ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual + InstD _ -> noHtml + _ -> error "declaration not supported by ppDecl" + + +ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] -> + Splice -> Unicode -> Qualification -> Html +ppLFunSig summary links loc doc lnames lty fixities splice unicode qual = + ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities + splice unicode qual + +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + [DocName] -> HsType DocName -> [(DocName, Fixity)] -> + Splice -> Unicode -> Qualification -> Html +ppFunSig summary links loc doc docnames typ fixities splice unicode qual = + ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ) + splice unicode qual + where + pp_typ = ppType unicode qual typ + +ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + Located DocName -> + HsPatSynDetails (LHsType DocName) -> LHsType DocName -> + LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] -> + Splice -> Unicode -> Qualification -> Html +ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual = + ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) + (unLoc prov) (unLoc req) fixities splice unicode qual + +ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + DocName -> + HsPatSynDetails (HsType DocName) -> HsType DocName -> + HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] -> + Splice -> Unicode -> Qualification -> Html +ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities + splice unicode qual + | summary = pref1 + | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual) + +++ docSection qual doc + where + pref1 = hsep [ toHtml "pattern" + , pp_cxt prov + , pp_head + , dcolon unicode + , pp_cxt req + , ppType unicode qual typ + ] + pp_head = case args of + PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs + InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right] + + pp_cxt cxt = ppContext cxt unicode qual + pp_type = ppParendType unicode qual + + occname = nameOccName . getName $ docname + +ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> + [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) -> + Splice -> Unicode -> Qualification -> Html +ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) + splice unicode qual = + ppTypeOrFunSig summary links loc docnames typ doc + ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode + , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames + , dcolon unicode + ) + splice unicode qual + where + occnames = map (nameOccName . getName) docnames + addFixities html + | summary = html + | otherwise = html <+> ppFixities fixities qual + + +ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName + -> DocForDecl DocName -> (Html, Html, Html) + -> Splice -> Unicode -> Qualification -> Html +ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual + | summary = pref1 + | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection qual doc + | otherwise = topDeclElem links loc splice docnames pref2 +++ + subArguments qual (do_args 0 sep typ) +++ docSection qual doc + where + argDoc n = Map.lookup n argDocs + + do_largs n leader (L _ t) = do_args n leader t + do_args :: Int -> Html -> HsType DocName -> [SubDecl] + do_args n leader (HsForAllTy Explicit tvs lctxt ltype) + = (leader <+> + hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> + ppLContextNoArrow lctxt unicode qual, + Nothing, []) + : do_largs n (darrow unicode) ltype + do_args n leader (HsForAllTy Implicit _ lctxt ltype) + | not (null (unLoc lctxt)) + = (leader <+> ppLContextNoArrow lctxt unicode qual, + Nothing, []) + : do_largs n (darrow unicode) ltype + -- if we're not showing any 'forall' or class constraints or + -- anything, skip having an empty line for the context. + | otherwise + = do_largs n leader ltype + do_args n leader (HsFunTy lt r) + = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) + : do_largs (n+1) (arrow unicode) r + do_args n leader t + = [(leader <+> ppType unicode qual t, argDoc n, [])] + +ppFixities :: [(DocName, Fixity)] -> Qualification -> Html +ppFixities [] _ = noHtml +ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge + where + ppFix (ns, p, d) = thespan ! [theclass "fixity"] << + (toHtml d <+> toHtml (show p) <+> ppNames ns) + + ppDir InfixR = "infixr" + ppDir InfixL = "infixl" + ppDir InfixN = "infix" + + ppNames = case fs of + _:[] -> const noHtml -- Don't display names for fixities on single names + _ -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False) + + uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs + , let d' = ppDir d + , then group by Down (p,d') using groupWith ] + + rightEdge = thespan ! [theclass "rightedge"] << noHtml + + +ppTyVars :: LHsTyVarBndrs DocName -> [Html] +ppTyVars tvs = map ppTyName (tyvarNames tvs) + + +tyvarNames :: LHsTyVarBndrs DocName -> [Name] +tyvarNames = map getName . hsLTyVarNames + + +ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName + -> ForeignDecl DocName -> [(DocName, Fixity)] + -> Splice -> Unicode -> Qualification -> Html +ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities + splice unicode qual + = ppFunSig summary links loc doc [name] typ fixities splice unicode qual +ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" + + +-- we skip type patterns for now +ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan + -> DocForDecl DocName -> TyClDecl DocName + -> Splice -> Unicode -> Qualification -> Html +ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars + , tcdRhs = ltype }) + splice unicode qual + = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc + (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) + splice unicode qual + where + hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) + full = hdr <+> equals <+> ppLType unicode qual ltype + occ = nameOccName . getName $ name + fixs + | summary = noHtml + | otherwise = ppFixities fixities qual +ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" + + +ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html +ppTypeSig summary nms pp_ty unicode = + concatHtml htmlNames <+> dcolon unicode <+> pp_ty + where + htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms + + +ppTyName :: Name -> Html +ppTyName = ppName Prefix + + +-------------------------------------------------------------------------------- +-- * Type families +-------------------------------------------------------------------------------- + + +ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName + -> Unicode -> Qualification -> Html +ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info + , fdKindSig = mkind }) + unicode qual = + (case info of + OpenTypeFamily + | associated -> keyword "type" + | otherwise -> keyword "type family" + DataFamily + | associated -> keyword "data" + | otherwise -> keyword "data family" + ClosedTypeFamily _ + -> keyword "type family" + ) <+> + + ppFamDeclBinderWithVars summary d <+> + + (case mkind of + Just kind -> dcolon unicode <+> ppLKind unicode qual kind + Nothing -> noHtml + ) + +ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> + [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> + FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html +ppTyFam summary associated links instances fixities loc doc decl splice unicode qual + + | summary = ppTyFamHeader True associated decl unicode qual + | otherwise = header_ +++ docSection qual doc +++ instancesBit + + where + docname = unLoc $ fdLName decl + + header_ = topDeclElem links loc splice [docname] $ + ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual + + instancesBit + | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl + , not summary + = subEquations qual $ map (ppTyFamEqn . unLoc) eqns + + | otherwise + = ppInstances instances docname unicode qual + + -- Individual equation of a closed type family + ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs + , tfie_pats = HsWB { hswb_cts = ts }} + = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual + <+> equals <+> ppType unicode qual (unLoc rhs) + , Nothing, [] ) + +-------------------------------------------------------------------------------- +-- * Associated Types +-------------------------------------------------------------------------------- + + +ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName + -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html +ppAssocType summ links doc (L loc decl) fixities splice unicode qual = + ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual + + +-------------------------------------------------------------------------------- +-- * TyClDecl helpers +-------------------------------------------------------------------------------- + +-- | Print a type family and its variables +ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html +ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = + ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs) + +-- | Print a newtype / data binder and its variables +ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html +ppDataBinderWithVars summ decl = + ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl) + +-------------------------------------------------------------------------------- +-- * Type applications +-------------------------------------------------------------------------------- + + +-- | Print an application of a DocName and two lists of HsTypes (kinds, types) +ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] + -> Unicode -> Qualification -> Html +ppAppNameTypes n ks ts unicode qual = + ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual) + + +-- | Print an application of a DocName and a list of Names +ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html +ppAppDocNameNames summ n ns = + ppTypeApp n [] ns ppDN ppTyName + where + ppDN notation = ppBinderFixity notation summ . nameOccName . getName + ppBinderFixity Infix = ppBinderInfix + ppBinderFixity _ = ppBinder + +-- | General printing of type applications +ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html +ppTypeApp n [] (t1:t2:rest) ppDN ppT + | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) + | operator = opApp + where + operator = isNameSym . getName $ n + opApp = ppT t1 <+> ppDN Infix n <+> ppT t2 + +ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts) + + +------------------------------------------------------------------------------- +-- * Contexts +------------------------------------------------------------------------------- + + +ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode + -> Qualification -> Html +ppLContext = ppContext . unLoc +ppLContextNoArrow = ppContextNoArrow . unLoc + + +ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html +ppContextNoArrow [] _ _ = noHtml +ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual + + +ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html +ppContextNoLocs [] _ _ = noHtml +ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual + <+> darrow unicode + + +ppContext :: HsContext DocName -> Unicode -> Qualification -> Html +ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual + + +ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html +ppHsContext [] _ _ = noHtml +ppHsContext [p] unicode qual = ppCtxType unicode qual p +ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) + + +------------------------------------------------------------------------------- +-- * Class declarations +------------------------------------------------------------------------------- + + +ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName + -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] + -> Unicode -> Qualification -> Html +ppClassHdr summ lctxt n tvs fds unicode qual = + keyword "class" + <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) + <+> ppAppDocNameNames summ n (tyvarNames tvs) + <+> ppFds fds unicode qual + + +ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html +ppFds fds unicode qual = + if null fds then noHtml else + char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) + where + fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 + ppVars = hsep . map (ppDocName qual Prefix True) + +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan + -> [(DocName, DocForDecl DocName)] + -> Splice -> Unicode -> Qualification -> Html +ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs + , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc + subdocs splice unicode qual = + if not (any isVanillaLSig sigs) && null ats + then (if summary then id else topDeclElem links loc splice [nm]) hdr + else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") + +++ shortSubDecls False + ( + [ ppAssocType summary links doc at [] splice unicode qual | at <- ats + , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ + + -- ToDo: add associated type defaults + + [ ppFunSig summary links loc doc names typ [] splice unicode qual + | L _ (TypeSig lnames (L _ typ)) <- sigs + , let doc = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames ] + -- FIXME: is taking just the first name ok? Is it possible that + -- there are different subdocs for different names in a single + -- type signature? + ) + where + hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual + nm = unLoc lname +ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + + + +ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] + -> SrcSpan -> Documentation DocName + -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName + -> Splice -> Unicode -> Qualification -> Html +ppClassDecl summary links instances fixities loc d subdocs + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars + , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) + splice unicode qual + | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual + | otherwise = classheader +++ docSection qual d + +++ minimalBit +++ atBit +++ methodBit +++ instancesBit + where + classheader + | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) + | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) + + -- Only the fixity relevant to the class header + fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual + + nm = tcdName decl + + hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds + + -- ToDo: add assocatied typ defaults + atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual + | at <- ats + , let n = unL . fdLName $ unL at + doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs + subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] + + methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual + | L _ (TypeSig lnames (L _ typ)) <- lsigs + , let doc = lookupAnySubdoc (head names) subdocs + subfixs = [ f | n <- names + , f@(n',_) <- fixities + , n == n' ] + names = map unLoc lnames ] + -- FIXME: is taking just the first name ok? Is it possible that + -- there are different subdocs for different names in a single + -- type signature? + + minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of + -- Miminal complete definition = every shown method + And xs : _ | sort [getName n | Var (L _ n) <- xs] == + sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns] + -> noHtml + + -- Minimal complete definition = the only shown method + Var (L _ n) : _ | [getName n] == + [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] + -> noHtml + + -- Minimal complete definition = nothing + And [] : _ -> subMinimal $ toHtml "Nothing" + + m : _ -> subMinimal $ ppMinimal False m + _ -> noHtml + + ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n + ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs + ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs + where wrap | p = parens | otherwise = id + + instancesBit = ppInstances instances nm unicode qual + +ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + + +ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html +ppInstances instances baseName unicode qual + = subInstances qual instName (map instDecl instances) + where + instName = getOccString $ getName baseName + instDecl :: DocInstance DocName -> SubDecl + instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, []) + instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual + <+> ppAppNameTypes n ks ts unicode qual + instHead (n, ks, ts, TypeInst rhs) = keyword "type" + <+> ppAppNameTypes n ks ts unicode qual + <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs + instHead (n, ks, ts, DataInst dd) = keyword "data" + <+> ppAppNameTypes n ks ts unicode qual + <+> ppShortDataDecl False True dd unicode qual + +lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 +lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n + + +------------------------------------------------------------------------------- +-- * Data & newtype declarations +------------------------------------------------------------------------------- + + +-- TODO: print contexts +ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html +ppShortDataDecl summary dataInst dataDecl unicode qual + + | [] <- cons = dataHeader + + | [lcon] <- cons, ResTyH98 <- resTy, + (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual + = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot + + | ResTyH98 <- resTy = dataHeader + +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) + + | otherwise = (dataHeader <+> keyword "where") + +++ shortSubDecls dataInst (map doGADTConstr cons) + + where + dataHeader + | dataInst = noHtml + | otherwise = ppDataHeader summary dataDecl unicode qual + doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual + doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual + + cons = dd_cons (tcdDataDefn dataDecl) + resTy = (con_res . unLoc . head) cons + + +ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> + [(DocName, DocForDecl DocName)] -> + SrcSpan -> Documentation DocName -> TyClDecl DocName -> + Splice -> Unicode -> Qualification -> Html +ppDataDecl summary links instances fixities subdocs loc doc dataDecl + splice unicode qual + + | summary = ppShortDataDecl summary False dataDecl unicode qual + | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit + + where + docname = tcdName dataDecl + cons = dd_cons (tcdDataDefn dataDecl) + resTy = (con_res . unLoc . head) cons + + header_ = topDeclElem links loc splice [docname] $ + ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix + + fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual + + whereBit + | null cons = noHtml + | otherwise = case resTy of + ResTyGADT _ -> keyword "where" + _ -> noHtml + + constrBit = subConstructors qual + [ ppSideBySideConstr subdocs subfixs unicode qual c + | c <- cons + , let subfixs = filter (\(n,_) -> n == unLoc (con_name (unLoc c))) fixities + ] + + instancesBit = ppInstances instances docname unicode qual + + + +ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html +ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot + where + (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual + + +-- returns three pieces: header, body, footer so that header & footer can be +-- incorporated into the declaration +ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html) +ppShortConstrParts summary dataInst con unicode qual = case con_res con of + ResTyH98 -> case con_details con of + PrefixCon args -> + (header_ unicode qual +++ hsep (ppBinder summary occ + : map (ppLParendType unicode qual) args), noHtml, noHtml) + RecCon fields -> + (header_ unicode qual +++ ppBinder summary occ <+> char '{', + doRecordFields fields, + char '}') + InfixCon arg1 arg2 -> + (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1, + ppBinderInfix summary occ, ppLParendType unicode qual arg2], + noHtml, noHtml) + + ResTyGADT resTy -> case con_details con of + -- prefix & infix could use hsConDeclArgTys if it seemed to + -- simplify the code. + PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml) + -- display GADT records with the new syntax, + -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) + -- (except each field gets its own line in docs, to match + -- non-GADT records) + RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+> + ppForAll forall_ ltvs lcontext unicode qual <+> char '{', + doRecordFields fields, + char '}' <+> arrow unicode <+> ppLType unicode qual resTy) + InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) + + where + doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) fields) + doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [ + ppForAll forall_ ltvs lcontext unicode qual, + ppLType unicode qual (foldr mkFunTy resTy args) ] + + header_ = ppConstrHdr forall_ tyVars context + occ = nameOccName . getName . unLoc . 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 is for (non-GADT) existentials constructors' syntax +ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode + -> Qualification -> Html +ppConstrHdr forall_ tvs ctxt unicode qual + = (if null tvs then noHtml else ppForall) + +++ + (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual + <+> darrow unicode +++ toHtml " ") + where + ppForall = case forall_ of + Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " + Implicit -> noHtml + + +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] + -> Unicode -> Qualification -> LConDecl DocName -> SubDecl +ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) + where + decl = case con_res con of + ResTyH98 -> case con_details con of + PrefixCon args -> + hsep ((header_ +++ ppBinder False occ) + : map (ppLParendType unicode qual) args) + <+> fixity + + RecCon _ -> header_ +++ ppBinder False occ <+> fixity + + InfixCon arg1 arg2 -> + hsep [header_ +++ ppLParendType unicode qual arg1, + ppBinderInfix False occ, + ppLParendType unicode qual arg2] + <+> fixity + + ResTyGADT resTy -> case con_details con of + -- prefix & infix could also use hsConDeclArgTys if it seemed to + -- simplify the code. + PrefixCon args -> doGADTCon args resTy + cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy + InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + + fieldPart = case con_details con of + RecCon fields -> [doRecordFields fields] + _ -> [] + + doRecordFields fields = subFields qual + (map (ppSideBySideField subdocs unicode qual) fields) + doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html + doGADTCon args resTy = ppBinder False occ <+> dcolon unicode + <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual, + ppLType unicode qual (foldr mkFunTy resTy args) ] + <+> fixity + + fixity = ppFixities fixities qual + header_ = ppConstrHdr forall_ tyVars context unicode qual + occ = nameOccName . getName . unLoc . con_name $ con + ltvs = con_qvars con + tyVars = tyvarNames (con_qvars con) + context = unLoc (con_cxt con) + forall_ = con_explicit con + -- don't use "con_doc con", in case it's reconstructed from a .hi file, + -- or also because we want Haddock to do the doc-parsing, not GHC. + mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst + mkFunTy a b = noLoc (HsFunTy a b) + + +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification + -> ConDeclField DocName -> SubDecl +ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) = + (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype, + mbDoc, + []) + where + -- don't use cd_fld_doc for same reason we don't use con_doc above + mbDoc = lookup name subdocs >>= combineDocumentation . fst + + +ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html +ppShortField summary unicode qual (ConDeclField (L _ name) ltype _) + = ppBinder summary (nameOccName . getName $ name) + <+> dcolon unicode <+> ppLType unicode qual ltype + + +-- | Print the LHS of a data\/newtype declaration. +-- Currently doesn't handle 'data instance' decls or kind signatures +ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html +ppDataHeader summary decl@(DataDecl { tcdDataDefn = + HsDataDefn { dd_ND = nd + , dd_ctxt = ctxt + , dd_kindSig = ks } }) + unicode qual + = -- newtype or data + (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) + <+> + -- context + ppLContext ctxt unicode qual <+> + -- T a b c ..., or a :+: b + ppDataBinderWithVars summary decl + <+> case ks of + Nothing -> mempty + Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x + +ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" + +-------------------------------------------------------------------------------- +-- * Types and contexts +-------------------------------------------------------------------------------- + + +ppBang :: HsBang -> Html +ppBang HsNoBang = noHtml +ppBang _ = toHtml "!" -- Unpacked args is an implementation detail, + -- so we just show the strictness annotation + + +tupleParens :: HsTupleSort -> [Html] -> Html +tupleParens HsUnboxedTuple = ubxParenList +tupleParens _ = parenList + + +-------------------------------------------------------------------------------- +-- * Rendering of HsType +-------------------------------------------------------------------------------- + + +pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int + +pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC +pREC_CTX = 1 :: Int -- Used for single contexts, eg. ctx => type + -- (as opposed to (ctx1, ctx2) => type) +pREC_FUN = 2 :: Int -- btype in ParseIface.y in GHC + -- Used for LH arg of (->) +pREC_OP = 3 :: Int -- Used for arg of any infix operator + -- (we don't keep their fixities around) +pREC_CON = 4 :: 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 + + +ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification + -> Located (HsType DocName) -> Html +ppLType unicode qual y = ppType unicode qual (unLoc y) +ppLParendType unicode qual y = ppParendType unicode qual (unLoc y) +ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y) + + +ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification + -> HsType DocName -> Html +ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual +ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual +ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual +ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual + +ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html +ppLKind unicode qual y = ppKind unicode qual (unLoc y) + +ppKind :: Unicode -> Qualification -> HsKind DocName -> Html +ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual + +-- Drop top-level for-all type variables in user style +-- since they are implicit in Haskell + +ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName + -> Located (HsContext DocName) -> Unicode -> Qualification -> Html +ppForAll expl tvs cxt unicode qual + | show_forall = forall_part <+> ppLContext cxt unicode qual + | otherwise = ppLContext cxt unicode qual + where + show_forall = not (null (hsQTvBndrs tvs)) && is_explicit + is_explicit = case expl of {Explicit -> True; Implicit -> False} + forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot + + +ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html +ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) + + +ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html +ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual] + +-- UnicodeSyntax alternatives +ppr_mono_ty _ (HsTyVar name) True _ + | getOccString (getName name) == "*" = toHtml "★" + | getOccString (getName name) == "(->)" = toHtml "(→)" + +ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty +ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q +ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) +ppr_mono_ty _ (HsKindSig ty kind) u q = + parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind) +ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) +ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q) +ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = + maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q +ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" +ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys +ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy" + +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual + = maybeParen ctxt_prec pREC_CTX $ + ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual + +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual + = maybeParen ctxt_prec pREC_CON $ + hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] + +ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual + where + ppr_op = ppLDocName qual Infix op + +ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual +-- = parens (ppr_mono_lty pREC_TOP ty) + = ppr_mono_lty ctxt_prec ty unicode qual + +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual + = ppr_mono_lty ctxt_prec ty unicode qual + +ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n + +ppr_tylit :: HsTyLit -> Html +ppr_tylit (HsNumTy n) = toHtml (show n) +ppr_tylit (HsStrTy s) = toHtml (show s) + + +ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html +ppr_fun_ty ctxt_prec ty1 ty2 unicode qual + = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual + p2 = ppr_mono_lty pREC_TOP ty2 unicode qual + in + maybeParen ctxt_prec pREC_FUN $ + hsep [p1, arrow unicode <+> p2] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs new file mode 100644 index 00000000..5e27d9b0 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -0,0 +1,143 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.DocMarkup +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.DocMarkup ( + docToHtml, + rdrDocToHtml, + origDocToHtml, + docToHtmlNoAnchors, + + docElement, docSection, docSection_, +) where + +import Control.Applicative ((<$>)) + +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Utils +import Haddock.Types +import Haddock.Utils +import Haddock.Doc (combineDocumentation) + +import Text.XHtml hiding ( name, p, quote ) +import Data.Maybe (fromMaybe) + +import GHC + +parHtmlMarkup :: Qualification -> Bool + -> (Bool -> a -> Html) -> DocMarkup a Html +parHtmlMarkup qual insertAnchors ppId = Markup { + markupEmpty = noHtml, + markupString = toHtml, + markupParagraph = paragraph, + markupAppend = (+++), + markupIdentifier = thecode . ppId insertAnchors, + markupIdentifierUnchecked = thecode . ppUncheckedLink qual, + markupModule = \m -> let (mdl,ref) = break (=='#') m + -- Accomodate for old style + -- foo\#bar anchors + mdl' = case reverse mdl of + '\\':_ -> init mdl + _ -> mdl + in ppModuleRef (mkModuleName mdl') ref, + markupWarning = thediv ! [theclass "warning"], + markupEmphasis = emphasize, + markupBold = strong, + markupMonospaced = thecode, + markupUnorderedList = unordList, + markupOrderedList = ordList, + markupDefList = defList, + markupCodeBlock = pre, + markupHyperlink = \(Hyperlink url mLabel) + -> if insertAnchors + then anchor ! [href url] + << fromMaybe url mLabel + else toHtml $ fromMaybe url mLabel, + markupAName = \aname -> namedAnchor aname << "", + markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), + markupProperty = pre . toHtml, + markupExample = examplesToHtml, + markupHeader = \(Header l t) -> makeHeader l t + } + where + makeHeader :: Int -> Html -> Html + makeHeader 1 mkup = h1 mkup + makeHeader 2 mkup = h2 mkup + makeHeader 3 mkup = h3 mkup + makeHeader 4 mkup = h4 mkup + makeHeader 5 mkup = h5 mkup + makeHeader 6 mkup = h6 mkup + makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!" + + + examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"] + + exampleToHtml (Example expression result) = htmlExample + where + htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result) + htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"] + htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] + + +-- If the doc is a single paragraph, don't surround it with <P> (this causes +-- ugly extra whitespace with some browsers). FIXME: Does this still apply? +docToHtml :: Qualification -> Doc DocName -> Html +docToHtml qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual True (ppDocName qual Raw) + +-- | Same as 'docToHtml' but it doesn't insert the 'anchor' element +-- in links. This is used to generate the Contents box elements. +docToHtmlNoAnchors :: Qualification -> Doc DocName -> Html +docToHtmlNoAnchors qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual False (ppDocName qual Raw) + +origDocToHtml :: Qualification -> Doc Name -> Html +origDocToHtml qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual True (const $ ppName Raw) + + +rdrDocToHtml :: Qualification -> Doc RdrName -> Html +rdrDocToHtml qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual True (const ppRdrName) + + +docElement :: (Html -> Html) -> Html -> Html +docElement el content_ = + if isNoHtml content_ + then el ! [theclass "doc empty"] << spaceHtml + else el ! [theclass "doc"] << content_ + + +docSection :: Qualification -> Documentation DocName -> Html +docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation + + +docSection_ :: Qualification -> Doc DocName -> Html +docSection_ qual = (docElement thediv <<) . docToHtml qual + + +cleanup :: Doc a -> Doc a +cleanup = markup fmtUnParagraphLists + where + -- If there is a single paragraph, then surrounding it with <P>..</P> + -- 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. We don't do this in code blocks as it eliminates line breaks. + unParagraph :: Doc a -> Doc a + unParagraph (DocParagraph d) = d + unParagraph doc = doc + + fmtUnParagraphLists :: DocMarkup a (Doc a) + fmtUnParagraphLists = idMarkup { + markupUnorderedList = DocUnorderedList . map unParagraph, + markupOrderedList = DocOrderedList . map unParagraph + } diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs new file mode 100644 index 00000000..e84a57b3 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -0,0 +1,235 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Layout +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Layout ( + miniBody, + + divPackageHeader, divContent, divModuleHeader, divFooter, + divTableOfContents, divDescription, divSynposis, divInterface, + divIndex, divAlphabet, divModuleList, + + sectionName, + nonEmptySectionName, + + shortDeclList, + shortSubDecls, + + divTopDecl, + + SubDecl, + subArguments, + subAssociatedTypes, + subConstructors, + subEquations, + subFields, + subInstances, + subMethods, + subMinimal, + + topDeclElem, declElem, +) where + + +import Haddock.Backends.Xhtml.DocMarkup +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils +import Haddock.Types +import Haddock.Utils (makeAnchorId) + +import qualified Data.Map as Map +import Text.XHtml hiding ( name, title, p, quote ) + +import FastString ( unpackFS ) +import GHC + + +-------------------------------------------------------------------------------- +-- * Sections of the document +-------------------------------------------------------------------------------- + + +miniBody :: Html -> Html +miniBody = body ! [identifier "mini"] + + +sectionDiv :: String -> Html -> Html +sectionDiv i = thediv ! [identifier i] + + +sectionName :: Html -> Html +sectionName = paragraph ! [theclass "caption"] + + +-- | Make an element that always has at least something (a non-breaking space). +-- If it would have otherwise been empty, then give it the class ".empty". +nonEmptySectionName :: Html -> Html +nonEmptySectionName c + | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml + | otherwise = paragraph ! [theclass "caption"] $ c + + +divPackageHeader, divContent, divModuleHeader, divFooter, + divTableOfContents, divDescription, divSynposis, divInterface, + divIndex, divAlphabet, divModuleList + :: Html -> Html + +divPackageHeader = sectionDiv "package-header" +divContent = sectionDiv "content" +divModuleHeader = sectionDiv "module-header" +divFooter = sectionDiv "footer" +divTableOfContents = sectionDiv "table-of-contents" +divDescription = sectionDiv "description" +divSynposis = sectionDiv "synopsis" +divInterface = sectionDiv "interface" +divIndex = sectionDiv "index" +divAlphabet = sectionDiv "alphabet" +divModuleList = sectionDiv "module-list" + + +-------------------------------------------------------------------------------- +-- * Declaration containers +-------------------------------------------------------------------------------- + + +shortDeclList :: [Html] -> Html +shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items + + +shortSubDecls :: Bool -> [Html] -> Html +shortSubDecls inst items = ulist ! [theclass c] << map (i <<) items + where i | inst = li ! [theclass "inst"] + | otherwise = li + c | inst = "inst" + | otherwise = "subs" + + +divTopDecl :: Html -> Html +divTopDecl = thediv ! [theclass "top"] + + +type SubDecl = (Html, Maybe (Doc DocName), [Html]) + + +divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html +divSubDecls cssClass captionName = maybe noHtml wrap + where + wrap = (subSection <<) . (subCaption +++) + subSection = thediv ! [theclass $ unwords ["subs", cssClass]] + subCaption = paragraph ! [theclass "caption"] << captionName + + +subDlist :: Qualification -> [SubDecl] -> Maybe Html +subDlist _ [] = Nothing +subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv + where + subEntry (decl, mdoc, subs) = + dterm ! [theclass "src"] << decl + +++ + docElement ddef << (fmap (docToHtml qual) mdoc +++ subs) + + clearDiv = thediv ! [ theclass "clear" ] << noHtml + + +subTable :: Qualification -> [SubDecl] -> Maybe Html +subTable _ [] = Nothing +subTable qual decls = Just $ table << aboves (concatMap subRow decls) + where + subRow (decl, mdoc, subs) = + (td ! [theclass "src"] << decl + <-> + docElement td << fmap (docToHtml qual) mdoc) + : map (cell . (td <<)) subs + + +subBlock :: [Html] -> Maybe Html +subBlock [] = Nothing +subBlock hs = Just $ toHtml hs + + +subArguments :: Qualification -> [SubDecl] -> Html +subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual + + +subAssociatedTypes :: [Html] -> Html +subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock + + +subConstructors :: Qualification -> [SubDecl] -> Html +subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual + + +subFields :: Qualification -> [SubDecl] -> Html +subFields qual = divSubDecls "fields" "Fields" . subDlist qual + + +subEquations :: Qualification -> [SubDecl] -> Html +subEquations qual = divSubDecls "equations" "Equations" . subTable qual + + +subInstances :: Qualification -> String -> [SubDecl] -> Html +subInstances qual nm = maybe noHtml wrap . instTable + where + wrap = (subSection <<) . (subCaption +++) + instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual + subSection = thediv ! [theclass "subs instances"] + subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" + id_ = makeAnchorId $ "i:" ++ nm + +subMethods :: [Html] -> Html +subMethods = divSubDecls "methods" "Methods" . subBlock + +subMinimal :: Html -> Html +subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem + + +-- a box for displaying code +declElem :: Html -> Html +declElem = paragraph ! [theclass "src"] + + +-- a box for top level documented names +-- it adds a source and wiki link at the right hand side of the box +topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html +topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html = + declElem << (html <+> srcLink <+> wikiLink) + where srcLink = let nameUrl = Map.lookup origPkg sourceMap + lineUrl = Map.lookup origPkg lineMap + mUrl | splice = lineUrl + -- Use the lineUrl as a backup + | otherwise = maybe lineUrl Just nameUrl in + case mUrl of + Nothing -> noHtml + Just url -> let url' = spliceURL (Just fname) (Just origMod) + (Just n) (Just loc) url + in anchor ! [href url', theclass "link"] << "Source" + + wikiLink = + case maybe_wiki_url of + Nothing -> noHtml + Just url -> let url' = spliceURL (Just fname) (Just mdl) + (Just n) (Just loc) url + in anchor ! [href url', theclass "link"] << "Comments" + + -- For source links, we want to point to the original module, + -- because only that will have the source. + -- TODO: do something about type instances. They will point to + -- the module defining the type family, which is wrong. + origMod = nameModule n + origPkg = modulePackageId origMod + + -- Name must be documented, otherwise we wouldn't get here + Documented n mdl = head names + -- FIXME: is it ok to simply take the first name? + + fname = case loc of + RealSrcSpan l -> unpackFS (srcSpanFile l) + UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs new file mode 100644 index 00000000..cf12da40 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -0,0 +1,171 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Names +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Names ( + ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, + ppBinder, ppBinderInfix, ppBinder', + ppModule, ppModuleRef, ppIPName, linkId, Notation(..) +) where + + +import Haddock.Backends.Xhtml.Utils +import Haddock.GhcUtils +import Haddock.Types +import Haddock.Utils + +import Text.XHtml hiding ( name, title, p, quote ) +import qualified Data.Map as M +import qualified Data.List as List + +import GHC +import Name +import RdrName +import FastString (unpackFS) + + +-- | Indicator of how to render a 'DocName' into 'Html' +data Notation = Raw -- ^ Render as-is. + | Infix -- ^ Render using infix notation. + | Prefix -- ^ Render using prefix notation. + deriving (Eq, Show) + +ppOccName :: OccName -> Html +ppOccName = toHtml . occNameString + + +ppRdrName :: RdrName -> Html +ppRdrName = ppOccName . rdrNameOcc + +ppIPName :: HsIPName -> Html +ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS + + +ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html +ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName + + +-- The Bool indicates if it is to be rendered in infix notation +ppLDocName :: Qualification -> Notation -> Located DocName -> Html +ppLDocName qual notation (L _ d) = ppDocName qual notation True d + +ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html +ppDocName qual notation insertAnchors docName = + case docName of + Documented name mdl -> + linkIdOcc mdl (Just (nameOccName name)) insertAnchors + << ppQualifyName qual notation name mdl + Undocumented name + | isExternalName name || isWiredInName name -> + ppQualifyName qual notation name (nameModule name) + | otherwise -> ppName notation name + +-- | Render a name depending on the selected qualification mode +ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html +ppQualifyName qual notation name mdl = + case qual of + NoQual -> ppName notation name + FullQual -> ppFullQualName notation mdl name + LocalQual localmdl -> + if moduleString mdl == moduleString localmdl + then ppName notation name + else ppFullQualName notation mdl name + RelativeQual localmdl -> + case List.stripPrefix (moduleString localmdl) (moduleString mdl) of + -- local, A.x -> x + Just [] -> ppName notation name + -- sub-module, A.B.x -> B.x + Just ('.':m) -> toHtml $ m ++ '.' : getOccString name + -- some module with same prefix, ABC.x -> ABC.x + Just _ -> ppFullQualName notation mdl name + -- some other module, D.x -> D.x + Nothing -> ppFullQualName notation mdl name + AliasedQual aliases localmdl -> + case (moduleString mdl == moduleString localmdl, + M.lookup mdl aliases) of + (False, Just alias) -> ppQualName notation alias name + _ -> ppName notation name + + +ppFullQualName :: Notation -> Module -> Name -> Html +ppFullQualName notation mdl name = wrapInfix notation (getOccName name) qname + where + qname = toHtml $ moduleString mdl ++ '.' : getOccString name + +ppQualName :: Notation -> ModuleName -> Name -> Html +ppQualName notation mdlName name = wrapInfix notation (getOccName name) qname + where + qname = toHtml $ moduleNameString mdlName ++ '.' : getOccString name + +ppName :: Notation -> Name -> Html +ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccString name) + + +ppBinder :: Bool -> OccName -> 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 n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n +ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"] + << ppBinder' Prefix n + +ppBinderInfix :: Bool -> OccName -> Html +ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n +ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"] + << ppBinder' Infix n + +ppBinder' :: Notation -> OccName -> Html +ppBinder' notation n = wrapInfix notation n $ ppOccName n + +wrapInfix :: Notation -> OccName -> Html -> Html +wrapInfix notation n = case notation of + Infix | is_star_kind -> id + | not is_sym -> quote + Prefix | is_star_kind -> id + | is_sym -> parens + _ -> id + where + is_sym = isSymOcc n + is_star_kind = isTcOcc n && occNameString n == "*" + +linkId :: Module -> Maybe Name -> Html -> Html +linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) True + + +linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html +linkIdOcc mdl mbName insertAnchors = + if insertAnchors + then anchor ! [href url] + else id + where + url = case mbName of + Nothing -> moduleUrl mdl + Just name -> moduleNameUrl mdl name + + +linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html +linkIdOcc' mdl mbName = anchor ! [href url] + where + url = case mbName of + Nothing -> moduleHtmlFile' mdl + Just name -> moduleNameUrl' mdl name + + +ppModule :: Module -> Html +ppModule mdl = anchor ! [href (moduleUrl mdl)] + << toHtml (moduleString mdl) + + +ppModuleRef :: ModuleName -> String -> Html +ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] + << toHtml (moduleNameString mdl) + -- NB: The ref parameter already includes the '#'. + -- This function is only called from markupModule expanding a + -- DocModule, which doesn't seem to be ever be used. diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs new file mode 100644 index 00000000..79b093ec --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -0,0 +1,209 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Themes +-- Copyright : (c) Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Themes ( + Themes, + getThemes, + + cssFiles, styleSheet + ) + where + +import Haddock.Options + +import Control.Applicative +import Control.Monad (liftM) +import Data.Char (toLower) +import Data.Either (lefts, rights) +import Data.List (nub) +import Data.Maybe (isJust, listToMaybe) + +import System.Directory +import System.FilePath +import Text.XHtml hiding ( name, title, p, quote, (</>) ) +import qualified Text.XHtml as XHtml + + +-------------------------------------------------------------------------------- +-- * CSS Themes +-------------------------------------------------------------------------------- + +data Theme = Theme { + themeName :: String, + themeHref :: String, + themeFiles :: [FilePath] + } + +type Themes = [Theme] + +type PossibleTheme = Either String Theme +type PossibleThemes = Either String Themes + + +-- | Find a theme by name (case insensitive match) +findTheme :: String -> Themes -> Maybe Theme +findTheme s = listToMaybe . filter ((== ls).lower.themeName) + where lower = map toLower + ls = lower s + + +-- | Standard theme used by default +standardTheme :: FilePath -> IO PossibleThemes +standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir) + + +-- | Default themes that are part of Haddock; added with --default-themes +-- The first theme in this list is considered the standard theme. +-- Themes are "discovered" by scanning the html sub-dir of the libDir, +-- and looking for directories with the extension .theme or .std-theme. +-- The later is, obviously, the standard theme. +defaultThemes :: FilePath -> IO PossibleThemes +defaultThemes libDir = do + themeDirs <- getDirectoryItems (libDir </> "html") + themes <- mapM directoryTheme $ discoverThemes themeDirs + return $ sequenceEither themes + where + discoverThemes paths = + filterExt ".std-theme" paths ++ filterExt ".theme" paths + filterExt ext = filter ((== ext).takeExtension) + + +-- | Build a theme from a single .css file +singleFileTheme :: FilePath -> IO PossibleTheme +singleFileTheme path = + if isCssFilePath path + then retRight $ Theme name file [path] + else errMessage "File extension isn't .css" path + where + name = takeBaseName path + file = takeFileName path + + +-- | Build a theme from a directory +directoryTheme :: FilePath -> IO PossibleTheme +directoryTheme path = do + items <- getDirectoryItems path + case filter isCssFilePath items of + [cf] -> retRight $ Theme (takeBaseName path) (takeFileName cf) items + [] -> errMessage "No .css file in theme directory" path + _ -> errMessage "More than one .css file in theme directory" path + + +-- | Check if we have a built in theme +doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool +doesBuiltInExist pts s = fmap (either (const False) test) pts + where test = isJust . findTheme s + + +-- | Find a built in theme +builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme +builtInTheme pts s = either Left fetch <$> pts + where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s + + +-------------------------------------------------------------------------------- +-- * CSS Theme Arguments +-------------------------------------------------------------------------------- + +-- | Process input flags for CSS Theme arguments +getThemes :: FilePath -> [Flag] -> IO PossibleThemes +getThemes libDir flags = + liftM concatEither (mapM themeFlag flags) >>= someTheme + where + themeFlag :: Flag -> IO (Either String Themes) + themeFlag (Flag_CSS path) = (liftM . liftEither) (:[]) (theme path) + themeFlag (Flag_BuiltInThemes) = builtIns + themeFlag _ = retRight [] + + theme :: FilePath -> IO PossibleTheme + theme path = pick path + [(doesFileExist, singleFileTheme), + (doesDirectoryExist, directoryTheme), + (doesBuiltInExist builtIns, builtInTheme builtIns)] + "Theme not found" + + pick :: FilePath + -> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)] -> String + -> IO PossibleTheme + pick path [] msg = errMessage msg path + pick path ((test,build):opts) msg = do + pass <- test path + if pass then build path else pick path opts msg + + + someTheme :: Either String Themes -> IO (Either String Themes) + someTheme (Right []) = standardTheme libDir + someTheme est = return est + + builtIns = defaultThemes libDir + + +errMessage :: String -> FilePath -> IO (Either String a) +errMessage msg path = return (Left msg') + where msg' = "Error: " ++ msg ++ ": \"" ++ path ++ "\"\n" + + +retRight :: a -> IO (Either String a) +retRight = return . Right + + +-------------------------------------------------------------------------------- +-- * File Utilities +-------------------------------------------------------------------------------- + + +getDirectoryItems :: FilePath -> IO [FilePath] +getDirectoryItems path = + map (combine path) . filter notDot <$> getDirectoryContents path + where notDot s = s /= "." && s /= ".." + + +isCssFilePath :: FilePath -> Bool +isCssFilePath path = takeExtension path == ".css" + + +-------------------------------------------------------------------------------- +-- * Style Sheet Utilities +-------------------------------------------------------------------------------- + +cssFiles :: Themes -> [String] +cssFiles ts = nub $ concatMap themeFiles ts + + +styleSheet :: Themes -> Html +styleSheet ts = toHtml $ zipWith mkLink rels ts + where + rels = "stylesheet" : repeat "alternate stylesheet" + mkLink aRel t = + thelink + ! [ href (themeHref t), rel aRel, thetype "text/css", + XHtml.title (themeName t) + ] + << noHtml + +-------------------------------------------------------------------------------- +-- * Either Utilities +-------------------------------------------------------------------------------- + +-- These three routines are here because Haddock does not have access to the +-- Control.Monad.Error module which supplies the Functor and Monad instances +-- for Either String. + +sequenceEither :: [Either a b] -> Either a [b] +sequenceEither es = maybe (Right $ rights es) Left (listToMaybe (lefts es)) + + +liftEither :: (b -> c) -> Either a b -> Either a c +liftEither f = either Left (Right . f) + + +concatEither :: [Either a [b]] -> Either a [b] +concatEither = liftEither concat . sequenceEither + diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs new file mode 100644 index 00000000..122861c3 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Types +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Types ( + SourceURLs, WikiURLs, + LinksInfo, + Splice, + Unicode, +) where + + +import Data.Map +import GHC + + +-- the base, module and entity URLs for the source code and wiki links. +type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath, Map PackageId FilePath) +type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) + + +-- The URL for source and wiki links +type LinksInfo = (SourceURLs, WikiURLs) + +-- Whether something is a splice or not +type Splice = Bool + +-- Whether unicode syntax is to be used +type Unicode = Bool diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs new file mode 100644 index 00000000..cbcbbd6d --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -0,0 +1,218 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Util +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Utils ( + renderToString, + + namedAnchor, linkedAnchor, + spliceURL, + groupId, + + (<+>), (<=>), char, + keyword, punctuate, + + braces, brackets, pabrackets, parens, parenList, ubxParenList, + arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, + + hsep, vcat, + + collapseSection, collapseToggle, collapseControl, +) where + + +import Haddock.GhcUtils +import Haddock.Utils + +import Data.Maybe + +import Text.XHtml hiding ( name, title, p, quote ) +import qualified Text.XHtml as XHtml + +import GHC ( SrcSpan(..), srcSpanStartLine, Name ) +import Module ( Module ) +import Name ( getOccString, nameOccName, isValOcc ) + + +spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> + Maybe SrcSpan -> String -> String +spliceURL maybe_file maybe_mod maybe_name maybe_loc = run + where + file = fromMaybe "" maybe_file + mdl = case maybe_mod of + Nothing -> "" + Just m -> moduleString m + + (name, kind) = + case maybe_name of + Nothing -> ("","") + Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v") + | otherwise -> (escapeStr (getOccString n), "t") + + line = case maybe_loc of + Nothing -> "" + Just span_ -> + case span_ of + RealSrcSpan span__ -> + show $ srcSpanStartLine span__ + UnhelpfulSpan _ -> + error "spliceURL UnhelpfulSpan" + + run "" = "" + run ('%':'M':rest) = mdl ++ run rest + run ('%':'F':rest) = file ++ run rest + run ('%':'N':rest) = name ++ run rest + run ('%':'K':rest) = kind ++ run rest + run ('%':'L':rest) = line ++ run rest + run ('%':'%':rest) = '%' : run rest + + run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ 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) mdl ++ run rest + + run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) = + map (\x -> if x == '/' then c else x) file ++ run rest + + run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest + + run (c:rest) = c : run rest + + +renderToString :: Bool -> Html -> String +renderToString debug html + | debug = renderHtml html + | otherwise = showHtml html + + +hsep :: [Html] -> Html +hsep [] = noHtml +hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls + +-- | Concatenate a series of 'Html' values vertically, with linebreaks in between. +vcat :: [Html] -> Html +vcat [] = noHtml +vcat htmls = foldr1 (\a b -> a+++br+++b) htmls + + +infixr 8 <+> +(<+>) :: Html -> Html -> Html +a <+> b = a +++ sep +++ b + where + sep = if isNoHtml a || isNoHtml b then noHtml else toHtml " " + +-- | Join two 'Html' values together with a linebreak in between. +-- Has 'noHtml' as left identity. +infixr 8 <=> +(<=>) :: Html -> Html -> Html +a <=> b = a +++ sep +++ b + where + sep = if isNoHtml a then noHtml else br + + +keyword :: String -> Html +keyword s = thespan ! [theclass "keyword"] << toHtml s + + +equals, comma :: Html +equals = char '=' +comma = char ',' + + +char :: Char -> Html +char c = toHtml [c] + + +quote :: Html -> Html +quote h = char '`' +++ h +++ '`' + + +parens, brackets, pabrackets, 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 + + +parenList :: [Html] -> Html +parenList = parens . hsep . punctuate comma + + +ubxParenList :: [Html] -> Html +ubxParenList = ubxparens . hsep . punctuate comma + + +ubxparens :: Html -> Html +ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" + + +dcolon, arrow, darrow, forallSymbol :: Bool -> Html +dcolon unicode = toHtml (if unicode then "∷" else "::") +arrow unicode = toHtml (if unicode then "→" else "->") +darrow unicode = toHtml (if unicode then "⇒" else "=>") +forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" + + +dot :: Html +dot = toHtml "." + + +-- | Generate a named anchor +namedAnchor :: String -> Html -> Html +namedAnchor n = anchor ! [XHtml.name n] + + +linkedAnchor :: String -> Html -> Html +linkedAnchor n = anchor ! [href ('#':n)] + + +-- | generate an anchor identifier for a group +groupId :: String -> String +groupId g = makeAnchorId ("g:" ++ g) + +-- +-- A section of HTML which is collapsible. +-- + +-- | Attributes for an area that can be collapsed +collapseSection :: String -> Bool -> String -> [HtmlAttr] +collapseSection id_ state classes = [ identifier sid, theclass cs ] + where cs = unwords (words classes ++ [pick state "show" "hide"]) + sid = "section." ++ id_ + +-- | Attributes for an area that toggles a collapsed area +collapseToggle :: String -> [HtmlAttr] +collapseToggle id_ = [ strAttr "onclick" js ] + where js = "toggleSection('" ++ id_ ++ "')"; + +-- | Attributes for an area that toggles a collapsed area, +-- and displays a control. +collapseControl :: String -> Bool -> String -> [HtmlAttr] +collapseControl id_ state classes = + [ identifier cid, theclass cs ] ++ collapseToggle id_ + where cs = unwords (words classes ++ [pick state "collapser" "expander"]) + cid = "control." ++ id_ + + +pick :: Bool -> a -> a -> a +pick True t _ = t +pick False _ f = f |