diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 920 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 249 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 236 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 171 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Themes.hs | 209 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Types.hs | 37 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 218 |
7 files changed, 2040 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..3bf4322d --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -0,0 +1,920 @@ +{-# 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 Control.Applicative +import Data.List ( intersperse, sort ) +import qualified Data.Map as Map +import Data.Maybe +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 qtvs prov req ty) -> + ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty 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 -> + (HsExplicitFlag, LHsTyVarBndrs DocName) -> + LHsContext DocName -> LHsContext DocName -> + LHsType DocName -> + [(DocName, Fixity)] -> + Splice -> Unicode -> Qualification -> Html +ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual + | summary = pref1 + | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual) + +++ docSection Nothing qual doc + where + pref1 = hsep [ keyword "pattern" + , ppBinder summary occname + , dcolon unicode + , ppLTyVarBndrs expl qtvs unicode qual + , cxt + , ppLType unicode qual typ + ] + + cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of + (Nothing, Nothing) -> noHtml + (Nothing, Just req) -> parens noHtml <+> darr <+> req <+> darr + (Just prov, Nothing) -> prov <+> darr + (Just prov, Just req) -> prov <+> darr <+> req <+> darr + + darr = darrow unicode + occname = nameOccName . getName $ name + +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 curName qual doc + | otherwise = topDeclElem links loc splice docnames pref2 +++ + subArguments qual (do_args 0 sep typ) +++ docSection curName qual doc + where + curName = getName <$> listToMaybe docnames + 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 _ _ tvs lctxt ltype) + = case unLoc lctxt of + [] -> do_largs n leader' ltype + _ -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) + : do_largs n (darrow unicode) ltype + where leader' = leader <+> ppForAll tvs unicode qual + 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, [])] + +ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html +ppForAll tvs unicode qual = + case [ppKTv n k | L _ (KindedTyVar n k) <- hsQTvBndrs tvs] of + [] -> noHtml + ts -> forallSymbol unicode <+> hsep ts +++ dot + where ppKTv n k = parens $ + ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k + +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 Nothing 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 TyFamEqn { tfe_tycon = n, tfe_rhs = rhs + , tfe_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 + + +ppLContextMaybe :: Located (HsContext DocName) -> Unicode -> Qualification -> Maybe Html +ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc + +ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html +ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ + ppContextNoLocsMaybe (map unLoc cxt) unicode qual + + +ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html +ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $ + ppContextNoLocsMaybe cxt unicode qual + + +ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html +ppContextNoLocsMaybe [] _ _ = Nothing +ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual + +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 Nothing 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 Nothing 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,_) -> any (\cn -> cn == n) + (map unLoc (con_names (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 (ppOcc + : map (ppLParendType unicode qual) args), noHtml, noHtml) + RecCon fields -> + (header_ unicode qual +++ ppOcc <+> char '{', + doRecordFields fields, + char '}') + InfixCon arg1 arg2 -> + (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1, + ppOccInfix, 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 -> (ppOcc <+> dcolon unicode <+> + ppForAllCon 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) (map unLoc fields)) + doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [ + ppForAllCon forall_ ltvs lcontext unicode qual, + ppLType unicode qual (foldr mkFunTy resTy args) ] + + header_ = ppConstrHdr forall_ tyVars context + occ = map (nameOccName . getName . unLoc) $ con_names con + + ppOcc = case occ of + [one] -> ppBinder summary one + _ -> hsep (punctuate comma (map (ppBinder summary) occ)) + + ppOccInfix = case occ of + [one] -> ppBinderInfix summary one + _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) + + 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 ". " + Qualified -> noHtml + 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_ +++ ppOcc) + : map (ppLParendType unicode qual) args) + <+> fixity + + RecCon _ -> header_ +++ ppOcc <+> fixity + + InfixCon arg1 arg2 -> + hsep [header_ +++ ppLParendType unicode qual arg1, + ppOccInfix, + 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) (map unLoc fields)) + doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html + doGADTCon args resTy = ppOcc <+> dcolon unicode + <+> hsep [ppForAllCon 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 = map (nameOccName . getName . unLoc) $ con_names con + + ppOcc = case occ of + [one] -> ppBinder False one + _ -> hsep (punctuate comma (map (ppBinder False) occ)) + + ppOccInfix = case occ of + [one] -> ppBinderInfix False one + _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) + + 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 $ head $ con_names 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 names ltype _) = + (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, + mbDoc, + []) + where + -- don't use cd_fld_doc for same reason we don't use con_doc above + -- Where there is more than one name, they all have the same documentation + mbDoc = lookup (unL $ head names) subdocs >>= combineDocumentation . fst + + +ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html +ppShortField summary unicode qual (ConDeclField names ltype _) + = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names)) + <+> 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 + +ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName + -> Located (HsContext DocName) -> Unicode -> Qualification -> Html +ppForAllCon expl tvs cxt unicode qual = + forall_part <+> ppLContext cxt unicode qual + where + forall_part = ppLTyVarBndrs expl tvs unicode qual + +ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName + -> Unicode -> Qualification + -> Html +ppLTyVarBndrs expl tvs unicode _qual + | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot + | otherwise = noHtml + where + show_forall = not (null (hsQTvBndrs tvs)) && is_explicit + is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} + + +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 extra tvs ctxt ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual + <+> ppr_mono_lty pREC_TOP ty unicode qual + where ctxt' = case extra of + Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt + Nothing -> ctxt + +-- 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 _ HsWildcardTy _ _ = char '_' + +ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name + +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..96d734eb --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -0,0 +1,249 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Data.List +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Utils +import Haddock.Types +import Haddock.Utils +import Haddock.Doc (combineDocumentation, emptyMetaDoc, + metaDocAppend, metaConcat) + +import Text.XHtml hiding ( name, p, quote ) +import Data.Maybe (fromMaybe) + +import GHC +import Name + +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"] + +-- | We use this intermediate type to transform the input 'Doc' tree +-- in an arbitrary way before rendering, such as grouping some +-- elements. This is effectivelly a hack to prevent the 'Doc' type +-- from changing if it is possible to recover the layout information +-- we won't need after the fact. +data Hack a id = + UntouchedDoc (MetaDoc a id) + | CollapsingHeader (Header (DocH a id)) (MetaDoc a id) Int (Maybe String) + | HackAppend (Hack a id) (Hack a id) + deriving Eq + +-- | Group things under bold 'DocHeader's together. +toHack :: Int -- ^ Counter for header IDs which serves to assign + -- unique identifiers within the comment scope + -> Maybe String + -- ^ It is not enough to have unique identifier within the + -- scope of the comment: if two different comments have the + -- same ID for headers, the collapse/expand behaviour will act + -- on them both. This serves to make each header a little bit + -- more unique. As we can't export things with the same names, + -- this should work more or less fine: it is in fact the + -- implicit assumption the collapse/expand mechanism makes for + -- things like ‘Instances’ boxes. + -> [MetaDoc a id] -> Hack a id +toHack _ _ [] = UntouchedDoc emptyMetaDoc +toHack _ _ [x] = UntouchedDoc x +toHack n nm (MetaDoc { _doc = DocHeader (Header l (DocBold x)) }:xs) = + let -- Header with dropped bold + h = Header l x + -- Predicate for takeWhile, grab everything including ‘smaller’ + -- headers + p (MetaDoc { _doc = DocHeader (Header l' _) }) = l' > l + p _ = True + -- Stuff ‘under’ this header + r = takeWhile p xs + -- Everything else that didn't make it under + r' = drop (length r) xs + app y [] = y + app y ys = HackAppend y (toHack (n + 1) nm ys) + in case r of + -- No content under this header + [] -> CollapsingHeader h emptyMetaDoc n nm `app` r' + -- We got something out, stitch it back together into one chunk + y:ys -> CollapsingHeader h (foldl metaDocAppend y ys) n nm `app` r' +toHack n nm (x:xs) = HackAppend (UntouchedDoc x) (toHack n nm xs) + +-- | Remove ‘top-level’ 'DocAppend's turning them into a flat list. +-- This lends itself much better to processing things in order user +-- might look at them, such as in 'toHack'. +flatten :: MetaDoc a id -> [MetaDoc a id] +flatten MetaDoc { _meta = m, _doc = DocAppend x y } = + let f z = MetaDoc { _meta = m, _doc = z } + in flatten (f x) ++ flatten (f y) +flatten x = [x] + +-- | Generate the markup needed for collapse to happen. For +-- 'UntouchedDoc' and 'HackAppend' we do nothing more but +-- extract/append the underlying 'Doc' and convert it to 'Html'. For +-- 'CollapsingHeader', we attach extra info to the generated 'Html' +-- that allows us to expand/collapse the content. +hackMarkup :: DocMarkup id Html -> Hack (ModuleName, OccName) id -> Html +hackMarkup fmt' h' = + let (html, ms) = hackMarkup' fmt' h' + in html +++ renderMeta fmt' (metaConcat ms) + where + hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id + -> (Html, [Meta]) + hackMarkup' fmt h = case h of + UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) + CollapsingHeader (Header lvl titl) par n nm -> + let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n + col' = collapseControl id_ True "caption" + instTable = (thediv ! collapseSection id_ False [] <<) + lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] + getHeader = fromMaybe caption (lookup lvl lvs) + subCaption = getHeader ! col' << markup fmt titl + in ((subCaption +++) . instTable $ markup fmt (_doc par), [_meta par]) + HackAppend d d' -> let (x, m) = hackMarkup' fmt d + (y, m') = hackMarkup' fmt d' + in (markupAppend fmt x y, m ++ m') + +renderMeta :: DocMarkup id Html -> Meta -> Html +renderMeta fmt (Meta { _version = Just x }) = + markupParagraph fmt . markupEmphasis fmt . toHtml $ + "Since: " ++ formatVersion x + where + formatVersion v = concat . intersperse "." $ map show v +renderMeta _ _ = noHtml + +-- | Goes through 'hackMarkup' to generate the 'Html' rather than +-- skipping straight to 'markup': this allows us to employ XHtml +-- specific hacks to the tree first. +markupHacked :: DocMarkup id Html + -> Maybe String + -> MDoc id + -> Html +markupHacked fmt n = hackMarkup fmt . toHack 0 n . flatten + +-- 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 :: Maybe String -- ^ Name of the thing this doc is for. See + -- comments on 'toHack' for details. + -> Qualification -> MDoc DocName -> Html +docToHtml n qual = markupHacked fmt n . 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 :: Maybe String -- ^ See 'toHack' + -> Qualification -> MDoc DocName -> Html +docToHtmlNoAnchors n qual = markupHacked fmt n . cleanup + where fmt = parHtmlMarkup qual False (ppDocName qual Raw) + +origDocToHtml :: Qualification -> MDoc Name -> Html +origDocToHtml qual = markupHacked fmt Nothing . cleanup + where fmt = parHtmlMarkup qual True (const $ ppName Raw) + + +rdrDocToHtml :: Qualification -> MDoc RdrName -> Html +rdrDocToHtml qual = markupHacked fmt Nothing . 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 :: Maybe Name -- ^ Name of the thing this doc is for + -> Qualification -> Documentation DocName -> Html +docSection n qual = maybe noHtml (docSection_ n qual) . combineDocumentation + + +docSection_ :: Maybe Name -- ^ Name of the thing this doc is for + -> Qualification -> MDoc DocName -> Html +docSection_ n qual = + (docElement thediv <<) . docToHtml (getOccString <$> n) qual + + +cleanup :: MDoc a -> MDoc a +cleanup = overDoc (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..b2c60534 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -0,0 +1,236 @@ +----------------------------------------------------------------------------- +-- | +-- 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 (MDoc 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 Nothing 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 Nothing 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 -- ^ Class name, used for anchor generation + -> [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 = modulePackageKey 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..3d1db887 --- /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 PackageKey FilePath, Map PackageKey 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 |