aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/Xhtml
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs885
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs143
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs235
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Names.hs171
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Themes.hs209
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Types.hs37
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs218
7 files changed, 1898 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
new file mode 100644
index 00000000..8884f69f
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -0,0 +1,885 @@
+{-# LANGUAGE TransformListComp #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.Decl
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Decl (
+ ppDecl,
+
+ ppTyName, ppTyFamHeader, ppTypeApp,
+ tyvarNames
+) where
+
+
+import Haddock.Backends.Xhtml.DocMarkup
+import Haddock.Backends.Xhtml.Layout
+import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
+import Haddock.GhcUtils
+import Haddock.Types
+import Haddock.Doc (combineDocumentation)
+
+import Data.List ( intersperse, sort )
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.Monoid ( mempty )
+import Text.XHtml hiding ( name, title, p, quote )
+
+import GHC
+import GHC.Exts
+import Name
+import BooleanFormula
+
+ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
+ -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
+ -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html
+ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
+ TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
+ TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
+ SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual
+ SigD (PatSynSig lname args ty prov req) ->
+ ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual
+ ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
+ InstD _ -> noHtml
+ _ -> error "declaration not supported by ppDecl"
+
+
+ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] ->
+ Splice -> Unicode -> Qualification -> Html
+ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =
+ ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities
+ splice unicode qual
+
+ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ [DocName] -> HsType DocName -> [(DocName, Fixity)] ->
+ Splice -> Unicode -> Qualification -> Html
+ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
+ ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ)
+ splice unicode qual
+ where
+ pp_typ = ppType unicode qual typ
+
+ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ Located DocName ->
+ HsPatSynDetails (LHsType DocName) -> LHsType DocName ->
+ LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] ->
+ Splice -> Unicode -> Qualification -> Html
+ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual =
+ ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ)
+ (unLoc prov) (unLoc req) fixities splice unicode qual
+
+ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ DocName ->
+ HsPatSynDetails (HsType DocName) -> HsType DocName ->
+ HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] ->
+ Splice -> Unicode -> Qualification -> Html
+ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities
+ splice unicode qual
+ | summary = pref1
+ | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual)
+ +++ docSection qual doc
+ where
+ pref1 = hsep [ toHtml "pattern"
+ , pp_cxt prov
+ , pp_head
+ , dcolon unicode
+ , pp_cxt req
+ , ppType unicode qual typ
+ ]
+ pp_head = case args of
+ PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs
+ InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right]
+
+ pp_cxt cxt = ppContext cxt unicode qual
+ pp_type = ppParendType unicode qual
+
+ occname = nameOccName . getName $ docname
+
+ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
+ [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->
+ Splice -> Unicode -> Qualification -> Html
+ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
+ splice unicode qual =
+ ppTypeOrFunSig summary links loc docnames typ doc
+ ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode
+ , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
+ , dcolon unicode
+ )
+ splice unicode qual
+ where
+ occnames = map (nameOccName . getName) docnames
+ addFixities html
+ | summary = html
+ | otherwise = html <+> ppFixities fixities qual
+
+
+ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName
+ -> DocForDecl DocName -> (Html, Html, Html)
+ -> Splice -> Unicode -> Qualification -> Html
+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual
+ | summary = pref1
+ | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection qual doc
+ | otherwise = topDeclElem links loc splice docnames pref2 +++
+ subArguments qual (do_args 0 sep typ) +++ docSection qual doc
+ where
+ argDoc n = Map.lookup n argDocs
+
+ do_largs n leader (L _ t) = do_args n leader t
+ do_args :: Int -> Html -> HsType DocName -> [SubDecl]
+ do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
+ = (leader <+>
+ hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
+ ppLContextNoArrow lctxt unicode qual,
+ Nothing, [])
+ : do_largs n (darrow unicode) ltype
+ do_args n leader (HsForAllTy Implicit _ lctxt ltype)
+ | not (null (unLoc lctxt))
+ = (leader <+> ppLContextNoArrow lctxt unicode qual,
+ Nothing, [])
+ : do_largs n (darrow unicode) ltype
+ -- if we're not showing any 'forall' or class constraints or
+ -- anything, skip having an empty line for the context.
+ | otherwise
+ = do_largs n leader ltype
+ do_args n leader (HsFunTy lt r)
+ = (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])
+ : do_largs (n+1) (arrow unicode) r
+ do_args n leader t
+ = [(leader <+> ppType unicode qual t, argDoc n, [])]
+
+ppFixities :: [(DocName, Fixity)] -> Qualification -> Html
+ppFixities [] _ = noHtml
+ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
+ where
+ ppFix (ns, p, d) = thespan ! [theclass "fixity"] <<
+ (toHtml d <+> toHtml (show p) <+> ppNames ns)
+
+ ppDir InfixR = "infixr"
+ ppDir InfixL = "infixl"
+ ppDir InfixN = "infix"
+
+ ppNames = case fs of
+ _:[] -> const noHtml -- Don't display names for fixities on single names
+ _ -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False)
+
+ uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs
+ , let d' = ppDir d
+ , then group by Down (p,d') using groupWith ]
+
+ rightEdge = thespan ! [theclass "rightedge"] << noHtml
+
+
+ppTyVars :: LHsTyVarBndrs DocName -> [Html]
+ppTyVars tvs = map ppTyName (tyvarNames tvs)
+
+
+tyvarNames :: LHsTyVarBndrs DocName -> [Name]
+tyvarNames = map getName . hsLTyVarNames
+
+
+ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
+ -> ForeignDecl DocName -> [(DocName, Fixity)]
+ -> Splice -> Unicode -> Qualification -> Html
+ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities
+ splice unicode qual
+ = ppFunSig summary links loc doc [name] typ fixities splice unicode qual
+ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"
+
+
+-- we skip type patterns for now
+ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan
+ -> DocForDecl DocName -> TyClDecl DocName
+ -> Splice -> Unicode -> Qualification -> Html
+ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+ , tcdRhs = ltype })
+ splice unicode qual
+ = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
+ (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)
+ splice unicode qual
+ where
+ hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
+ full = hdr <+> equals <+> ppLType unicode qual ltype
+ occ = nameOccName . getName $ name
+ fixs
+ | summary = noHtml
+ | otherwise = ppFixities fixities qual
+ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
+
+
+ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html
+ppTypeSig summary nms pp_ty unicode =
+ concatHtml htmlNames <+> dcolon unicode <+> pp_ty
+ where
+ htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms
+
+
+ppTyName :: Name -> Html
+ppTyName = ppName Prefix
+
+
+--------------------------------------------------------------------------------
+-- * Type families
+--------------------------------------------------------------------------------
+
+
+ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName
+ -> Unicode -> Qualification -> Html
+ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
+ , fdKindSig = mkind })
+ unicode qual =
+ (case info of
+ OpenTypeFamily
+ | associated -> keyword "type"
+ | otherwise -> keyword "type family"
+ DataFamily
+ | associated -> keyword "data"
+ | otherwise -> keyword "data family"
+ ClosedTypeFamily _
+ -> keyword "type family"
+ ) <+>
+
+ ppFamDeclBinderWithVars summary d <+>
+
+ (case mkind of
+ Just kind -> dcolon unicode <+> ppLKind unicode qual kind
+ Nothing -> noHtml
+ )
+
+ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] ->
+ [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
+ FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html
+ppTyFam summary associated links instances fixities loc doc decl splice unicode qual
+
+ | summary = ppTyFamHeader True associated decl unicode qual
+ | otherwise = header_ +++ docSection qual doc +++ instancesBit
+
+ where
+ docname = unLoc $ fdLName decl
+
+ header_ = topDeclElem links loc splice [docname] $
+ ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual
+
+ instancesBit
+ | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl
+ , not summary
+ = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
+
+ | otherwise
+ = ppInstances instances docname unicode qual
+
+ -- Individual equation of a closed type family
+ ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs
+ , tfie_pats = HsWB { hswb_cts = ts }}
+ = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
+ <+> equals <+> ppType unicode qual (unLoc rhs)
+ , Nothing, [] )
+
+--------------------------------------------------------------------------------
+-- * Associated Types
+--------------------------------------------------------------------------------
+
+
+ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName
+ -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html
+ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
+ ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual
+
+
+--------------------------------------------------------------------------------
+-- * TyClDecl helpers
+--------------------------------------------------------------------------------
+
+-- | Print a type family and its variables
+ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html
+ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
+ ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs)
+
+-- | Print a newtype / data binder and its variables
+ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html
+ppDataBinderWithVars summ decl =
+ ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl)
+
+--------------------------------------------------------------------------------
+-- * Type applications
+--------------------------------------------------------------------------------
+
+
+-- | Print an application of a DocName and two lists of HsTypes (kinds, types)
+ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName]
+ -> Unicode -> Qualification -> Html
+ppAppNameTypes n ks ts unicode qual =
+ ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual)
+
+
+-- | Print an application of a DocName and a list of Names
+ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html
+ppAppDocNameNames summ n ns =
+ ppTypeApp n [] ns ppDN ppTyName
+ where
+ ppDN notation = ppBinderFixity notation summ . nameOccName . getName
+ ppBinderFixity Infix = ppBinderInfix
+ ppBinderFixity _ = ppBinder
+
+-- | General printing of type applications
+ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
+ppTypeApp n [] (t1:t2:rest) ppDN ppT
+ | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
+ | operator = opApp
+ where
+ operator = isNameSym . getName $ n
+ opApp = ppT t1 <+> ppDN Infix n <+> ppT t2
+
+ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)
+
+
+-------------------------------------------------------------------------------
+-- * Contexts
+-------------------------------------------------------------------------------
+
+
+ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode
+ -> Qualification -> Html
+ppLContext = ppContext . unLoc
+ppLContextNoArrow = ppContextNoArrow . unLoc
+
+
+ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html
+ppContextNoArrow [] _ _ = noHtml
+ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual
+
+
+ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html
+ppContextNoLocs [] _ _ = noHtml
+ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual
+ <+> darrow unicode
+
+
+ppContext :: HsContext DocName -> Unicode -> Qualification -> Html
+ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
+
+
+ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html
+ppHsContext [] _ _ = noHtml
+ppHsContext [p] unicode qual = ppCtxType unicode qual p
+ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
+
+
+-------------------------------------------------------------------------------
+-- * Class declarations
+-------------------------------------------------------------------------------
+
+
+ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
+ -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
+ -> Unicode -> Qualification -> Html
+ppClassHdr summ lctxt n tvs fds unicode qual =
+ keyword "class"
+ <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)
+ <+> ppAppDocNameNames summ n (tyvarNames tvs)
+ <+> ppFds fds unicode qual
+
+
+ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html
+ppFds fds unicode qual =
+ if null fds then noHtml else
+ char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
+ where
+ fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2
+ ppVars = hsep . map (ppDocName qual Prefix True)
+
+ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
+ -> [(DocName, DocForDecl DocName)]
+ -> Splice -> Unicode -> Qualification -> Html
+ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs
+ , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc
+ subdocs splice unicode qual =
+ if not (any isVanillaLSig sigs) && null ats
+ then (if summary then id else topDeclElem links loc splice [nm]) hdr
+ else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")
+ +++ shortSubDecls False
+ (
+ [ ppAssocType summary links doc at [] splice unicode qual | at <- ats
+ , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++
+
+ -- ToDo: add associated type defaults
+
+ [ ppFunSig summary links loc doc names typ [] splice unicode qual
+ | L _ (TypeSig lnames (L _ typ)) <- sigs
+ , let doc = lookupAnySubdoc (head names) subdocs
+ names = map unLoc lnames ]
+ -- FIXME: is taking just the first name ok? Is it possible that
+ -- there are different subdocs for different names in a single
+ -- type signature?
+ )
+ where
+ hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual
+ nm = unLoc lname
+ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+
+
+
+ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)]
+ -> SrcSpan -> Documentation DocName
+ -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName
+ -> Splice -> Unicode -> Qualification -> Html
+ppClassDecl summary links instances fixities loc d subdocs
+ decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
+ , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats })
+ splice unicode qual
+ | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual
+ | otherwise = classheader +++ docSection qual d
+ +++ minimalBit +++ atBit +++ methodBit +++ instancesBit
+ where
+ classheader
+ | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)
+ | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)
+
+ -- Only the fixity relevant to the class header
+ fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual
+
+ nm = tcdName decl
+
+ hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
+
+ -- ToDo: add assocatied typ defaults
+ atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual
+ | at <- ats
+ , let n = unL . fdLName $ unL at
+ doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
+ subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
+
+ methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual
+ | L _ (TypeSig lnames (L _ typ)) <- lsigs
+ , let doc = lookupAnySubdoc (head names) subdocs
+ subfixs = [ f | n <- names
+ , f@(n',_) <- fixities
+ , n == n' ]
+ names = map unLoc lnames ]
+ -- FIXME: is taking just the first name ok? Is it possible that
+ -- there are different subdocs for different names in a single
+ -- type signature?
+
+ minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of
+ -- Miminal complete definition = every shown method
+ And xs : _ | sort [getName n | Var (L _ n) <- xs] ==
+ sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns]
+ -> noHtml
+
+ -- Minimal complete definition = the only shown method
+ Var (L _ n) : _ | [getName n] ==
+ [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns]
+ -> noHtml
+
+ -- Minimal complete definition = nothing
+ And [] : _ -> subMinimal $ toHtml "Nothing"
+
+ m : _ -> subMinimal $ ppMinimal False m
+ _ -> noHtml
+
+ ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n
+ ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs
+ ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
+ where wrap | p = parens | otherwise = id
+
+ instancesBit = ppInstances instances nm unicode qual
+
+ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+
+
+ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
+ppInstances instances baseName unicode qual
+ = subInstances qual instName (map instDecl instances)
+ where
+ instName = getOccString $ getName baseName
+ instDecl :: DocInstance DocName -> SubDecl
+ instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
+ instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
+ <+> ppAppNameTypes n ks ts unicode qual
+ instHead (n, ks, ts, TypeInst rhs) = keyword "type"
+ <+> ppAppNameTypes n ks ts unicode qual
+ <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
+ instHead (n, ks, ts, DataInst dd) = keyword "data"
+ <+> ppAppNameTypes n ks ts unicode qual
+ <+> ppShortDataDecl False True dd unicode qual
+
+lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
+lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
+
+
+-------------------------------------------------------------------------------
+-- * Data & newtype declarations
+-------------------------------------------------------------------------------
+
+
+-- TODO: print contexts
+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html
+ppShortDataDecl summary dataInst dataDecl unicode qual
+
+ | [] <- cons = dataHeader
+
+ | [lcon] <- cons, ResTyH98 <- resTy,
+ (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual
+ = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
+
+ | ResTyH98 <- resTy = dataHeader
+ +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons)
+
+ | otherwise = (dataHeader <+> keyword "where")
+ +++ shortSubDecls dataInst (map doGADTConstr cons)
+
+ where
+ dataHeader
+ | dataInst = noHtml
+ | otherwise = ppDataHeader summary dataDecl unicode qual
+ doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual
+ doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual
+
+ cons = dd_cons (tcdDataDefn dataDecl)
+ resTy = (con_res . unLoc . head) cons
+
+
+ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->
+ [(DocName, DocForDecl DocName)] ->
+ SrcSpan -> Documentation DocName -> TyClDecl DocName ->
+ Splice -> Unicode -> Qualification -> Html
+ppDataDecl summary links instances fixities subdocs loc doc dataDecl
+ splice unicode qual
+
+ | summary = ppShortDataDecl summary False dataDecl unicode qual
+ | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
+
+ where
+ docname = tcdName dataDecl
+ cons = dd_cons (tcdDataDefn dataDecl)
+ resTy = (con_res . unLoc . head) cons
+
+ header_ = topDeclElem links loc splice [docname] $
+ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix
+
+ fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual
+
+ whereBit
+ | null cons = noHtml
+ | otherwise = case resTy of
+ ResTyGADT _ -> keyword "where"
+ _ -> noHtml
+
+ constrBit = subConstructors qual
+ [ ppSideBySideConstr subdocs subfixs unicode qual c
+ | c <- cons
+ , let subfixs = filter (\(n,_) -> n == unLoc (con_name (unLoc c))) fixities
+ ]
+
+ instancesBit = ppInstances instances docname unicode qual
+
+
+
+ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html
+ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
+ where
+ (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual
+
+
+-- returns three pieces: header, body, footer so that header & footer can be
+-- incorporated into the declaration
+ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html)
+ppShortConstrParts summary dataInst con unicode qual = case con_res con of
+ ResTyH98 -> case con_details con of
+ PrefixCon args ->
+ (header_ unicode qual +++ hsep (ppBinder summary occ
+ : map (ppLParendType unicode qual) args), noHtml, noHtml)
+ RecCon fields ->
+ (header_ unicode qual +++ ppBinder summary occ <+> char '{',
+ doRecordFields fields,
+ char '}')
+ InfixCon arg1 arg2 ->
+ (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,
+ ppBinderInfix summary occ, ppLParendType unicode qual arg2],
+ noHtml, noHtml)
+
+ ResTyGADT resTy -> case con_details con of
+ -- prefix & infix could use hsConDeclArgTys if it seemed to
+ -- simplify the code.
+ PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml)
+ -- display GADT records with the new syntax,
+ -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b)
+ -- (except each field gets its own line in docs, to match
+ -- non-GADT records)
+ RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+>
+ ppForAll forall_ ltvs lcontext unicode qual <+> char '{',
+ doRecordFields fields,
+ char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
+ InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
+
+ where
+ doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) fields)
+ doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [
+ ppForAll forall_ ltvs lcontext unicode qual,
+ ppLType unicode qual (foldr mkFunTy resTy args) ]
+
+ header_ = ppConstrHdr forall_ tyVars context
+ occ = nameOccName . getName . unLoc . con_name $ con
+ ltvs = con_qvars con
+ tyVars = tyvarNames ltvs
+ lcontext = con_cxt con
+ context = unLoc (con_cxt con)
+ forall_ = con_explicit con
+ mkFunTy a b = noLoc (HsFunTy a b)
+
+
+-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
+ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode
+ -> Qualification -> Html
+ppConstrHdr forall_ tvs ctxt unicode qual
+ = (if null tvs then noHtml else ppForall)
+ +++
+ (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual
+ <+> darrow unicode +++ toHtml " ")
+ where
+ ppForall = case forall_ of
+ Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". "
+ Implicit -> noHtml
+
+
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
+ -> Unicode -> Qualification -> LConDecl DocName -> SubDecl
+ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart)
+ where
+ decl = case con_res con of
+ ResTyH98 -> case con_details con of
+ PrefixCon args ->
+ hsep ((header_ +++ ppBinder False occ)
+ : map (ppLParendType unicode qual) args)
+ <+> fixity
+
+ RecCon _ -> header_ +++ ppBinder False occ <+> fixity
+
+ InfixCon arg1 arg2 ->
+ hsep [header_ +++ ppLParendType unicode qual arg1,
+ ppBinderInfix False occ,
+ ppLParendType unicode qual arg2]
+ <+> fixity
+
+ ResTyGADT resTy -> case con_details con of
+ -- prefix & infix could also use hsConDeclArgTys if it seemed to
+ -- simplify the code.
+ PrefixCon args -> doGADTCon args resTy
+ cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy
+ InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
+
+ fieldPart = case con_details con of
+ RecCon fields -> [doRecordFields fields]
+ _ -> []
+
+ doRecordFields fields = subFields qual
+ (map (ppSideBySideField subdocs unicode qual) fields)
+ doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
+ doGADTCon args resTy = ppBinder False occ <+> dcolon unicode
+ <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual,
+ ppLType unicode qual (foldr mkFunTy resTy args) ]
+ <+> fixity
+
+ fixity = ppFixities fixities qual
+ header_ = ppConstrHdr forall_ tyVars context unicode qual
+ occ = nameOccName . getName . unLoc . con_name $ con
+ ltvs = con_qvars con
+ tyVars = tyvarNames (con_qvars con)
+ context = unLoc (con_cxt con)
+ forall_ = con_explicit con
+ -- don't use "con_doc con", in case it's reconstructed from a .hi file,
+ -- or also because we want Haddock to do the doc-parsing, not GHC.
+ mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst
+ mkFunTy a b = noLoc (HsFunTy a b)
+
+
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
+ -> ConDeclField DocName -> SubDecl
+ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
+ (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype,
+ mbDoc,
+ [])
+ where
+ -- don't use cd_fld_doc for same reason we don't use con_doc above
+ mbDoc = lookup name subdocs >>= combineDocumentation . fst
+
+
+ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html
+ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
+ = ppBinder summary (nameOccName . getName $ name)
+ <+> dcolon unicode <+> ppLType unicode qual ltype
+
+
+-- | Print the LHS of a data\/newtype declaration.
+-- Currently doesn't handle 'data instance' decls or kind signatures
+ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html
+ppDataHeader summary decl@(DataDecl { tcdDataDefn =
+ HsDataDefn { dd_ND = nd
+ , dd_ctxt = ctxt
+ , dd_kindSig = ks } })
+ unicode qual
+ = -- newtype or data
+ (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" })
+ <+>
+ -- context
+ ppLContext ctxt unicode qual <+>
+ -- T a b c ..., or a :+: b
+ ppDataBinderWithVars summary decl
+ <+> case ks of
+ Nothing -> mempty
+ Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x
+
+ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
+
+--------------------------------------------------------------------------------
+-- * Types and contexts
+--------------------------------------------------------------------------------
+
+
+ppBang :: HsBang -> Html
+ppBang HsNoBang = noHtml
+ppBang _ = toHtml "!" -- Unpacked args is an implementation detail,
+ -- so we just show the strictness annotation
+
+
+tupleParens :: HsTupleSort -> [Html] -> Html
+tupleParens HsUnboxedTuple = ubxParenList
+tupleParens _ = parenList
+
+
+--------------------------------------------------------------------------------
+-- * Rendering of HsType
+--------------------------------------------------------------------------------
+
+
+pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int
+
+pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC
+pREC_CTX = 1 :: Int -- Used for single contexts, eg. ctx => type
+ -- (as opposed to (ctx1, ctx2) => type)
+pREC_FUN = 2 :: Int -- btype in ParseIface.y in GHC
+ -- Used for LH arg of (->)
+pREC_OP = 3 :: Int -- Used for arg of any infix operator
+ -- (we don't keep their fixities around)
+pREC_CON = 4 :: Int -- Used for arg of type applicn:
+ -- always parenthesise unless atomic
+
+maybeParen :: Int -- Precedence of context
+ -> Int -- Precedence of top-level operator
+ -> Html -> Html -- Wrap in parens if (ctxt >= op)
+maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
+ | otherwise = p
+
+
+ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification
+ -> Located (HsType DocName) -> Html
+ppLType unicode qual y = ppType unicode qual (unLoc y)
+ppLParendType unicode qual y = ppParendType unicode qual (unLoc y)
+ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y)
+
+
+ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification
+ -> HsType DocName -> Html
+ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual
+ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual
+ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual
+ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual
+
+ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html
+ppLKind unicode qual y = ppKind unicode qual (unLoc y)
+
+ppKind :: Unicode -> Qualification -> HsKind DocName -> Html
+ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
+
+-- Drop top-level for-all type variables in user style
+-- since they are implicit in Haskell
+
+ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
+ -> Located (HsContext DocName) -> Unicode -> Qualification -> Html
+ppForAll expl tvs cxt unicode qual
+ | show_forall = forall_part <+> ppLContext cxt unicode qual
+ | otherwise = ppLContext cxt unicode qual
+ where
+ show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
+ is_explicit = case expl of {Explicit -> True; Implicit -> False}
+ forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
+
+
+ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html
+ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
+
+
+ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html
+ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual
+ = maybeParen ctxt_prec pREC_FUN $
+ hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual]
+
+-- UnicodeSyntax alternatives
+ppr_mono_ty _ (HsTyVar name) True _
+ | getOccString (getName name) == "*" = toHtml "★"
+ | getOccString (getName name) == "(->)" = toHtml "(→)"
+
+ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty
+ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q
+ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)
+ppr_mono_ty _ (HsKindSig ty kind) u q =
+ parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind)
+ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q)
+ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
+ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q =
+ maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q
+ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"
+ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
+ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy"
+ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
+ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys
+ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy"
+
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
+ = maybeParen ctxt_prec pREC_CTX $
+ ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual
+
+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
+ = maybeParen ctxt_prec pREC_CON $
+ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]
+
+ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual
+ = maybeParen ctxt_prec pREC_FUN $
+ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual
+ where
+ ppr_op = ppLDocName qual Infix op
+
+ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
+-- = parens (ppr_mono_lty pREC_TOP ty)
+ = ppr_mono_lty ctxt_prec ty unicode qual
+
+ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual
+ = ppr_mono_lty ctxt_prec ty unicode qual
+
+ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n
+
+ppr_tylit :: HsTyLit -> Html
+ppr_tylit (HsNumTy n) = toHtml (show n)
+ppr_tylit (HsStrTy s) = toHtml (show s)
+
+
+ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html
+ppr_fun_ty ctxt_prec ty1 ty2 unicode qual
+ = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual
+ p2 = ppr_mono_lty pREC_TOP ty2 unicode qual
+ in
+ maybeParen ctxt_prec pREC_FUN $
+ hsep [p1, arrow unicode <+> p2]
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
new file mode 100644
index 00000000..5e27d9b0
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -0,0 +1,143 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.DocMarkup
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.DocMarkup (
+ docToHtml,
+ rdrDocToHtml,
+ origDocToHtml,
+ docToHtmlNoAnchors,
+
+ docElement, docSection, docSection_,
+) where
+
+import Control.Applicative ((<$>))
+
+import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Utils
+import Haddock.Types
+import Haddock.Utils
+import Haddock.Doc (combineDocumentation)
+
+import Text.XHtml hiding ( name, p, quote )
+import Data.Maybe (fromMaybe)
+
+import GHC
+
+parHtmlMarkup :: Qualification -> Bool
+ -> (Bool -> a -> Html) -> DocMarkup a Html
+parHtmlMarkup qual insertAnchors ppId = Markup {
+ markupEmpty = noHtml,
+ markupString = toHtml,
+ markupParagraph = paragraph,
+ markupAppend = (+++),
+ markupIdentifier = thecode . ppId insertAnchors,
+ markupIdentifierUnchecked = thecode . ppUncheckedLink qual,
+ markupModule = \m -> let (mdl,ref) = break (=='#') m
+ -- Accomodate for old style
+ -- foo\#bar anchors
+ mdl' = case reverse mdl of
+ '\\':_ -> init mdl
+ _ -> mdl
+ in ppModuleRef (mkModuleName mdl') ref,
+ markupWarning = thediv ! [theclass "warning"],
+ markupEmphasis = emphasize,
+ markupBold = strong,
+ markupMonospaced = thecode,
+ markupUnorderedList = unordList,
+ markupOrderedList = ordList,
+ markupDefList = defList,
+ markupCodeBlock = pre,
+ markupHyperlink = \(Hyperlink url mLabel)
+ -> if insertAnchors
+ then anchor ! [href url]
+ << fromMaybe url mLabel
+ else toHtml $ fromMaybe url mLabel,
+ markupAName = \aname -> namedAnchor aname << "",
+ markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),
+ markupProperty = pre . toHtml,
+ markupExample = examplesToHtml,
+ markupHeader = \(Header l t) -> makeHeader l t
+ }
+ where
+ makeHeader :: Int -> Html -> Html
+ makeHeader 1 mkup = h1 mkup
+ makeHeader 2 mkup = h2 mkup
+ makeHeader 3 mkup = h3 mkup
+ makeHeader 4 mkup = h4 mkup
+ makeHeader 5 mkup = h5 mkup
+ makeHeader 6 mkup = h6 mkup
+ makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!"
+
+
+ examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
+
+ exampleToHtml (Example expression result) = htmlExample
+ where
+ htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result)
+ htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]
+ htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
+
+
+-- If the doc is a single paragraph, don't surround it with <P> (this causes
+-- ugly extra whitespace with some browsers). FIXME: Does this still apply?
+docToHtml :: Qualification -> Doc DocName -> Html
+docToHtml qual = markup fmt . cleanup
+ where fmt = parHtmlMarkup qual True (ppDocName qual Raw)
+
+-- | Same as 'docToHtml' but it doesn't insert the 'anchor' element
+-- in links. This is used to generate the Contents box elements.
+docToHtmlNoAnchors :: Qualification -> Doc DocName -> Html
+docToHtmlNoAnchors qual = markup fmt . cleanup
+ where fmt = parHtmlMarkup qual False (ppDocName qual Raw)
+
+origDocToHtml :: Qualification -> Doc Name -> Html
+origDocToHtml qual = markup fmt . cleanup
+ where fmt = parHtmlMarkup qual True (const $ ppName Raw)
+
+
+rdrDocToHtml :: Qualification -> Doc RdrName -> Html
+rdrDocToHtml qual = markup fmt . cleanup
+ where fmt = parHtmlMarkup qual True (const ppRdrName)
+
+
+docElement :: (Html -> Html) -> Html -> Html
+docElement el content_ =
+ if isNoHtml content_
+ then el ! [theclass "doc empty"] << spaceHtml
+ else el ! [theclass "doc"] << content_
+
+
+docSection :: Qualification -> Documentation DocName -> Html
+docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation
+
+
+docSection_ :: Qualification -> Doc DocName -> Html
+docSection_ qual = (docElement thediv <<) . docToHtml qual
+
+
+cleanup :: Doc a -> Doc a
+cleanup = markup fmtUnParagraphLists
+ where
+ -- If there is a single paragraph, then surrounding it with <P>..</P>
+ -- can add too much whitespace in some browsers (eg. IE). However if
+ -- we have multiple paragraphs, then we want the extra whitespace to
+ -- separate them. So we catch the single paragraph case and transform it
+ -- here. We don't do this in code blocks as it eliminates line breaks.
+ unParagraph :: Doc a -> Doc a
+ unParagraph (DocParagraph d) = d
+ unParagraph doc = doc
+
+ fmtUnParagraphLists :: DocMarkup a (Doc a)
+ fmtUnParagraphLists = idMarkup {
+ markupUnorderedList = DocUnorderedList . map unParagraph,
+ markupOrderedList = DocOrderedList . map unParagraph
+ }
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
new file mode 100644
index 00000000..e84a57b3
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -0,0 +1,235 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.Layout
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Layout (
+ miniBody,
+
+ divPackageHeader, divContent, divModuleHeader, divFooter,
+ divTableOfContents, divDescription, divSynposis, divInterface,
+ divIndex, divAlphabet, divModuleList,
+
+ sectionName,
+ nonEmptySectionName,
+
+ shortDeclList,
+ shortSubDecls,
+
+ divTopDecl,
+
+ SubDecl,
+ subArguments,
+ subAssociatedTypes,
+ subConstructors,
+ subEquations,
+ subFields,
+ subInstances,
+ subMethods,
+ subMinimal,
+
+ topDeclElem, declElem,
+) where
+
+
+import Haddock.Backends.Xhtml.DocMarkup
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
+import Haddock.Types
+import Haddock.Utils (makeAnchorId)
+
+import qualified Data.Map as Map
+import Text.XHtml hiding ( name, title, p, quote )
+
+import FastString ( unpackFS )
+import GHC
+
+
+--------------------------------------------------------------------------------
+-- * Sections of the document
+--------------------------------------------------------------------------------
+
+
+miniBody :: Html -> Html
+miniBody = body ! [identifier "mini"]
+
+
+sectionDiv :: String -> Html -> Html
+sectionDiv i = thediv ! [identifier i]
+
+
+sectionName :: Html -> Html
+sectionName = paragraph ! [theclass "caption"]
+
+
+-- | Make an element that always has at least something (a non-breaking space).
+-- If it would have otherwise been empty, then give it the class ".empty".
+nonEmptySectionName :: Html -> Html
+nonEmptySectionName c
+ | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml
+ | otherwise = paragraph ! [theclass "caption"] $ c
+
+
+divPackageHeader, divContent, divModuleHeader, divFooter,
+ divTableOfContents, divDescription, divSynposis, divInterface,
+ divIndex, divAlphabet, divModuleList
+ :: Html -> Html
+
+divPackageHeader = sectionDiv "package-header"
+divContent = sectionDiv "content"
+divModuleHeader = sectionDiv "module-header"
+divFooter = sectionDiv "footer"
+divTableOfContents = sectionDiv "table-of-contents"
+divDescription = sectionDiv "description"
+divSynposis = sectionDiv "synopsis"
+divInterface = sectionDiv "interface"
+divIndex = sectionDiv "index"
+divAlphabet = sectionDiv "alphabet"
+divModuleList = sectionDiv "module-list"
+
+
+--------------------------------------------------------------------------------
+-- * Declaration containers
+--------------------------------------------------------------------------------
+
+
+shortDeclList :: [Html] -> Html
+shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items
+
+
+shortSubDecls :: Bool -> [Html] -> Html
+shortSubDecls inst items = ulist ! [theclass c] << map (i <<) items
+ where i | inst = li ! [theclass "inst"]
+ | otherwise = li
+ c | inst = "inst"
+ | otherwise = "subs"
+
+
+divTopDecl :: Html -> Html
+divTopDecl = thediv ! [theclass "top"]
+
+
+type SubDecl = (Html, Maybe (Doc DocName), [Html])
+
+
+divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html
+divSubDecls cssClass captionName = maybe noHtml wrap
+ where
+ wrap = (subSection <<) . (subCaption +++)
+ subSection = thediv ! [theclass $ unwords ["subs", cssClass]]
+ subCaption = paragraph ! [theclass "caption"] << captionName
+
+
+subDlist :: Qualification -> [SubDecl] -> Maybe Html
+subDlist _ [] = Nothing
+subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv
+ where
+ subEntry (decl, mdoc, subs) =
+ dterm ! [theclass "src"] << decl
+ +++
+ docElement ddef << (fmap (docToHtml qual) mdoc +++ subs)
+
+ clearDiv = thediv ! [ theclass "clear" ] << noHtml
+
+
+subTable :: Qualification -> [SubDecl] -> Maybe Html
+subTable _ [] = Nothing
+subTable qual decls = Just $ table << aboves (concatMap subRow decls)
+ where
+ subRow (decl, mdoc, subs) =
+ (td ! [theclass "src"] << decl
+ <->
+ docElement td << fmap (docToHtml qual) mdoc)
+ : map (cell . (td <<)) subs
+
+
+subBlock :: [Html] -> Maybe Html
+subBlock [] = Nothing
+subBlock hs = Just $ toHtml hs
+
+
+subArguments :: Qualification -> [SubDecl] -> Html
+subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual
+
+
+subAssociatedTypes :: [Html] -> Html
+subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock
+
+
+subConstructors :: Qualification -> [SubDecl] -> Html
+subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual
+
+
+subFields :: Qualification -> [SubDecl] -> Html
+subFields qual = divSubDecls "fields" "Fields" . subDlist qual
+
+
+subEquations :: Qualification -> [SubDecl] -> Html
+subEquations qual = divSubDecls "equations" "Equations" . subTable qual
+
+
+subInstances :: Qualification -> String -> [SubDecl] -> Html
+subInstances qual nm = maybe noHtml wrap . instTable
+ where
+ wrap = (subSection <<) . (subCaption +++)
+ instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual
+ subSection = thediv ! [theclass "subs instances"]
+ subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
+ id_ = makeAnchorId $ "i:" ++ nm
+
+subMethods :: [Html] -> Html
+subMethods = divSubDecls "methods" "Methods" . subBlock
+
+subMinimal :: Html -> Html
+subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem
+
+
+-- a box for displaying code
+declElem :: Html -> Html
+declElem = paragraph ! [theclass "src"]
+
+
+-- a box for top level documented names
+-- it adds a source and wiki link at the right hand side of the box
+topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html
+topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html =
+ declElem << (html <+> srcLink <+> wikiLink)
+ where srcLink = let nameUrl = Map.lookup origPkg sourceMap
+ lineUrl = Map.lookup origPkg lineMap
+ mUrl | splice = lineUrl
+ -- Use the lineUrl as a backup
+ | otherwise = maybe lineUrl Just nameUrl in
+ case mUrl of
+ Nothing -> noHtml
+ Just url -> let url' = spliceURL (Just fname) (Just origMod)
+ (Just n) (Just loc) url
+ in anchor ! [href url', theclass "link"] << "Source"
+
+ wikiLink =
+ case maybe_wiki_url of
+ Nothing -> noHtml
+ Just url -> let url' = spliceURL (Just fname) (Just mdl)
+ (Just n) (Just loc) url
+ in anchor ! [href url', theclass "link"] << "Comments"
+
+ -- For source links, we want to point to the original module,
+ -- because only that will have the source.
+ -- TODO: do something about type instances. They will point to
+ -- the module defining the type family, which is wrong.
+ origMod = nameModule n
+ origPkg = modulePackageId origMod
+
+ -- Name must be documented, otherwise we wouldn't get here
+ Documented n mdl = head names
+ -- FIXME: is it ok to simply take the first name?
+
+ fname = case loc of
+ RealSrcSpan l -> unpackFS (srcSpanFile l)
+ UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
new file mode 100644
index 00000000..cf12da40
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -0,0 +1,171 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.Names
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Names (
+ ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
+ ppBinder, ppBinderInfix, ppBinder',
+ ppModule, ppModuleRef, ppIPName, linkId, Notation(..)
+) where
+
+
+import Haddock.Backends.Xhtml.Utils
+import Haddock.GhcUtils
+import Haddock.Types
+import Haddock.Utils
+
+import Text.XHtml hiding ( name, title, p, quote )
+import qualified Data.Map as M
+import qualified Data.List as List
+
+import GHC
+import Name
+import RdrName
+import FastString (unpackFS)
+
+
+-- | Indicator of how to render a 'DocName' into 'Html'
+data Notation = Raw -- ^ Render as-is.
+ | Infix -- ^ Render using infix notation.
+ | Prefix -- ^ Render using prefix notation.
+ deriving (Eq, Show)
+
+ppOccName :: OccName -> Html
+ppOccName = toHtml . occNameString
+
+
+ppRdrName :: RdrName -> Html
+ppRdrName = ppOccName . rdrNameOcc
+
+ppIPName :: HsIPName -> Html
+ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS
+
+
+ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
+ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName
+
+
+-- The Bool indicates if it is to be rendered in infix notation
+ppLDocName :: Qualification -> Notation -> Located DocName -> Html
+ppLDocName qual notation (L _ d) = ppDocName qual notation True d
+
+ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html
+ppDocName qual notation insertAnchors docName =
+ case docName of
+ Documented name mdl ->
+ linkIdOcc mdl (Just (nameOccName name)) insertAnchors
+ << ppQualifyName qual notation name mdl
+ Undocumented name
+ | isExternalName name || isWiredInName name ->
+ ppQualifyName qual notation name (nameModule name)
+ | otherwise -> ppName notation name
+
+-- | Render a name depending on the selected qualification mode
+ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html
+ppQualifyName qual notation name mdl =
+ case qual of
+ NoQual -> ppName notation name
+ FullQual -> ppFullQualName notation mdl name
+ LocalQual localmdl ->
+ if moduleString mdl == moduleString localmdl
+ then ppName notation name
+ else ppFullQualName notation mdl name
+ RelativeQual localmdl ->
+ case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
+ -- local, A.x -> x
+ Just [] -> ppName notation name
+ -- sub-module, A.B.x -> B.x
+ Just ('.':m) -> toHtml $ m ++ '.' : getOccString name
+ -- some module with same prefix, ABC.x -> ABC.x
+ Just _ -> ppFullQualName notation mdl name
+ -- some other module, D.x -> D.x
+ Nothing -> ppFullQualName notation mdl name
+ AliasedQual aliases localmdl ->
+ case (moduleString mdl == moduleString localmdl,
+ M.lookup mdl aliases) of
+ (False, Just alias) -> ppQualName notation alias name
+ _ -> ppName notation name
+
+
+ppFullQualName :: Notation -> Module -> Name -> Html
+ppFullQualName notation mdl name = wrapInfix notation (getOccName name) qname
+ where
+ qname = toHtml $ moduleString mdl ++ '.' : getOccString name
+
+ppQualName :: Notation -> ModuleName -> Name -> Html
+ppQualName notation mdlName name = wrapInfix notation (getOccName name) qname
+ where
+ qname = toHtml $ moduleNameString mdlName ++ '.' : getOccString name
+
+ppName :: Notation -> Name -> Html
+ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccString name)
+
+
+ppBinder :: Bool -> OccName -> Html
+-- The Bool indicates whether we are generating the summary, in which case
+-- the binder will be a link to the full definition.
+ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n
+ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
+ << ppBinder' Prefix n
+
+ppBinderInfix :: Bool -> OccName -> Html
+ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n
+ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
+ << ppBinder' Infix n
+
+ppBinder' :: Notation -> OccName -> Html
+ppBinder' notation n = wrapInfix notation n $ ppOccName n
+
+wrapInfix :: Notation -> OccName -> Html -> Html
+wrapInfix notation n = case notation of
+ Infix | is_star_kind -> id
+ | not is_sym -> quote
+ Prefix | is_star_kind -> id
+ | is_sym -> parens
+ _ -> id
+ where
+ is_sym = isSymOcc n
+ is_star_kind = isTcOcc n && occNameString n == "*"
+
+linkId :: Module -> Maybe Name -> Html -> Html
+linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) True
+
+
+linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html
+linkIdOcc mdl mbName insertAnchors =
+ if insertAnchors
+ then anchor ! [href url]
+ else id
+ where
+ url = case mbName of
+ Nothing -> moduleUrl mdl
+ Just name -> moduleNameUrl mdl name
+
+
+linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html
+linkIdOcc' mdl mbName = anchor ! [href url]
+ where
+ url = case mbName of
+ Nothing -> moduleHtmlFile' mdl
+ Just name -> moduleNameUrl' mdl name
+
+
+ppModule :: Module -> Html
+ppModule mdl = anchor ! [href (moduleUrl mdl)]
+ << toHtml (moduleString mdl)
+
+
+ppModuleRef :: ModuleName -> String -> Html
+ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
+ << toHtml (moduleNameString mdl)
+ -- NB: The ref parameter already includes the '#'.
+ -- This function is only called from markupModule expanding a
+ -- DocModule, which doesn't seem to be ever be used.
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
new file mode 100644
index 00000000..79b093ec
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
@@ -0,0 +1,209 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.Themes
+-- Copyright : (c) Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Themes (
+ Themes,
+ getThemes,
+
+ cssFiles, styleSheet
+ )
+ where
+
+import Haddock.Options
+
+import Control.Applicative
+import Control.Monad (liftM)
+import Data.Char (toLower)
+import Data.Either (lefts, rights)
+import Data.List (nub)
+import Data.Maybe (isJust, listToMaybe)
+
+import System.Directory
+import System.FilePath
+import Text.XHtml hiding ( name, title, p, quote, (</>) )
+import qualified Text.XHtml as XHtml
+
+
+--------------------------------------------------------------------------------
+-- * CSS Themes
+--------------------------------------------------------------------------------
+
+data Theme = Theme {
+ themeName :: String,
+ themeHref :: String,
+ themeFiles :: [FilePath]
+ }
+
+type Themes = [Theme]
+
+type PossibleTheme = Either String Theme
+type PossibleThemes = Either String Themes
+
+
+-- | Find a theme by name (case insensitive match)
+findTheme :: String -> Themes -> Maybe Theme
+findTheme s = listToMaybe . filter ((== ls).lower.themeName)
+ where lower = map toLower
+ ls = lower s
+
+
+-- | Standard theme used by default
+standardTheme :: FilePath -> IO PossibleThemes
+standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir)
+
+
+-- | Default themes that are part of Haddock; added with --default-themes
+-- The first theme in this list is considered the standard theme.
+-- Themes are "discovered" by scanning the html sub-dir of the libDir,
+-- and looking for directories with the extension .theme or .std-theme.
+-- The later is, obviously, the standard theme.
+defaultThemes :: FilePath -> IO PossibleThemes
+defaultThemes libDir = do
+ themeDirs <- getDirectoryItems (libDir </> "html")
+ themes <- mapM directoryTheme $ discoverThemes themeDirs
+ return $ sequenceEither themes
+ where
+ discoverThemes paths =
+ filterExt ".std-theme" paths ++ filterExt ".theme" paths
+ filterExt ext = filter ((== ext).takeExtension)
+
+
+-- | Build a theme from a single .css file
+singleFileTheme :: FilePath -> IO PossibleTheme
+singleFileTheme path =
+ if isCssFilePath path
+ then retRight $ Theme name file [path]
+ else errMessage "File extension isn't .css" path
+ where
+ name = takeBaseName path
+ file = takeFileName path
+
+
+-- | Build a theme from a directory
+directoryTheme :: FilePath -> IO PossibleTheme
+directoryTheme path = do
+ items <- getDirectoryItems path
+ case filter isCssFilePath items of
+ [cf] -> retRight $ Theme (takeBaseName path) (takeFileName cf) items
+ [] -> errMessage "No .css file in theme directory" path
+ _ -> errMessage "More than one .css file in theme directory" path
+
+
+-- | Check if we have a built in theme
+doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool
+doesBuiltInExist pts s = fmap (either (const False) test) pts
+ where test = isJust . findTheme s
+
+
+-- | Find a built in theme
+builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme
+builtInTheme pts s = either Left fetch <$> pts
+ where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s
+
+
+--------------------------------------------------------------------------------
+-- * CSS Theme Arguments
+--------------------------------------------------------------------------------
+
+-- | Process input flags for CSS Theme arguments
+getThemes :: FilePath -> [Flag] -> IO PossibleThemes
+getThemes libDir flags =
+ liftM concatEither (mapM themeFlag flags) >>= someTheme
+ where
+ themeFlag :: Flag -> IO (Either String Themes)
+ themeFlag (Flag_CSS path) = (liftM . liftEither) (:[]) (theme path)
+ themeFlag (Flag_BuiltInThemes) = builtIns
+ themeFlag _ = retRight []
+
+ theme :: FilePath -> IO PossibleTheme
+ theme path = pick path
+ [(doesFileExist, singleFileTheme),
+ (doesDirectoryExist, directoryTheme),
+ (doesBuiltInExist builtIns, builtInTheme builtIns)]
+ "Theme not found"
+
+ pick :: FilePath
+ -> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)] -> String
+ -> IO PossibleTheme
+ pick path [] msg = errMessage msg path
+ pick path ((test,build):opts) msg = do
+ pass <- test path
+ if pass then build path else pick path opts msg
+
+
+ someTheme :: Either String Themes -> IO (Either String Themes)
+ someTheme (Right []) = standardTheme libDir
+ someTheme est = return est
+
+ builtIns = defaultThemes libDir
+
+
+errMessage :: String -> FilePath -> IO (Either String a)
+errMessage msg path = return (Left msg')
+ where msg' = "Error: " ++ msg ++ ": \"" ++ path ++ "\"\n"
+
+
+retRight :: a -> IO (Either String a)
+retRight = return . Right
+
+
+--------------------------------------------------------------------------------
+-- * File Utilities
+--------------------------------------------------------------------------------
+
+
+getDirectoryItems :: FilePath -> IO [FilePath]
+getDirectoryItems path =
+ map (combine path) . filter notDot <$> getDirectoryContents path
+ where notDot s = s /= "." && s /= ".."
+
+
+isCssFilePath :: FilePath -> Bool
+isCssFilePath path = takeExtension path == ".css"
+
+
+--------------------------------------------------------------------------------
+-- * Style Sheet Utilities
+--------------------------------------------------------------------------------
+
+cssFiles :: Themes -> [String]
+cssFiles ts = nub $ concatMap themeFiles ts
+
+
+styleSheet :: Themes -> Html
+styleSheet ts = toHtml $ zipWith mkLink rels ts
+ where
+ rels = "stylesheet" : repeat "alternate stylesheet"
+ mkLink aRel t =
+ thelink
+ ! [ href (themeHref t), rel aRel, thetype "text/css",
+ XHtml.title (themeName t)
+ ]
+ << noHtml
+
+--------------------------------------------------------------------------------
+-- * Either Utilities
+--------------------------------------------------------------------------------
+
+-- These three routines are here because Haddock does not have access to the
+-- Control.Monad.Error module which supplies the Functor and Monad instances
+-- for Either String.
+
+sequenceEither :: [Either a b] -> Either a [b]
+sequenceEither es = maybe (Right $ rights es) Left (listToMaybe (lefts es))
+
+
+liftEither :: (b -> c) -> Either a b -> Either a c
+liftEither f = either Left (Right . f)
+
+
+concatEither :: [Either a [b]] -> Either a [b]
+concatEither = liftEither concat . sequenceEither
+
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs
new file mode 100644
index 00000000..122861c3
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs
@@ -0,0 +1,37 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.Types
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Types (
+ SourceURLs, WikiURLs,
+ LinksInfo,
+ Splice,
+ Unicode,
+) where
+
+
+import Data.Map
+import GHC
+
+
+-- the base, module and entity URLs for the source code and wiki links.
+type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath, Map PackageId FilePath)
+type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)
+
+
+-- The URL for source and wiki links
+type LinksInfo = (SourceURLs, WikiURLs)
+
+-- Whether something is a splice or not
+type Splice = Bool
+
+-- Whether unicode syntax is to be used
+type Unicode = Bool
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
new file mode 100644
index 00000000..cbcbbd6d
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -0,0 +1,218 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.Util
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Utils (
+ renderToString,
+
+ namedAnchor, linkedAnchor,
+ spliceURL,
+ groupId,
+
+ (<+>), (<=>), char,
+ keyword, punctuate,
+
+ braces, brackets, pabrackets, parens, parenList, ubxParenList,
+ arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote,
+
+ hsep, vcat,
+
+ collapseSection, collapseToggle, collapseControl,
+) where
+
+
+import Haddock.GhcUtils
+import Haddock.Utils
+
+import Data.Maybe
+
+import Text.XHtml hiding ( name, title, p, quote )
+import qualified Text.XHtml as XHtml
+
+import GHC ( SrcSpan(..), srcSpanStartLine, Name )
+import Module ( Module )
+import Name ( getOccString, nameOccName, isValOcc )
+
+
+spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->
+ Maybe SrcSpan -> String -> String
+spliceURL maybe_file maybe_mod maybe_name maybe_loc = run
+ where
+ file = fromMaybe "" maybe_file
+ mdl = case maybe_mod of
+ Nothing -> ""
+ Just m -> moduleString m
+
+ (name, kind) =
+ case maybe_name of
+ Nothing -> ("","")
+ Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v")
+ | otherwise -> (escapeStr (getOccString n), "t")
+
+ line = case maybe_loc of
+ Nothing -> ""
+ Just span_ ->
+ case span_ of
+ RealSrcSpan span__ ->
+ show $ srcSpanStartLine span__
+ UnhelpfulSpan _ ->
+ error "spliceURL UnhelpfulSpan"
+
+ run "" = ""
+ run ('%':'M':rest) = mdl ++ run rest
+ run ('%':'F':rest) = file ++ run rest
+ run ('%':'N':rest) = name ++ run rest
+ run ('%':'K':rest) = kind ++ run rest
+ run ('%':'L':rest) = line ++ run rest
+ run ('%':'%':rest) = '%' : run rest
+
+ run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest
+ run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest
+ run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest
+ run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest
+
+ run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) =
+ map (\x -> if x == '.' then c else x) mdl ++ run rest
+
+ run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) =
+ map (\x -> if x == '/' then c else x) file ++ run rest
+
+ run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest
+
+ run (c:rest) = c : run rest
+
+
+renderToString :: Bool -> Html -> String
+renderToString debug html
+ | debug = renderHtml html
+ | otherwise = showHtml html
+
+
+hsep :: [Html] -> Html
+hsep [] = noHtml
+hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls
+
+-- | Concatenate a series of 'Html' values vertically, with linebreaks in between.
+vcat :: [Html] -> Html
+vcat [] = noHtml
+vcat htmls = foldr1 (\a b -> a+++br+++b) htmls
+
+
+infixr 8 <+>
+(<+>) :: Html -> Html -> Html
+a <+> b = a +++ sep +++ b
+ where
+ sep = if isNoHtml a || isNoHtml b then noHtml else toHtml " "
+
+-- | Join two 'Html' values together with a linebreak in between.
+-- Has 'noHtml' as left identity.
+infixr 8 <=>
+(<=>) :: Html -> Html -> Html
+a <=> b = a +++ sep +++ b
+ where
+ sep = if isNoHtml a then noHtml else br
+
+
+keyword :: String -> Html
+keyword s = thespan ! [theclass "keyword"] << toHtml s
+
+
+equals, comma :: Html
+equals = char '='
+comma = char ','
+
+
+char :: Char -> Html
+char c = toHtml [c]
+
+
+quote :: Html -> Html
+quote h = char '`' +++ h +++ '`'
+
+
+parens, brackets, pabrackets, braces :: Html -> Html
+parens h = char '(' +++ h +++ char ')'
+brackets h = char '[' +++ h +++ char ']'
+pabrackets h = toHtml "[:" +++ h +++ toHtml ":]"
+braces h = char '{' +++ h +++ char '}'
+
+
+punctuate :: Html -> [Html] -> [Html]
+punctuate _ [] = []
+punctuate h (d0:ds) = go d0 ds
+ where
+ go d [] = [d]
+ go d (e:es) = (d +++ h) : go e es
+
+
+parenList :: [Html] -> Html
+parenList = parens . hsep . punctuate comma
+
+
+ubxParenList :: [Html] -> Html
+ubxParenList = ubxparens . hsep . punctuate comma
+
+
+ubxparens :: Html -> Html
+ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"
+
+
+dcolon, arrow, darrow, forallSymbol :: Bool -> Html
+dcolon unicode = toHtml (if unicode then "∷" else "::")
+arrow unicode = toHtml (if unicode then "→" else "->")
+darrow unicode = toHtml (if unicode then "⇒" else "=>")
+forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall"
+
+
+dot :: Html
+dot = toHtml "."
+
+
+-- | Generate a named anchor
+namedAnchor :: String -> Html -> Html
+namedAnchor n = anchor ! [XHtml.name n]
+
+
+linkedAnchor :: String -> Html -> Html
+linkedAnchor n = anchor ! [href ('#':n)]
+
+
+-- | generate an anchor identifier for a group
+groupId :: String -> String
+groupId g = makeAnchorId ("g:" ++ g)
+
+--
+-- A section of HTML which is collapsible.
+--
+
+-- | Attributes for an area that can be collapsed
+collapseSection :: String -> Bool -> String -> [HtmlAttr]
+collapseSection id_ state classes = [ identifier sid, theclass cs ]
+ where cs = unwords (words classes ++ [pick state "show" "hide"])
+ sid = "section." ++ id_
+
+-- | Attributes for an area that toggles a collapsed area
+collapseToggle :: String -> [HtmlAttr]
+collapseToggle id_ = [ strAttr "onclick" js ]
+ where js = "toggleSection('" ++ id_ ++ "')";
+
+-- | Attributes for an area that toggles a collapsed area,
+-- and displays a control.
+collapseControl :: String -> Bool -> String -> [HtmlAttr]
+collapseControl id_ state classes =
+ [ identifier cid, theclass cs ] ++ collapseToggle id_
+ where cs = unwords (words classes ++ [pick state "collapser" "expander"])
+ cid = "control." ++ id_
+
+
+pick :: Bool -> a -> a -> a
+pick True t _ = t
+pick False _ f = f