diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 17 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker.hs | 44 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 6 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 289 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 15 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 166 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 20 | ||||
| -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 |
11 files changed, 335 insertions, 258 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index c5a0f772..c114e84d 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Hoogle @@ -37,8 +38,6 @@ import Data.Version import System.Directory import System.FilePath -import GHC.Core.Multiplicity - prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock" ,"-- See Hoogle, http://www.haskell.org/hoogle/" @@ -85,7 +84,7 @@ dropHsDocTy = f f (HsOpTy x a b c) = HsOpTy x (g a) b (g c) f (HsParTy x a) = HsParTy x (g a) f (HsKindSig x a b) = HsKindSig x (g a) b - f (HsDocTy _ a _) = f $ unL a + f (HsDocTy _ a _) = f $ unLoc a f x = x outHsType :: (OutputableBndrId p) @@ -217,7 +216,7 @@ ppSynonym dflags x = [out dflags x] ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} : - concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn) + concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn) where -- GHC gives out "data Bar =", we want to delete the equals. @@ -253,7 +252,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with. - name = commaSeparate dflags . map unL $ getConNames con + name = commaSeparate dflags . map unLoc $ getConNames con tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty @@ -268,8 +267,8 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { }) where f = [typeSig name (getGADTConTypeG con)] - typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) - name = out dflags $ map unL $ getConNames con + typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty) + name = out dflags $ map unLoc $ getConNames con ppFixity :: DynFlags -> (Name, Fixity) -> [String] ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)] @@ -298,7 +297,7 @@ docWith dflags header d mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String] mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s where - getDoc = maybe [] (return . fst) (lookup (unL n) subdocs) + getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs) data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String deriving Show @@ -325,7 +324,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 d315ced0..6ef07434 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,8 +18,9 @@ import Data.Maybe import System.Directory import System.FilePath -import GHC.Iface.Ext.Types ( HieFile(..), HieASTs(..) ) +import GHC.Iface.Ext.Types ( HieFile(..), HieASTs(..), HieAST(..), NodeInfo(..), SourcedNodeInfo(..) ) import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..)) +import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc ) import Data.Map as M import GHC.Data.FastString ( mkFastString ) import GHC.Unit.Module ( Module, moduleName ) @@ -32,27 +33,28 @@ import GHC.Types.Unique.Supply ( 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' @@ -66,25 +68,33 @@ ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of <$> (readHieFile ncu 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) + emptyHieAst fileFs = Node + { nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0) + , nodeChildren = [] + , sourcedNodeInfo = SourcedNodeInfo mempty + } + -- | 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 5fd040a8..3db3c685 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,10 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Haddock.Backends.Hyperlinker.Parser (parse) where +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class import Control.Applicative ( Alternative(..) ) -import Control.Monad.Trans.Maybe ( MaybeT(..) ) -import Control.Monad.Trans.Class ( MonadTrans(lift) ) import Data.List ( isPrefixOf, isSuffixOf ) import qualified Data.ByteString as BS @@ -274,6 +275,7 @@ classify tok = ITdot -> TkOperator ITstar {} -> TkOperator ITtypeApp -> TkGlyph + ITpercent -> TkGlyph ITbiglam -> TkGlyph diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index ce5ff11c..b093b5a4 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 badb1914..df81fd6e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -39,9 +39,9 @@ import System.FilePath import Data.Char import Control.Monad import Data.Maybe -import Data.List +import Data.List ( sort ) +import Data.Void ( absurd ) import Prelude hiding ((<>)) -import GHC.Core.Multiplicity import Haddock.Doc (combineDocumentation) @@ -105,6 +105,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 @@ -158,7 +162,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" @@ -173,7 +177,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 @@ -289,7 +293,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 @@ -297,7 +301,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 @@ -309,7 +313,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" @@ -319,13 +323,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 @@ -337,6 +342,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,21 +362,25 @@ ppFamDecl doc instances decl unicode = -- | Print the LHS of a type\/data family declaration. ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print - -> Bool -- ^ unicode - -> LaTeX + -> Bool -- ^ unicode + -> Bool -- ^ is the family associated? + -> LaTeX 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 @@ -412,17 +422,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 @@ -431,15 +447,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. @@ -459,7 +467,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 @@ -481,8 +489,9 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ <+> 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 _ _w (L _ (HsRecTy _ fields)) r) = [ (decltt ldr, latex <+> nl) @@ -501,9 +510,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 '{' ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX @@ -533,10 +542,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}" @@ -547,9 +555,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}" @@ -593,6 +601,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 @@ -613,18 +622,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 = unLoc . 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 @@ -643,6 +662,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 @@ -725,15 +745,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 Specificity 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 = ppHsForAllTelescope (mkHsForAllInvisTeleI tvs) unicode + + ppCtxt + | null ctxt = empty + | otherwise = ppContextNoArrow ctxt unicode <+> darrow unicode <> space -- | Pretty-print a constructor @@ -762,11 +788,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' @@ -774,7 +799,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = | hasArgDocs -> header_ <+> ppOcc | otherwise -> hsep [ header_ , ppOcc - , hsep (map ((ppLParendType unicode) . hsScaledThing) args) + , hsep (map (ppLParendType unicode . hsScaledThing) args) ] -- Record constructor, e.g. 'Identity { runIdentity :: a }' @@ -1001,7 +1026,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 @@ -1033,7 +1058,6 @@ ppLKind unicode y = ppKind unicode (unLoc y) ppKind :: Bool -> HsKind DocNameI -> LaTeX 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 @@ -1060,7 +1084,7 @@ 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 (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" +ppr_mono_ty (HsSpliceTy v _) _ = absurd v ppr_mono_ty (HsRecTy {}) _ = text "{..}" ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys @@ -1086,7 +1110,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) @@ -1120,9 +1144,6 @@ ppSymName name | otherwise = ppName name -ppVerbOccName :: OccName -> LaTeX -ppVerbOccName = text . latexFilter . occNameString - ppIPName :: HsIPName -> LaTeX ppIPName = text . ('?':) . unpackFS . hsIPNameFS @@ -1130,18 +1151,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 @@ -1179,9 +1191,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 ------------------------------------------------------------------------------- @@ -1189,34 +1202,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 @@ -1229,6 +1248,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) @@ -1245,35 +1267,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 @@ -1298,23 +1313,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 @@ -1322,8 +1337,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 @@ -1331,6 +1346,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.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 24b565fc..f8c22e0a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -295,6 +295,10 @@ ppHtmlContents state odir doctitle _maybe_package ] createDirectoryIfMissing True odir writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + where + -- Extract a module's short description. + toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name) + toInstalledDescription = fmap mkMeta . hmi_description . instInfo ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html @@ -304,6 +308,7 @@ ppPrologue pkg qual title (Just doc) = ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html +ppSignatureTree _ _ [] = mempty ppSignatureTree pkg qual ts = divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts) @@ -669,16 +674,22 @@ numberSectionHeadings = go 1 where go :: Int -> [ExportItem DocNameI] -> [ExportItem DocNameI] go _ [] = [] go n (ExportGroup lev _ doc : es) - = ExportGroup lev (show n) doc : go (n+1) es + = case collectAnchors doc of + [] -> ExportGroup lev (show n) doc : go (n+1) es + (a:_) -> ExportGroup lev a doc : go (n+1) es go n (other:es) = other : go n es + collectAnchors :: DocH (Wrap (ModuleName, OccName)) (Wrap DocName) -> [String] + collectAnchors (DocAppend a b) = collectAnchors a ++ collectAnchors b + collectAnchors (DocAName a) = [a] + collectAnchors _ = [] processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification -> ExportItem DocNameI -> Maybe Html processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances processExport summary _ _ pkg qual (ExportGroup lev id0 doc) - = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) pkg qual (mkMeta doc) + = nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice) = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual processExport summary _ _ _ qual (ExportNoDecl y []) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 6e210b61..eeb9fa94 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -32,6 +32,7 @@ import Haddock.Doc (combineDocumentation) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe +import Data.Void ( absurd ) import Text.XHtml hiding ( name, title, p, quote ) import GHC.Core.Type ( Specificity(..) ) @@ -41,7 +42,6 @@ import GHC.Exts import GHC.Types.Name import GHC.Data.BooleanFormula import GHC.Types.Name.Reader ( rdrNameOcc ) -import GHC.Core.Multiplicity -- | Pretty print a declaration ppDecl :: Bool -- ^ print summary info only @@ -76,14 +76,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 @@ -134,8 +134,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. @@ -155,7 +155,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ do_args n leader (HsForAllTy _ tele ltype) = do_largs n leader' ltype where - leader' = leader <+> ppForAll tele unicode qual + leader' = leader <+> ppForAllPart unicode qual tele do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt) @@ -189,24 +189,6 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ gadtOpen = toHtml "{" - -ppForAll :: HsForAllTelescope DocNameI -> Unicode -> Qualification - -> Html -ppForAll tele unicode qual = case tele of - HsForAllVis { hsf_vis_bndrs = bndrs } -> - pp_bndrs bndrs (spaceHtml +++ arrow unicode) - HsForAllInvis { hsf_invis_bndrs = bndrs } -> - pp_bndrs bndrs dot - where - pp_bndrs :: [LHsTyVarBndr flag DocNameI] -> Html -> Html - pp_bndrs tvs forall_separator = - case [pp_ktv n k | L _ (KindedTyVar _ _ (L _ n) k) <- tvs] of - [] -> noHtml - ts -> forallSymbol unicode <+> hsep ts +++ forall_separator - - pp_ktv 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 @@ -240,7 +222,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" @@ -272,10 +254,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 @@ -519,7 +497,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 @@ -541,7 +519,7 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity) -> 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 }) + , 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 @@ -562,24 +540,61 @@ ppClassDecl summary links instances fixities loc d subdocs 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 = unLoc . fdLName $ unLoc 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] == @@ -603,6 +618,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 @@ -827,18 +843,16 @@ 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) . hsScaledThing) args) + ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) , noHtml , noHtml ) @@ -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 (hsScaledThing arg1) + ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1) , ppOccInfix , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2) ] @@ -901,28 +915,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 - , hsep (map ((ppLParendType unicode qual HideEmptyContexts) . hsScaledThing) args) + | hasArgDocs -> header_ <+> ppOcc <+> fixity + | otherwise -> hsep [ header_ <+> ppOcc + , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) 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 (hsScaledThing arg1) + | hasArgDocs -> header_ <+> ppOcc <+> fixity + | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1) , ppOccInfix , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2) , fixity @@ -973,17 +986,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 Specificity 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 (HsForAllInvis noExtField tvs) ppCtxt | null ctxt = noHtml @@ -1169,6 +1182,7 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html ppPatSigType unicode qual typ = let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ + ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html ppForAllPart unicode qual tele = case tele of HsForAllVis { hsf_vis_bndrs = bndrs } -> @@ -1208,11 +1222,11 @@ 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 -ppr_mono_ty (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty (HsSpliceTy v _) _ _ _ = absurd v ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index ee90ad68..378d0559 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -19,7 +19,7 @@ module Haddock.Backends.Xhtml.DocMarkup ( docElement, docSection, docSection_, ) where -import Data.List +import Data.List (intersperse) import Documentation.Haddock.Markup import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils @@ -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 dd8b0b18..d61d6d9b 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 83279f70..8553cdfb 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 GHC.Types.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. |