diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 15 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker.hs | 49 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 306 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 183 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 18 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 4 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 28 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Themes.hs | 2 |
10 files changed, 346 insertions, 263 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index b76d14b5..1f98ef9c 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -254,13 +254,14 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - tyVarArg (UserTyVar _ n) = HsTyVar noExtField NotPromoted n - tyVarArg (KindedTyVar _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty - tyVarArg _ = panic "ppCtor" + resType = let c = HsTyVar noExtField NotPromoted (reL (tcdName dat)) + as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) + in apps (map reL (c : as)) - resType = apps $ map reL $ - (HsTyVar noExtField NotPromoted (reL (tcdName dat))) : - map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) + tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn + tyVarBndr2Type (UserTyVar _ n) = HsTyVar noExtField NotPromoted n + tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) k + tyVarBndr2Type (XTyVarBndr _) = panic "haddock:ppCtor" ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f @@ -325,7 +326,7 @@ markupTag dflags = Markup { markupString = str, markupAppend = (++), markupIdentifier = box (TagInline "a") . str . out dflags, - markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd, + markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd), markupModule = box (TagInline "a") . str, markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 7571db9e..3f5483fe 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -7,7 +7,7 @@ module Haddock.Backends.Hyperlinker import Haddock.Types -import Haddock.Utils (writeUtf8File) +import Haddock.Utils (writeUtf8File, out, verbose, Verbosity) import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types @@ -18,12 +18,13 @@ import Data.Maybe import System.Directory import System.FilePath -import HieTypes ( HieFile(..), HieASTs(..) ) +import HieTypes ( HieFile(..), HieAST(..), HieASTs(..), NodeInfo(..) ) import HieBin ( readHieFile, hie_file_result) import Data.Map as M import FastString ( mkFastString ) import Module ( Module, moduleName ) import NameCache ( initNameCache ) +import SrcLoc ( mkRealSrcLoc, realSrcLocSpan ) import UniqSupply ( mkSplitUniqSupply ) @@ -32,27 +33,28 @@ import UniqSupply ( mkSplitUniqSupply ) -- Note that list of interfaces should also contain interfaces normally hidden -- when generating documentation. Otherwise this could lead to dead links in -- produced source. -ppHyperlinkedSource :: FilePath -- ^ Output directory +ppHyperlinkedSource :: Verbosity + -> FilePath -- ^ Output directory -> FilePath -- ^ Resource directory -> Maybe FilePath -- ^ Custom CSS file path -> Bool -- ^ Flag indicating whether to pretty-print HTML -> M.Map Module SrcPath -- ^ Paths to sources -> [Interface] -- ^ Interfaces for which we create source -> IO () -ppHyperlinkedSource outdir libdir mstyle pretty srcs' ifaces = do +ppHyperlinkedSource verbosity outdir libdir mstyle pretty srcs' ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir </> srcCssFile copyFile (libdir </> "html" </> highlightScript) $ srcdir </> highlightScript - mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces + mapM_ (ppHyperlinkedModuleSource verbosity srcdir pretty srcs) ifaces where srcdir = outdir </> hypSrcDir srcs = (srcs', M.mapKeys moduleName srcs') -- | Generate hyperlinked source for particular interface. -ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMaps -> Interface -> IO () -ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of +ppHyperlinkedModuleSource :: Verbosity -> FilePath -> Bool -> SrcMaps -> Interface -> IO () +ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile iface of Just hfp -> do -- Parse the GHC-produced HIE file u <- mkSplitUniqSupply 'a' @@ -64,25 +66,38 @@ ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of <$> (readHieFile (initNameCache u []) hfp) -- Get the AST and tokens corresponding to the source file we want - let mast | M.size asts == 1 = snd <$> M.lookupMin asts - | otherwise = M.lookup (mkFastString file) asts + let fileFs = mkFastString file + mast | M.size asts == 1 = snd <$> M.lookupMin asts + | otherwise = M.lookup fileFs asts + ast = fromMaybe (emptyHieAst fileFs) mast + fullAst = recoverFullIfaceTypes df types ast tokens = parse df file rawSrc + -- Warn if we didn't find an AST, but there were still ASTs + if M.null asts + then pure () + else out verbosity verbose $ unwords [ "couldn't find ast for" + , file, show (M.keys asts) ] + -- Produce and write out the hyperlinked sources - case mast of - Just ast -> - let fullAst = recoverFullIfaceTypes df types ast - in writeUtf8File path . renderToString pretty . render' fullAst $ tokens - Nothing - | M.size asts == 0 -> return () - | otherwise -> error $ unwords [ "couldn't find ast for" - , file, show (M.keys asts) ] + writeUtf8File path . renderToString pretty . render' fullAst $ tokens Nothing -> return () where df = ifaceDynFlags iface render' = render (Just srcCssFile) (Just highlightScript) srcs path = srcdir </> hypSrcModuleFile (ifaceMod iface) + emptyNodeInfo = NodeInfo + { nodeAnnotations = mempty + , nodeType = [] + , nodeIdentifiers = mempty + } + emptyHieAst fileFs = Node + { nodeInfo = emptyNodeInfo + , nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0) + , nodeChildren = [] + } + -- | Name of CSS file in output directory. srcCssFile :: FilePath srcCssFile = "style.css" diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index e9029ae6..0247d567 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -9,7 +9,7 @@ import qualified Data.ByteString as BS import BasicTypes ( IntegralLit(..) ) import DynFlags -import ErrUtils ( emptyMessages, pprLocErrMsg ) +import ErrUtils ( pprLocErrMsg ) import FastString ( mkFastString ) import Lexer ( P(..), ParseResult(..), PState(..), Token(..) , mkPStatePure, lexer, mkParserFlags', getErrorMessages, addFatalError ) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index 67eb10b5..612f3f08 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -102,7 +102,7 @@ type PrintedType = String -- > hieAst -- -- However, this is very inefficient (both in time and space) because the --- mutliple calls to 'recoverFullType' don't share intermediate results. This +-- multiple calls to 'recoverFullType' don't share intermediate results. This -- function fixes that. recoverFullIfaceTypes :: DynFlags diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 6fd7969f..f2fb1041 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -103,6 +103,10 @@ haddockSty = "haddock.sty" type LaTeX = Pretty.Doc +-- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100 +-- often overflows the line). +latex2String :: LaTeX -> String +latex2String = fullRender PageMode 90 1 txtPrinter "" ppLaTeXTop :: String @@ -156,7 +160,7 @@ ppLaTeXModule _title odir iface = do text "\\haddockbeginheader", verb $ vcat [ text "module" <+> text mdl_str <+> lparen, - text " " <> fsep (punctuate (text ", ") $ + text " " <> fsep (punctuate (char ',') $ map exportListItem $ filter forSummary exports), text " ) where" @@ -171,7 +175,7 @@ ppLaTeXModule _title odir iface = do body = processExports exports -- - writeUtf8File (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex) + writeUtf8File (odir </> moduleLaTeXFile mdl) (show tex) -- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX @@ -287,7 +291,7 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print -> LaTeX ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of - TyClD _ d@FamDecl {} -> ppFamDecl doc instances d unicode + TyClD _ d@FamDecl {} -> ppFamDecl False doc instances d unicode TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now @@ -295,7 +299,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode ForD _ d -> ppFor (doc, fnArgsDoc) d unicode InstD _ _ -> empty @@ -307,7 +311,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = - ppFunSig doc [name] (hsSigTypeI typ) unicode + ppFunSig Nothing doc [name] (hsSigTypeI typ) unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -317,13 +321,14 @@ ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" ------------------------------------------------------------------------------- -- | Pretty-print a data\/type family declaration -ppFamDecl :: Documentation DocName -- ^ this decl's docs +ppFamDecl :: Bool -- ^ is the family associated? + -> Documentation DocName -- ^ this decl's docs -> [DocInstance DocNameI] -- ^ relevant instances -> TyClDecl DocNameI -- ^ family to print -> Bool -- ^ unicode -> LaTeX -ppFamDecl doc instances decl unicode = - declWithDoc (ppFamHeader (tcdFam decl) unicode <+> whereBit) +ppFamDecl associated doc instances decl unicode = + declWithDoc (ppFamHeader (tcdFam decl) unicode associated <+> whereBit) (if null body then Nothing else Just (vcat body)) $$ instancesBit where @@ -335,6 +340,7 @@ ppFamDecl doc instances decl unicode = familyEqns | FamilyDecl { fdInfo = ClosedTypeFamily (Just eqns) } <- tcdFam decl + , not (null eqns) = Just (text "\\haddockbeginargs" $$ vcat [ decltt (ppFamDeclEqn eqn) <+> nl | L _ eqn <- eqns ] $$ text "\\end{tabulary}\\par") @@ -356,22 +362,26 @@ ppFamDecl doc instances decl unicode = -- | Print the LHS of a type\/data family declaration. ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print - -> Bool -- ^ unicode - -> LaTeX -ppFamHeader (XFamilyDecl nec) _ = noExtCon nec + -> Bool -- ^ unicode + -> Bool -- ^ is the family associated? + -> LaTeX +ppFamHeader (XFamilyDecl nec) _ _ = noExtCon nec ppFamHeader (FamilyDecl { fdLName = L _ name , fdTyVars = tvs , fdInfo = info , fdResultSig = L _ result , fdInjectivityAnn = injectivity }) - unicode = - leader <+> keyword "family" <+> famName <+> famSig <+> injAnn + unicode associated = + famly leader <+> famName <+> famSig <+> injAnn where leader = case info of OpenTypeFamily -> keyword "type" ClosedTypeFamily _ -> keyword "type" DataFamily -> keyword "data" + famly | associated = id + | otherwise = (<+> keyword "family") + famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs) famSig = case result of @@ -414,17 +424,23 @@ ppTySyn _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI - -> Bool -> LaTeX -ppFunSig doc docnames (L _ typ) unicode = +ppFunSig + :: Maybe LaTeX -- ^ a prefix to put right before the signature + -> DocForDecl DocName -- ^ documentation + -> [DocName] -- ^ pattern names in the pattern signature + -> LHsType DocNameI -- ^ type of the pattern synonym + -> Bool -- ^ unicode + -> LaTeX +ppFunSig leader doc docnames (L _ typ) unicode = ppTypeOrFunSig typ doc - ( ppTypeSig names typ False - , hsep . punctuate comma $ map ppSymName names + ( lead $ ppTypeSig names typ False + , lead $ hsep . punctuate comma $ map ppSymName names , dcolon unicode ) unicode where names = map getName docnames + lead = maybe id (<+>) leader -- | Pretty-print a pattern synonym ppLPatSig :: DocForDecl DocName -- ^ documentation @@ -433,15 +449,7 @@ ppLPatSig :: DocForDecl DocName -- ^ documentation -> Bool -- ^ unicode -> LaTeX ppLPatSig doc docnames ty unicode - = ppTypeOrFunSig typ doc - ( keyword "pattern" <+> ppTypeSig names typ False - , keyword "pattern" <+> (hsep . punctuate comma $ map ppSymName names) - , dcolon unicode - ) - unicode - where - typ = unLoc (hsSigTypeI ty) - names = map getName docnames + = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigTypeI ty) unicode -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed. @@ -461,7 +469,7 @@ ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode text "\\end{tabulary}\\par" $$ fromMaybe empty (documentationToLaTeX doc) --- This splits up a type signature along `->` and adds docs (when they exist) +-- | This splits up a type signature along @->@ and adds docs (when they exist) -- to the arguments. The output is a list of (leader/seperator, argument and -- its doc) ppSubSigLike :: Bool -- ^ unicode @@ -479,13 +487,13 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] do_args _n leader (HsForAllTy _ fvf tvs ltype) = [ ( decltt leader - , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ - [ppForAllSeparator unicode fvf])) + , decltt (ppForAllPart unicode tvs fvf) <+> ppLType unicode ltype ) ] do_args n leader (HsQualTy _ lctxt ltype) - = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl) - : do_largs n (darrow unicode) ltype + = ( decltt leader + , decltt (ppLContextNoArrow lctxt unicode) <+> nl + ) : do_largs n (darrow unicode) ltype do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) = [ (decltt ldr, latex <+> nl) @@ -504,9 +512,9 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode -- mode since `->` and `::` are rendered as single characters. - gadtComma = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "," - gadtEnd = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "\\}" - gadtOpen = text "\\{" + gadtComma = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char ',' + gadtEnd = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char '}' + gadtOpen = char '{' ppForAllSeparator :: Bool -> ForallVisFlag -> LaTeX @@ -522,8 +530,9 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty -ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX] -ppTyVars = map (ppSymName . getName . hsLTyVarNameI) +-- | Pretty-print type variables. +ppTyVars :: Bool -> [LHsTyVarBndr DocNameI] -> [LaTeX] +ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc) tyvarNames :: LHsQTyVars DocNameI -> [Name] @@ -534,10 +543,9 @@ declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX declWithDoc decl doc = text "\\begin{haddockdesc}" $$ text "\\item[\\begin{tabular}{@{}l}" $$ - text (latexMonoFilter (show decl)) $$ - text "\\end{tabular}]" <> - (if isNothing doc then empty else text "\\haddockbegindoc") $$ - maybe empty id doc $$ + text (latexMonoFilter (latex2String decl)) $$ + text "\\end{tabular}]" $$ + maybe empty (\x -> text "{\\haddockbegindoc" $$ x <> text "}") doc $$ text "\\end{haddockdesc}" @@ -548,9 +556,9 @@ multiDecl :: [LaTeX] -> LaTeX multiDecl decls = text "\\begin{haddockdesc}" $$ vcat [ - text "\\item[" $$ - text (latexMonoFilter (show decl)) $$ - text "]" + text "\\item[\\begin{tabular}{@{}l}" $$ + text (latexMonoFilter (latex2String decl)) $$ + text "\\end{tabular}]" | decl <- decls ] $$ text "\\end{haddockdesc}" @@ -594,6 +602,7 @@ ppFds fds unicode = hsep (map (ppDocName . unLoc) vars2) +-- TODO: associated type defaults, docs on default methods ppClassDecl :: [DocInstance DocNameI] -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Bool -> LaTeX @@ -614,18 +623,28 @@ ppClassDecl instances doc subdocs body_ | null lsigs, null ats, null at_defs = Nothing | null ats, null at_defs = Just methodTable ---- | otherwise = atTable $$ methodTable - | otherwise = error "LaTeX.ppClassDecl" + | otherwise = Just (atTable $$ methodTable) + + atTable = + text "\\haddockpremethods{}" <> emph (text "Associated Types") $$ + vcat [ ppFamDecl True (fst doc) [] (FamDecl noExtField decl) True + | L _ decl <- ats + , let name = unL . fdLName $ decl + doc = lookupAnySubdoc name subdocs + ] + methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$ - vcat [ ppFunSig doc names (hsSigWcType typ) unicode - | L _ (TypeSig _ lnames typ) <- lsigs - , let doc = lookupAnySubdoc (head names) subdocs - names = map unLoc lnames ] - -- FIXME: is taking just the first name ok? Is it possible that - -- there are different subdocs for different names in a single - -- type signature? + vcat [ ppFunSig leader doc names (hsSigTypeI typ) unicode + | L _ (ClassOpSig _ is_def lnames typ) <- lsigs + , let doc | is_def = noDocForDecl + | otherwise = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames + leader = if is_def then Just (keyword "default") else Nothing + ] + -- N.B. taking just the first name is ok. Signatures with multiple + -- names are expanded so that each name gets its own signature. instancesBit = ppDocInstances unicode instances @@ -644,6 +663,7 @@ ppDocInstances unicode (i : rest) isUndocdInstance :: DocInstance a -> Maybe (InstHead a) isUndocdInstance (i,Nothing,_,_) = Just i +isUndocdInstance (i,Just (MetaDoc _ DocEmpty),_,_) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside @@ -726,15 +746,21 @@ ppDataDecl pats instances subdocs doc dataDecl unicode = -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Bool -> LaTeX -ppConstrHdr forall tvs ctxt unicode - = (if null tvs then empty else ppForall) - <+> - (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") +ppConstrHdr + :: Bool -- ^ print explicit foralls + -> [LHsTyVarBndr DocNameI] -- ^ type variables + -> HsContext DocNameI -- ^ context + -> Bool -- ^ unicode + -> LaTeX +ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt where - ppForall = case forall of - True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " - False -> empty + ppForall + | null tvs || not forall_ = empty + | otherwise = ppForAllPart unicode tvs ForallInvis + + ppCtxt + | null ctxt = empty + | otherwise = ppContextNoArrow ctxt unicode <+> darrow unicode <> space -- | Pretty-print a constructor @@ -763,11 +789,10 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = -- First line of the constructor (no doc, no fields, single-line) decl = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarNameI) vars - context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False + } -> let context = unLoc (fromMaybe (noLoc []) cxt) header_ = ppConstrHdr forall_ tyVars context unicode in case det of -- Prefix constructor, e.g. 'Just a' @@ -1004,7 +1029,7 @@ ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode -ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode +ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode @@ -1017,7 +1042,7 @@ ppLHsTypeArg _ (HsArgPar _) = text "" ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) = - parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind + parens (ppDocName name <+> dcolon unicode <+> ppLKind unicode kind) ppHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec ppLKind :: Bool -> LHsKind DocNameI -> LaTeX @@ -1030,14 +1055,22 @@ ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell +ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> LaTeX +ppForAllPart unicode tvs fvf = hsep (forallSymbol unicode : tvs') <> fv + where + tvs' = ppTyVars unicode tvs + fv = case fvf of + ForallVis -> text "\\ " <> arrow unicode + ForallInvis -> dot + + ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode - = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> - ppForAllSeparator unicode fvf + = sep [ ppForAllPart unicode tvs fvf , ppr_mono_lty ty unicode ] ppr_mono_ty (HsQualTy _ ctxt ty) unicode = sep [ ppLContext ctxt unicode @@ -1051,7 +1084,7 @@ ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name ppr_mono_ty (HsTyVar _ IsPromoted (L _ name)) _ = char '\'' <> ppDocName name ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) -ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind) +ppr_mono_ty (HsKindSig _ ty kind) u = ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u ppr_mono_ty (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" @@ -1080,7 +1113,7 @@ ppr_mono_ty (HsParTy _ ty) unicode ppr_mono_ty (HsDocTy _ ty _) unicode = ppr_mono_lty ty unicode -ppr_mono_ty (HsWildCardTy _) _ = text "\\_" +ppr_mono_ty (HsWildCardTy _) _ = char '_' ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) @@ -1114,9 +1147,6 @@ ppSymName name | otherwise = ppName name -ppVerbOccName :: OccName -> LaTeX -ppVerbOccName = text . latexFilter . occNameString - ppIPName :: HsIPName -> LaTeX ppIPName = text . ('?':) . unpackFS . hsIPNameFS @@ -1124,18 +1154,9 @@ ppOccName :: OccName -> LaTeX ppOccName = text . occNameString -ppVerbDocName :: DocName -> LaTeX -ppVerbDocName = ppVerbOccName . nameOccName . getName - - -ppVerbRdrName :: RdrName -> LaTeX -ppVerbRdrName = ppVerbOccName . rdrNameOcc - - ppDocName :: DocName -> LaTeX ppDocName = ppOccName . nameOccName . getName - ppLDocName :: Located DocName -> LaTeX ppLDocName (L _ d) = ppDocName d @@ -1173,9 +1194,10 @@ latexMunge c s = c : s latexMonoMunge :: Char -> String -> String -latexMonoMunge ' ' s = '\\' : ' ' : s +latexMonoMunge ' ' (' ':s) = "\\ \\ " ++ s +latexMonoMunge ' ' ('\\':' ':s) = "\\ \\ " ++ s latexMonoMunge '\n' s = '\\' : '\\' : s -latexMonoMunge c s = latexMunge c s +latexMonoMunge c s = latexMunge c s ------------------------------------------------------------------------------- @@ -1183,34 +1205,40 @@ latexMonoMunge c s = latexMunge c s ------------------------------------------------------------------------------- -parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX) -parLatexMarkup ppId = Markup { - markupParagraph = \p v -> p v <> text "\\par" $$ text "", - markupEmpty = \_ -> empty, - markupString = \s v -> text (fixString v s), - markupAppend = \l r v -> l v <> r v, - markupIdentifier = markupId ppId, - markupIdentifierUnchecked = markupId (ppVerbOccName . snd), - markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), - markupWarning = \p v -> emph (p v), - markupEmphasis = \p v -> emph (p v), - markupBold = \p v -> bold (p v), - markupMonospaced = \p _ -> tt (p Mono), - markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", - markupPic = \p _ -> markupPic p, - markupMathInline = \p _ -> markupMathInline p, - markupMathDisplay = \p _ -> markupMathDisplay p, - markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", - markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), - markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", - markupHyperlink = \(Hyperlink u l) p -> markupLink u (fmap ($p) l), - markupAName = \_ _ -> empty, - markupProperty = \p _ -> quote $ verb $ text p, - markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e, - markupHeader = \(Header l h) p -> header l (h p), - markupTable = \(Table h b) p -> table h b p +latexMarkup :: HasOccName a => DocMarkup (Wrap a) (StringContext -> LaTeX -> LaTeX) +latexMarkup = Markup + { markupParagraph = \p v -> blockElem (p v (text "\\par")) + , markupEmpty = \_ -> id + , markupString = \s v -> inlineElem (text (fixString v s)) + , markupAppend = \l r v -> l v . r v + , markupIdentifier = \i v -> inlineElem (markupId v (fmap occName i)) + , markupIdentifierUnchecked = \i v -> inlineElem (markupId v (fmap snd i)) + , markupModule = \m _ -> inlineElem (let (mdl,_ref) = break (=='#') m in (tt (text mdl))) + , markupWarning = \p v -> p v + , markupEmphasis = \p v -> inlineElem (emph (p v empty)) + , markupBold = \p v -> inlineElem (bold (p v empty)) + , markupMonospaced = \p v -> inlineElem (markupMonospace p v) + , markupUnorderedList = \p v -> blockElem (itemizedList (map (\p' -> p' v empty) p)) + , markupPic = \p _ -> inlineElem (markupPic p) + , markupMathInline = \p _ -> inlineElem (markupMathInline p) + , markupMathDisplay = \p _ -> blockElem (markupMathDisplay p) + , markupOrderedList = \p v -> blockElem (enumeratedList (map (\p' -> p' v empty) p)) + , markupDefList = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l)) + , markupCodeBlock = \p _ -> blockElem (quote (verb (p Verb empty))) + , markupHyperlink = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l)) + , markupAName = \_ _ -> id -- TODO + , markupProperty = \p _ -> blockElem (quote (verb (text p))) + , markupExample = \e _ -> blockElem (quote (verb (text $ unlines $ map exampleToString e))) + , markupHeader = \(Header l h) p -> blockElem (header l (h p empty)) + , markupTable = \(Table h b) p -> blockElem (table h b p) } where + blockElem :: LaTeX -> LaTeX -> LaTeX + blockElem = ($$) + + inlineElem :: LaTeX -> LaTeX -> LaTeX + inlineElem = (<>) + header 1 d = text "\\section*" <> braces d header 2 d = text "\\subsection*" <> braces d header l d @@ -1223,6 +1251,9 @@ parLatexMarkup ppId = Markup { fixString Verb s = s fixString Mono s = latexMonoFilter s + markupMonospace p Verb = p Verb empty + markupMonospace p _ = tt (p Mono empty) + markupLink url mLabel = case mLabel of Just label -> text "\\href" <> braces (text url) <> braces label Nothing -> text "\\url" <> braces (text url) @@ -1239,35 +1270,28 @@ parLatexMarkup ppId = Markup { markupMathDisplay mathjax = text "\\[" <> text mathjax <> text "\\]" - markupId ppId_ id v = + markupId v wrappedOcc = case v of - Verb -> theid - Mono -> theid - Plain -> text "\\haddockid" <> braces theid - where theid = ppId_ id - - -latexMarkup :: DocMarkup DocName (StringContext -> LaTeX) -latexMarkup = parLatexMarkup ppVerbDocName - - -rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX) -rdrLatexMarkup = parLatexMarkup ppVerbRdrName - + Verb -> text i + Mono -> text "\\haddockid" <> braces (text . latexMonoFilter $ i) + Plain -> text "\\haddockid" <> braces (text . latexFilter $ i) + where i = showWrapped occNameString wrappedOcc docToLaTeX :: Doc DocName -> LaTeX -docToLaTeX doc = markup latexMarkup doc Plain - +docToLaTeX doc = markup latexMarkup doc Plain empty documentationToLaTeX :: Documentation DocName -> Maybe LaTeX documentationToLaTeX = fmap docToLaTeX . fmap _doc . combineDocumentation rdrDocToLaTeX :: Doc RdrName -> LaTeX -rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain +rdrDocToLaTeX doc = markup latexMarkup doc Plain empty -data StringContext = Plain | Verb | Mono +data StringContext + = Plain -- ^ all special characters have to be escape + | Mono -- ^ on top of special characters, escape space chraacters + | Verb -- ^ don't escape anything latexStripTrailingWhitespace :: Doc a -> Doc a @@ -1292,23 +1316,23 @@ latexStripTrailingWhitespace other = other itemizedList :: [LaTeX] -> LaTeX itemizedList items = - text "\\begin{itemize}" $$ + text "\\vbox{\\begin{itemize}" $$ vcat (map (text "\\item" $$) items) $$ - text "\\end{itemize}" + text "\\end{itemize}}" enumeratedList :: [LaTeX] -> LaTeX enumeratedList items = - text "\\begin{enumerate}" $$ + text "\\vbox{\\begin{enumerate}" $$ vcat (map (text "\\item " $$) items) $$ - text "\\end{enumerate}" + text "\\end{enumerate}}" descriptionList :: [(LaTeX,LaTeX)] -> LaTeX descriptionList items = - text "\\begin{description}" $$ - vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$ - text "\\end{description}" + text "\\vbox{\\begin{description}" $$ + vcat (map (\(a,b) -> text "\\item" <> brackets a <> text "\\hfill \\par" $$ b) items) $$ + text "\\end{description}}" tt :: LaTeX -> LaTeX @@ -1316,8 +1340,8 @@ tt ltx = text "\\haddocktt" <> braces ltx decltt :: LaTeX -> LaTeX -decltt ltx = text "\\haddockdecltt" <> braces ltx - +decltt ltx = text "\\haddockdecltt" <> braces (text filtered) + where filtered = latexMonoFilter (latex2String ltx) emph :: LaTeX -> LaTeX emph ltx = text "\\emph" <> braces ltx @@ -1325,6 +1349,12 @@ emph ltx = text "\\emph" <> braces ltx bold :: LaTeX -> LaTeX bold ltx = text "\\textbf" <> braces ltx +-- TODO: @verbatim@ is too much since +-- +-- * Haddock supports markup _inside_ of codeblocks. Right now, the LaTeX +-- representing that markup gets printed verbatim +-- * Verbatim environments are not supported everywhere (example: not nested +-- inside a @tabulary@ environment) verb :: LaTeX -> LaTeX verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}" -- NB. swallow a trailing \n in the verbatim text by appending the diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index a24715a7..c7ae15ca 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -36,11 +36,11 @@ import Text.XHtml hiding ( name, title, p, quote ) import BasicTypes (PromotionFlag(..), isPromoted) import GHC hiding (LexicalFixity(..)) +import qualified GHC import GHC.Exts import Name import BooleanFormula import RdrName ( rdrNameOcc ) -import Outputable ( panic ) -- | Pretty print a declaration ppDecl :: Bool -- ^ print summary info only @@ -75,14 +75,14 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = - ppFunSig summary links loc doc (map unLoc lnames) lty fixities + ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities splice unicode pkg qual -ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual = - ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) +ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual = + ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ) splice unicode pkg qual HideEmptyContexts where pp_typ = ppLType unicode qual HideEmptyContexts typ @@ -133,8 +133,8 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) curname = getName <$> listToMaybe docnames --- This splits up a type signature along `->` and adds docs (when they exist) to --- the arguments. +-- | This splits up a type signature along @->@ and adds docs (when they exist) +-- to the arguments. -- -- If one passes in a list of the available subdocs, any top-level `HsRecTy` -- found will be expanded out into their fields. @@ -152,9 +152,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] do_args n leader (HsForAllTy _ fvf tvs ltype) - = do_largs n leader' ltype - where - leader' = leader <+> ppForAll tvs unicode qual fvf + = do_largs n (leader <+> ppForAllPart unicode qual tvs fvf) ltype do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt) @@ -188,22 +186,6 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ gadtOpen = toHtml "{" - -ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> ForallVisFlag - -> Html -ppForAll tvs unicode qual fvf = - case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of - [] -> noHtml - ts -> forallSymbol unicode <+> hsep ts +++ ppForAllSeparator unicode fvf - where ppKTv n k = parens $ - ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k - -ppForAllSeparator :: Unicode -> ForallVisFlag -> Html -ppForAllSeparator unicode fvf = - case fvf of - ForallVis -> spaceHtml +++ arrow unicode - ForallInvis -> dot - ppFixities :: [(DocName, Fixity)] -> Qualification -> Html ppFixities [] _ = noHtml ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge @@ -236,7 +218,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual - = ppFunSig summary links loc doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual + = ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -268,10 +250,6 @@ ppTypeSig summary nms pp_ty unicode = htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms -ppTyName :: Name -> Html -ppTyName = ppName Prefix - - ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan -> [DocName] -> HsType DocNameI -> Html @@ -518,7 +496,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names (hsSigTypeI typ) + [ ppFunSig summary links loc noHtml doc names (hsSigTypeI typ) [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -539,8 +517,9 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs - decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars - , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname@(L _ nm) + , tcdTyVars = ltyvars, tcdFDs = lfds, tcdSigs = lsigs + , tcdATs = ats, tcdATDefs = atsDefs }) splice unicode pkg qual | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual | otherwise = classheader +++ docSection curname pkg qual d @@ -557,28 +536,63 @@ ppClassDecl summary links instances fixities loc d subdocs -- 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 pkg 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 [name] (hsSigTypeI typ) - subfixs splice unicode pkg qual - | L _ (ClassOpSig _ _ lnames typ) <- lsigs - , name <- map unLoc lnames - , let doc = lookupAnySubdoc name subdocs - subfixs = [ f | f@(n',_) <- fixities - , name == n' ] - ] - -- N.B. taking just the first name is ok. Signatures with multiple names - -- are expanded so that each name gets its own signature. + -- Associated types + atBit = subAssociatedTypes + [ ppAssocType summary links doc at subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defTys) + | at <- ats + , let name = unL . fdLName $ unL at + doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defTys = (declElem . ppDefaultAssocTy name) <$> lookupDAT name + ] + + -- Default associated types + ppDefaultAssocTy n (vs,rhs) = hsep + [ keyword "type", ppAppNameTypeArgs n vs unicode qual, equals + , ppType unicode qual HideEmptyContexts (unLoc rhs) + ] + lookupDAT name = Map.lookup (getName name) defaultAssocTys + defaultAssocTys = Map.fromList + [ (getName name, (vs, typ)) + | L _ (TyFamInstDecl (HsIB _ (FamEqn { feqn_rhs = typ + , feqn_tycon = L _ name + , feqn_pats = vs }))) <- atsDefs + ] + + -- Methods + methodBit = subMethods + [ ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) + subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defSigs) + | ClassOpSig _ False lnames typ <- sigs + , name <- map unLoc lnames + , let doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defSigs = ppDefaultFunSig name <$> lookupDM name + ] + -- N.B. taking just the first name is ok. Signatures with multiple names + -- are expanded so that each name gets its own signature. + + -- Default methods + ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default") + d' [n] (hsSigTypeI t) [] splice unicode pkg qual + + lookupDM name = Map.lookup (getOccString name) defaultMethods + defaultMethods = Map.fromList + [ (nameStr, (typ, doc)) + | ClassOpSig _ True lnames typ <- sigs + , name <- map unLoc lnames + , let doc = noDocForDecl -- TODO: get docs for method defaults + nameStr = getOccString name + ] + + -- Minimal complete definition minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == @@ -587,7 +601,7 @@ ppClassDecl summary links instances fixities loc d subdocs -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns] + [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -602,6 +616,7 @@ ppClassDecl summary links instances fixities loc d subdocs where wrap | p = parens | otherwise = id ppMinimal p (Parens x) = ppMinimal p (unLoc x) + -- Instances instancesBit = ppInstances links (OriginClass nm) instances splice unicode pkg qual @@ -828,24 +843,23 @@ ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualificati ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarNameI) vars - context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False + } -> let context = unLoc (fromMaybe (noLoc []) cxt) header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' PrefixCon args -> - ( header_ +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args) + ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args) , noHtml , noHtml ) -- Record constructor, e.g. 'Identity { runIdentity :: a }' RecCon (L _ fields) -> - ( header_ +++ ppOcc <+> char '{' + ( header_ <+> ppOcc <+> char '{' , shortSubDecls dataInst [ ppShortField summary unicode qual field | L _ field <- fields ] @@ -854,7 +868,7 @@ ppShortConstrParts summary dataInst con unicode qual -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 -> - ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1 + ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts arg1 , ppOccInfix , ppLParendType unicode qual HideEmptyContexts arg2 ] @@ -902,28 +916,27 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) decl = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarNameI) vars - context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False + } -> let context = unLoc (fromMaybe (noLoc []) cxt) header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' PrefixCon args - | hasArgDocs -> header_ +++ ppOcc <+> fixity - | otherwise -> hsep [ header_ +++ ppOcc + | hasArgDocs -> header_ <+> ppOcc <+> fixity + | otherwise -> hsep [ header_ <+> ppOcc , hsep (map (ppLParendType unicode qual HideEmptyContexts) args) , fixity ] -- Record constructor, e.g. 'Identity { runIdentity :: a }' - RecCon _ -> header_ +++ ppOcc <+> fixity + RecCon _ -> header_ <+> ppOcc <+> fixity -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 - | hasArgDocs -> header_ +++ ppOcc <+> fixity - | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1 + | hasArgDocs -> header_ <+> ppOcc <+> fixity + | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts arg1 , ppOccInfix , ppLParendType unicode qual HideEmptyContexts arg2 , fixity @@ -976,17 +989,17 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -- ^ print explicit foralls - -> [Name] -- ^ type variables - -> HsContext DocNameI -- ^ context - -> Unicode -> Qualification -> Html +ppConstrHdr + :: Bool -- ^ print explicit foralls + -> [LHsTyVarBndr DocNameI] -- ^ type variables + -> HsContext DocNameI -- ^ context + -> Unicode -> Qualification + -> Html ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt where ppForall | null tvs || not forall_ = noHtml - | otherwise = forallSymbol unicode - <+> hsep (map (ppName Prefix) tvs) - <+> toHtml ". " + | otherwise = ppForAllPart unicode qual tvs ForallInvis ppCtxt | null ctxt = noHtml @@ -1159,10 +1172,14 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html ppPatSigType unicode qual typ = let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ -ppForAllPart :: Unicode -> Qualification -> ForallVisFlag -> [LHsTyVarBndr DocNameI] -> Html -ppForAllPart unicode qual fvf tvs = - hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ - ppForAllSeparator unicode fvf + +ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> Html +ppForAllPart unicode qual tvs fvf = hsep (forallSymbol unicode : tvs') +++ fv + where + tvs' = ppTyVars unicode qual tvs + fv = case fvf of + ForallVis -> spaceHtml +++ arrow unicode + ForallInvis -> dot ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ty = ppr_mono_ty (unLoc ty) @@ -1170,7 +1187,7 @@ ppr_mono_lty ty = ppr_mono_ty (unLoc ty) ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode qual emptyCtxts - = ppForAllPart unicode qual fvf tvs <+> ppr_mono_lty ty unicode qual emptyCtxts + = ppForAllPart unicode qual tvs fvf <+> ppr_mono_lty ty unicode qual emptyCtxts ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts = ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts @@ -1195,7 +1212,7 @@ ppr_mono_ty (HsTupleTy _ con tys) u q _ = ppr_mono_ty (HsSumTy _ tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys) ppr_mono_ty (HsKindSig _ ty kind) u q e = - parens (ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind) + ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 09aabc0c..edab4b16 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -171,18 +171,18 @@ flatten x = [x] -- 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 -> Maybe Package -> Hack (ModuleName, OccName) id -> Html +hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (Wrap (ModuleName, OccName)) id -> Html hackMarkup fmt' currPkg h' = let (html, ms) = hackMarkup' fmt' h' in html +++ renderMeta fmt' currPkg (metaConcat ms) where - hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id + hackMarkup' :: DocMarkup id Html -> Hack (Wrap (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_ "caption" + col' = collapseControl id_ "subheading" summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Expand" instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents) lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] @@ -206,7 +206,7 @@ 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 +markupHacked :: DocMarkup (Wrap id) Html -> Maybe Package -- this package -> Maybe String -> MDoc id @@ -220,7 +220,7 @@ docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docToHtml n pkg qual = markupHacked fmt pkg n . cleanup - where fmt = parHtmlMarkup qual True (ppDocName qual Raw) + where fmt = parHtmlMarkup qual True (ppWrappedDocName qual Raw) -- | Same as 'docToHtml' but it doesn't insert the 'anchor' element -- in links. This is used to generate the Contents box elements. @@ -228,16 +228,16 @@ docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack' -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup - where fmt = parHtmlMarkup qual False (ppDocName qual Raw) + where fmt = parHtmlMarkup qual False (ppWrappedDocName qual Raw) origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup - where fmt = parHtmlMarkup qual True (const $ ppName Raw) + where fmt = parHtmlMarkup qual True (const (ppWrappedName Raw)) rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup - where fmt = parHtmlMarkup qual True (const ppRdrName) + where fmt = parHtmlMarkup qual True (const (ppRdrName . unwrap)) docElement :: (Html -> Html) -> Html -> Html @@ -273,7 +273,7 @@ cleanup = overDoc (markup fmtUnParagraphLists) unParagraph (DocParagraph d) = d unParagraph doc = doc - fmtUnParagraphLists :: DocMarkup a (Doc a) + fmtUnParagraphLists :: DocMarkup (Wrap 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 index 25d8b07a..4535b897 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -35,6 +35,7 @@ module Haddock.Backends.Xhtml.Layout ( subInstances, subOrphanInstances, subInstHead, subInstDetails, subFamInstDetails, subMethods, + subDefaults, subMinimal, topDeclElem, declElem, @@ -259,6 +260,9 @@ instAnchorId iid = makeAnchorId $ "i:" ++ iid subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock +subDefaults :: [Html] -> Html +subDefaults = divSubDecls "default" "" . subBlock + subMinimal :: Html -> Html subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index 574045e0..6a047747 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -13,7 +13,8 @@ module Haddock.Backends.Xhtml.Names ( ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, ppBinder, ppBinderInfix, ppBinder', - ppModule, ppModuleRef, ppIPName, linkId, Notation(..) + ppModule, ppModuleRef, ppIPName, linkId, Notation(..), + ppWrappedDocName, ppWrappedName, ) where @@ -24,7 +25,7 @@ import Haddock.Utils import Text.XHtml hiding ( name, p, quote ) import qualified Data.Map as M -import qualified Data.List as List +import Data.List ( stripPrefix ) import GHC hiding (LexicalFixity(..)) import Name @@ -49,9 +50,11 @@ ppIPName :: HsIPName -> Html ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS -ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html -ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName - +ppUncheckedLink :: Qualification -> Wrap (ModuleName, OccName) -> Html +ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml + where + (mdl, occ) = unwrap x + occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName -- The Bool indicates if it is to be rendered in infix notation ppLDocName :: Qualification -> Notation -> Located DocName -> Html @@ -68,6 +71,19 @@ ppDocName qual notation insertAnchors docName = ppQualifyName qual notation name (nameModule name) | otherwise -> ppName notation name + +ppWrappedDocName :: Qualification -> Notation -> Bool -> Wrap DocName -> Html +ppWrappedDocName qual notation insertAnchors docName = case docName of + Unadorned n -> ppDocName qual notation insertAnchors n + Parenthesized n -> ppDocName qual Prefix insertAnchors n + Backticked n -> ppDocName qual Infix insertAnchors n + +ppWrappedName :: Notation -> Wrap Name -> Html +ppWrappedName notation docName = case docName of + Unadorned n -> ppName notation n + Parenthesized n -> ppName Prefix n + Backticked n -> ppName Infix n + -- | Render a name depending on the selected qualification mode ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html ppQualifyName qual notation name mdl = @@ -79,7 +95,7 @@ ppQualifyName qual notation name mdl = then ppName notation name else ppFullQualName notation mdl name RelativeQual localmdl -> - case List.stripPrefix (moduleString localmdl) (moduleString mdl) of + case stripPrefix (moduleString localmdl) (moduleString mdl) of -- local, A.x -> x Just [] -> ppName notation name -- sub-module, A.B.x -> B.x diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs index 10d6ab10..b1d64acd 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -58,7 +58,7 @@ standardTheme :: FilePath -> IO PossibleThemes standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir) --- | Default themes that are part of Haddock; added with --default-themes +-- | Default themes that are part of Haddock; added with @--built-in-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. |