aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Backends')
-rw-r--r--src/Haddock/Backends/HaddockDB.hs170
-rw-r--r--src/Haddock/Backends/Hoogle.hs331
-rw-r--r--src/Haddock/Backends/LaTeX.hs1221
-rw-r--r--src/Haddock/Backends/Xhtml.hs690
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs885
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs143
-rw-r--r--src/Haddock/Backends/Xhtml/Layout.hs235
-rw-r--r--src/Haddock/Backends/Xhtml/Names.hs171
-rw-r--r--src/Haddock/Backends/Xhtml/Themes.hs209
-rw-r--r--src/Haddock/Backends/Xhtml/Types.hs37
-rw-r--r--src/Haddock/Backends/Xhtml/Utils.hs218
11 files changed, 0 insertions, 4310 deletions
diff --git a/src/Haddock/Backends/HaddockDB.hs b/src/Haddock/Backends/HaddockDB.hs
deleted file mode 100644
index 1c248bfb..00000000
--- a/src/Haddock/Backends/HaddockDB.hs
+++ /dev/null
@@ -1,170 +0,0 @@
------------------------------------------------------------------------------
--- |
--- 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 "-&gt;", 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/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
deleted file mode 100644
index 628e1cd0..00000000
--- a/src/Haddock/Backends/Hoogle.hs
+++ /dev/null
@@ -1,331 +0,0 @@
------------------------------------------------------------------------------
--- |
--- 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 '<' = "&lt;"
- f '>' = "&gt;"
- f '&' = "&amp;"
- f x = [x]
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
deleted file mode 100644
index 7b72c030..00000000
--- a/src/Haddock/Backends/LaTeX.hs
+++ /dev/null
@@ -1,1221 +0,0 @@
-{-# 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/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
deleted file mode 100644
index 9628a33d..00000000
--- a/src/Haddock/Backends/Xhtml.hs
+++ /dev/null
@@ -1,690 +0,0 @@
------------------------------------------------------------------------------
--- |
--- 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/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
deleted file mode 100644
index 8884f69f..00000000
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ /dev/null
@@ -1,885 +0,0 @@
-{-# 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/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
deleted file mode 100644
index 5e27d9b0..00000000
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ /dev/null
@@ -1,143 +0,0 @@
------------------------------------------------------------------------------
--- |
--- 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/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
deleted file mode 100644
index e84a57b3..00000000
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ /dev/null
@@ -1,235 +0,0 @@
------------------------------------------------------------------------------
--- |
--- 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/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
deleted file mode 100644
index cf12da40..00000000
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ /dev/null
@@ -1,171 +0,0 @@
------------------------------------------------------------------------------
--- |
--- 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/src/Haddock/Backends/Xhtml/Themes.hs b/src/Haddock/Backends/Xhtml/Themes.hs
deleted file mode 100644
index 79b093ec..00000000
--- a/src/Haddock/Backends/Xhtml/Themes.hs
+++ /dev/null
@@ -1,209 +0,0 @@
------------------------------------------------------------------------------
--- |
--- 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/src/Haddock/Backends/Xhtml/Types.hs b/src/Haddock/Backends/Xhtml/Types.hs
deleted file mode 100644
index 122861c3..00000000
--- a/src/Haddock/Backends/Xhtml/Types.hs
+++ /dev/null
@@ -1,37 +0,0 @@
------------------------------------------------------------------------------
--- |
--- 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/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs
deleted file mode 100644
index cbcbbd6d..00000000
--- a/src/Haddock/Backends/Xhtml/Utils.hs
+++ /dev/null
@@ -1,218 +0,0 @@
------------------------------------------------------------------------------
--- |
--- 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 10:28:23 +0000