haddock 2.8.1 → 2.9.0
raw patch · 28 files changed
+839/−695 lines, 28 filesdep ~ghc
Dependency ranges changed: ghc
Files
- CHANGES +22/−0
- dist/build/haddock/haddock-tmp/Haddock/Lex.hs +6/−5
- dist/build/haddock/haddock-tmp/Haddock/Parse.hs +1/−0
- doc/haddock.xml +49/−8
- haddock.cabal +5/−7
- haddock.spec +1/−1
- src/Documentation/Haddock.hs +1/−3
- src/Haddock/Backends/Hoogle.hs +2/−3
- src/Haddock/Backends/LaTeX.hs +8/−19
- src/Haddock/Backends/Xhtml.hs +101/−83
- src/Haddock/Backends/Xhtml/Decl.hs +222/−209
- src/Haddock/Backends/Xhtml/DocMarkup.hs +9/−9
- src/Haddock/Backends/Xhtml/Layout.hs +19/−18
- src/Haddock/Backends/Xhtml/Names.hs +38/−7
- src/Haddock/Backends/Xhtml/Themes.hs +6/−4
- src/Haddock/Backends/Xhtml/Utils.hs +10/−4
- src/Haddock/Convert.hs +6/−23
- src/Haddock/GhcUtils.hs +3/−15
- src/Haddock/Interface.hs +21/−15
- src/Haddock/Interface/AttachInstances.hs +9/−2
- src/Haddock/Interface/Create.hs +54/−47
- src/Haddock/InterfaceFile.hs +5/−6
- src/Haddock/Lex.x +5/−4
- src/Haddock/Options.hs +18/−4
- src/Haddock/Parse.y +1/−0
- src/Haddock/Types.hs +162/−146
- src/Haddock/Utils.hs +7/−8
- src/Main.hs +48/−45
CHANGES view
@@ -1,3 +1,25 @@+Changes in version 2.9.0++ * Drop support for ghc < 7++ * New flag --qual for qualification of names++ * Print doc coverage information to stdout when generating docs++ * Include an 'All' option in the A-Z subdivided index++ * Make TOC group header identifiers validate++ * Minor changes to the API++Changes in the version that comes with GHC 7.0.1+ + [This version claims it is 2.8.0 but is actually based on 2.8.1]++ * Fix URL creation on Windows: Use / not \ in URLs.++ * Support GHC 7.0+ Changes in version 2.8.1 * Fix build on Windows with MinGW
dist/build/haddock/haddock-tmp/Haddock/Lex.hs view
@@ -1,6 +1,7 @@ {-# OPTIONS -fglasgow-exts -cpp #-} {-# LINE 10 "src/Haddock/Lex.x" #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS -Wwarn -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix@@ -165,7 +166,7 @@ alex_deflt = AlexA# "\xff\xff\x1b\x00\x41\x00\xff\xff\x22\x00\x24\x00\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\x29\x00\x29\x00\x2c\x00\xff\xff\x2c\x00\xff\xff\x2f\x00\x2f\x00\xff\xff\x32\x00\x32\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff"# alex_accept = listArray (0::Int,67) [[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_12))],[],[(AlexAcc (alex_action_15))],[],[],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_7))],[],[(AlexAccSkip)],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[],[],[(AlexAcc (alex_action_6))],[],[(AlexAcc (alex_action_8))],[],[(AlexAcc (alex_action_9))],[],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_13))],[],[(AlexAcc (alex_action_14))],[],[],[(AlexAcc (alex_action_16))],[],[(AlexAcc (alex_action_17))],[],[(AlexAcc (alex_action_18))],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_20))],[],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_20))],[],[(AlexAcc (alex_action_21))],[(AlexAcc (alex_action_27))],[],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_27))],[],[(AlexAcc (alex_action_23))],[(AlexAcc (alex_action_23))],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_25))],[],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_26))],[],[],[(AlexAcc (alex_action_28))],[(AlexAcc (alex_action_29))],[(AlexAcc (alex_action_30))],[(AlexAcc (alex_action_31))]]-{-# LINE 112 "src/Haddock/Lex.x" #-}+{-# LINE 113 "src/Haddock/Lex.x" #-} -- | A located token type LToken = (Token, AlexPosn)@@ -241,12 +242,12 @@ strToHsQNames :: DynFlags -> String -> Maybe [RdrName] strToHsQNames dflags str0 = - let buffer = unsafePerformIO (stringToStringBuffer str0)-#if MIN_VERSION_ghc(6,13,0)- pstate = mkPState dflags buffer noSrcLoc+#if MIN_VERSION_ghc(7,1,0)+ let buffer = stringToStringBuffer str0 #else- pstate = mkPState buffer noSrcLoc dflags+ let buffer = unsafePerformIO (stringToStringBuffer str0) #endif+ pstate = mkPState dflags buffer noSrcLoc result = unP parseIdentifier pstate in case result of POk _ name -> Just [unLoc name]
dist/build/haddock/haddock-tmp/Haddock/Parse.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} {-# OPTIONS -fglasgow-exts -cpp #-}+{-# LANGUAGE BangPatterns #-} {-# OPTIONS -Wwarn -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix
doc/haddock.xml view
@@ -21,7 +21,7 @@ <holder>Simon Marlow, David Waern</holder> </copyright> <abstract>- <para>This document describes Haddock version 2.8.1, a Haskell+ <para>This document describes Haddock version 2.9.0, a Haskell documentation tool.</para> </abstract> </bookinfo>@@ -788,16 +788,57 @@ <varlistentry> <term>- <indexterm><primary><option>-d</option></primary></indexterm>- <option>-d</option>+ <indexterm><primary><option>-q</option></primary></indexterm>+ <option>-q</option> <replaceable>mode</replaceable> </term> <term>- <indexterm><primary><option>--debug</option></primary></indexterm>- <option>--debug</option>+ <indexterm><primary><option>--qual</option></primary></indexterm>+ <option>--qual</option>=<replaceable>mode</replaceable> </term>- <listitem>- <para>Produce extra debugging output.</para>- </listitem>+ <listitem>+ <para>+ Specify how identifiers are qualified.+ </para>+ <para>+ <replaceable>mode</replaceable> should be one of+ <itemizedlist>+ <listitem>+ <para>none (default): don't qualify any identifiers</para>+ </listitem>+ <listitem>+ <para>full: always qualify identifiers completely</para>+ </listitem>+ <listitem>+ <para>local: only qualify identifiers that are not part+ of the module</para>+ </listitem>+ <listitem>+ <para>relative: like local, but strip name of the module+ from qualifications of identifiers in submodules</para>+ </listitem>+ </itemizedlist>+ </para>+ <para>+ Example: If you generate documentation for module A, then the+ identifiers A.x, A.B.y and C.z are qualified as follows.+ </para>+ <para>+ <itemizedlist>+ <listitem>+ none: x, y, z+ </listitem>+ <listitem>+ full: A.x, A.B.y, C.z+ </listitem>+ <listitem>+ local: x, A.B.y, C.z+ </listitem>+ <listitem>+ relative: x, B.y, C.z+ </listitem>+ </itemizedlist>+ </para>+ </listitem> </varlistentry> <varlistentry>
haddock.cabal view
@@ -1,5 +1,5 @@ name: haddock-version: 2.8.1+version: 2.9.0 cabal-version: >= 1.6 license: BSD3 build-type: Simple@@ -82,11 +82,10 @@ array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.5,- ghc >= 6.12 && < 6.16+ ghc >= 7.0 && < 7.2 if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE- extensions: ForeignFunctionInterface else build-depends: ghc-paths @@ -96,7 +95,7 @@ main-is: Main.hs hs-source-dirs: src- extensions: CPP, PatternGuards, DeriveDataTypeable,+ extensions: CPP, DeriveDataTypeable, ScopedTypeVariables, MagicHash ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs @@ -142,11 +141,10 @@ array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.5,- ghc >= 6.12 && < 6.14+ ghc >= 7.0 && < 7.2 if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE- extensions: ForeignFunctionInterface else build-depends: ghc-paths @@ -155,7 +153,7 @@ build-depends: QuickCheck >= 2.1 && < 3 hs-source-dirs: src- extensions: CPP, PatternGuards, DeriveDataTypeable,+ extensions: CPP, DeriveDataTypeable, ScopedTypeVariables, MagicHash ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs
haddock.spec view
@@ -17,7 +17,7 @@ # version label of your release tarball. %define name haddock-%define version 2.8.1+%define version 2.9.0 %define release 1 Name: %{name}
src/Documentation/Haddock.hs view
@@ -26,10 +26,9 @@ DocForDecl, FnArgsDoc, - -- * Hyperlinking+ -- * Cross-referencing LinkEnv, DocName(..),- docNameOcc, -- * Instances DocInstance,@@ -43,7 +42,6 @@ markup, -- * Interface files- -- | (.haddock files) InterfaceFile(..), readInterfaceFile, nameCacheFromGhc,
src/Haddock/Backends/Hoogle.hs view
@@ -240,13 +240,12 @@ markupCodeBlock = box TagPre, markupURL = box (TagInline "a") . str, markupAName = const $ str "",- markupExample = box TagPre . str . unlines . (map exampleToString)+ markupExample = box TagPre . str . unlines . map exampleToString } showTags :: [Tag] -> [String]-showTags = concat . intersperse [""] . map showBlock- where+showTags = intercalate [""] . map showBlock showBlock :: Tag -> [String]
src/Haddock/Backends/LaTeX.hs view
@@ -577,11 +577,7 @@ -- ppConstrHdr is for (non-GADT) existentials constructors' syntax-#if __GLASGOW_HASKELL__ == 612-ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> LaTeX-#else ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX-#endif ppConstrHdr forall tvs ctxt unicode = (if null tvs then empty else ppForall) <+>@@ -635,7 +631,7 @@ header_ = ppConstrHdr forall tyVars context- occ = docNameOcc . unLoc . con_name $ con+ occ = nameOccName . getName . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con)@@ -649,7 +645,7 @@ ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =- decltt (ppBinder (docNameOcc name)+ decltt (ppBinder (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above@@ -740,7 +736,7 @@ -- | Print an application of a DocName and a list of Names ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX ppAppDocNameNames _summ n ns =- ppTypeApp n ns (ppBinder . docNameOcc) ppSymName+ ppTypeApp n ns (ppBinder . nameOccName . getName) ppSymName -- | General printing of type applications@@ -850,11 +846,7 @@ -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -#if __GLASGOW_HASKELL__ == 612-ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)]-#else ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)]-#endif -> Located (HsContext DocName) -> Bool -> LaTeX ppForAll expl tvs cxt unicode | show_forall = forall_part <+> ppLContext cxt unicode@@ -884,12 +876,9 @@ ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p) ppr_mono_ty _ (HsNumTy n) _ = text (show n) -- generics only ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"-#if __GLASGOW_HASKELL__ == 612-ppr_mono_ty _ (HsSpliceTyOut {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"-#else ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"-#endif ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"+ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode = maybeParen ctxt_prec pREC_CON $@@ -900,7 +889,7 @@ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode where ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op- occName = docNameOcc . unLoc $ op+ occName = nameOccName . getName . unLoc $ op ppr_mono_ty ctxt_prec (HsParTy ty) unicode -- = parens (ppr_mono_lty pREC_TOP ty)@@ -945,7 +934,7 @@ ppVerbDocName :: DocName -> LaTeX-ppVerbDocName = ppVerbOccName . docNameOcc+ppVerbDocName = ppVerbOccName . nameOccName . getName ppVerbRdrName :: RdrName -> LaTeX@@ -953,7 +942,7 @@ ppDocName :: DocName -> LaTeX-ppDocName = ppOccName . docNameOcc+ppDocName = ppOccName . nameOccName . getName ppLDocName :: Located DocName -> LaTeX@@ -961,7 +950,7 @@ ppDocBinder :: DocName -> LaTeX-ppDocBinder = ppBinder . docNameOcc+ppDocBinder = ppBinder . nameOccName . getName ppName :: Name -> LaTeX
src/Haddock/Backends/Xhtml.hs view
@@ -35,13 +35,12 @@ import Control.Monad ( when, unless ) import Control.Monad.Instances ( ) -- for Functor Either a import Data.Char ( toUpper )-import Data.List ( sortBy, groupBy )+import Data.List ( sortBy, groupBy, intercalate ) import Data.Maybe import System.FilePath hiding ( (</>) ) import System.Directory import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map )-import Data.List ( intercalate ) import Data.Function import Data.Ord ( comparing ) @@ -56,49 +55,52 @@ ppHtml :: String- -> Maybe String -- package+ -> Maybe String -- ^ Package -> [Interface]- -> FilePath -- destination directory- -> Maybe (Doc GHC.RdrName) -- prologue text, maybe- -> Themes -- themes- -> SourceURLs -- the source URL (--source)- -> WikiURLs -- the wiki URL (--wiki)- -> Maybe String -- the contents URL (--use-contents)- -> Maybe String -- the index URL (--use-index)- -> Bool -- whether to use unicode in output (--use-unicode)+ -> FilePath -- ^ Destination directory+ -> Maybe (Doc GHC.RdrName) -- ^ Prologue text, maybe+ -> Themes -- ^ Themes+ -> SourceURLs -- ^ The source URL (--source)+ -> WikiURLs -- ^ The wiki URL (--wiki)+ -> Maybe String -- ^ The contents URL (--use-contents)+ -> Maybe String -- ^ The index URL (--use-index)+ -> Bool -- ^ Whether to use unicode in output (--use-unicode)+ -> Qualification -- ^ How to qualify names+ -> Bool -- ^ Output pretty html (newlines and indenting) -> IO () ppHtml doctitle maybe_package ifaces odir prologue themes maybe_source_url maybe_wiki_url- maybe_contents_url maybe_index_url unicode = do+ maybe_contents_url maybe_index_url unicode+ qual debug = do let- visible_ifaces = filter visible ifaces- visible i = OptHide `notElem` ifaceOptions i- when (not (isJust maybe_contents_url)) $+ visible_ifaces = filter visible ifaces+ visible i = OptHide `notElem` ifaceOptions i++ when (isNothing maybe_contents_url) $ ppHtmlContents odir doctitle maybe_package themes maybe_index_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces) False -- we don't want to display the packages in a single-package contents prologue+ debug - when (not (isJust maybe_index_url)) $+ when (isNothing maybe_index_url) $ ppHtmlIndex odir doctitle maybe_package themes maybe_contents_url maybe_source_url maybe_wiki_url- (map toInstalledIface visible_ifaces)+ (map toInstalledIface visible_ifaces) debug mapM_ (ppHtmlModule odir doctitle themes maybe_source_url maybe_wiki_url- maybe_contents_url maybe_index_url unicode) visible_ifaces+ maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces copyHtmlBits :: FilePath -> FilePath -> Themes -> IO () copyHtmlBits odir libdir themes = do let- libhtmldir = joinPath [libdir, "html"]- copyCssFile f = do- copyFile f (combine odir (takeFileName f))- copyLibFile f = do- copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])+ libhtmldir = joinPath [libdir, "html"]+ copyCssFile f = copyFile f (combine odir (takeFileName f))+ copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) mapM_ copyCssFile (cssFiles themes) mapM_ copyLibFile [ jsFile, framesFile ] @@ -148,13 +150,13 @@ contentsButton :: Maybe String -> Maybe Html contentsButton maybe_contents_url = Just (anchor ! [href url] << "Contents")- where url = maybe contentsHtmlFile id maybe_contents_url+ where url = fromMaybe contentsHtmlFile maybe_contents_url indexButton :: Maybe String -> Maybe Html indexButton maybe_index_url = Just (anchor ! [href url] << "Index")- where url = maybe indexHtmlFile id maybe_index_url+ where url = fromMaybe indexHtmlFile maybe_index_url bodyHtml :: String -> Maybe Interface@@ -189,7 +191,7 @@ let info = ifaceInfo iface - doOneEntry :: (String, (HaddockModInfo GHC.Name) -> Maybe String) -> Maybe HtmlTable+ doOneEntry :: (String, HaddockModInfo GHC.Name -> Maybe String) -> Maybe HtmlTable doOneEntry (fieldName, field) = field info >>= \a -> return (th << fieldName <-> td << a) @@ -219,10 +221,11 @@ -> SourceURLs -> WikiURLs -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName)+ -> Bool -> IO () ppHtmlContents odir doctitle _maybe_package themes maybe_index_url- maybe_source_url maybe_wiki_url ifaces showPkgs prologue = do+ maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug = do let tree = mkModuleTree showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces] html =@@ -234,10 +237,10 @@ ppModuleTree tree ] createDirectoryIfMissing True odir- writeFile (joinPath [odir, contentsHtmlFile]) (renderToString html)+ writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html) -- XXX: think of a better place for this?- ppHtmlContentsFrame odir doctitle themes ifaces+ ppHtmlContentsFrame odir doctitle themes ifaces debug ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> Html@@ -306,13 +309,13 @@ where mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ] ppModule' txt mdl =- anchor ! [href ((moduleHtmlFile mdl)), target mainFrameName]+ anchor ! [href (moduleHtmlFile mdl), target mainFrameName] << toHtml txt ppHtmlContentsFrame :: FilePath -> String -> Themes- -> [InstalledInterface] -> IO ()-ppHtmlContentsFrame odir doctitle themes ifaces = do+ -> [InstalledInterface] -> Bool -> IO ()+ppHtmlContentsFrame odir doctitle themes ifaces debug = do let mods = flatModuleTree ifaces html = headHtml doctitle Nothing themes +++@@ -320,7 +323,7 @@ (sectionName << "Modules" +++ ulist << [ li ! [theclass "module"] << m | m <- mods ]) createDirectoryIfMissing True odir- writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString html)+ writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString debug html) --------------------------------------------------------------------------------@@ -336,18 +339,22 @@ -> SourceURLs -> WikiURLs -> [InstalledInterface]+ -> Bool -> IO () ppHtmlIndex odir doctitle _maybe_package themes- maybe_contents_url maybe_source_url maybe_wiki_url ifaces = do+ maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do let html = indexPage split_indices Nothing (if split_indices then [] else index) createDirectoryIfMissing True odir - when split_indices $+ when split_indices $ do mapM_ (do_sub_index index) initialChars+ -- Let's add a single large index as well for those who don't know exactly what they're looking for:+ let mergedhtml = indexPage False Nothing index+ writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) - writeFile (joinPath [odir, indexHtmlFile]) (renderToString html)+ writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html) where indexPage showLetters ch items =@@ -361,6 +368,7 @@ ] indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch+ merged_name = "All" buildIndex items = table << aboves (map indexElt items) @@ -373,9 +381,10 @@ indexInitialLetterLinks = divAlphabet <<- unordList [ anchor ! [href (subIndexHtmlFile c)] << [c]- | c <- initialChars- , any ((==c) . toUpper . head . fst) index ]+ unordList (map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $+ [ [c] | c <- initialChars+ , any ((==c) . toUpper . head . fst) index ] +++ [merged_name]) -- todo: what about names/operators that start with Unicode -- characters?@@ -386,7 +395,7 @@ do_sub_index this_ix c = unless (null index_part) $- writeFile (joinPath [odir, subIndexHtmlFile c]) (renderToString html)+ writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) where html = indexPage True (Just c) index_part index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]@@ -394,7 +403,7 @@ index :: [(String, Map GHC.Name [(Module,Bool)])] index = sortBy cmp (Map.toAscList full_index)- where cmp (n1,_) (n2,_) = map toUpper n1 `compare` map toUpper n2+ where cmp (n1,_) (n2,_) = comparing (map toUpper) n1 n2 -- for each name (a plain string), we have a number of original HsNames that -- it can refer to, and for each of those we have a list of modules@@ -402,7 +411,7 @@ -- in a visible or invisible way (hence the Bool). full_index :: Map String (Map GHC.Name [(Module,Bool)]) full_index = Map.fromListWith (flip (Map.unionWith (++)))- (concat (map getIfaceIndex ifaces))+ (concatMap getIfaceIndex ifaces) getIfaceIndex iface = [ (getOccString name@@ -448,44 +457,48 @@ ppHtmlModule :: FilePath -> String -> Themes -> SourceURLs -> WikiURLs- -> Maybe String -> Maybe String -> Bool- -> Interface -> IO ()+ -> Maybe String -> Maybe String -> Bool -> Qualification+ -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes maybe_source_url maybe_wiki_url- maybe_contents_url maybe_index_url unicode iface = do+ maybe_contents_url maybe_index_url unicode qual debug iface = do let mdl = ifaceMod iface mdl_str = moduleString mdl+ real_qual = case qual of+ LocalQual Nothing -> LocalQual (Just mdl)+ RelativeQual Nothing -> RelativeQual (Just mdl)+ _ -> qual html = headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),- ifaceToHtml maybe_source_url maybe_wiki_url iface unicode+ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual ] createDirectoryIfMissing True odir- writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString html)- ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode+ writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)+ ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode qual debug ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes- -> Interface -> Bool -> IO ()-ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode = do+ -> Interface -> Bool -> Qualification -> Bool -> IO ()+ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do let mdl = ifaceMod iface html = headHtml (moduleString mdl) Nothing themes +++ miniBody << (divModuleHeader << sectionName << moduleString mdl +++- miniSynopsis mdl iface unicode)+ miniSynopsis mdl iface unicode qual) createDirectoryIfMissing True odir- writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString html)+ writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html) -ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Html-ifaceToHtml maybe_source_url maybe_wiki_url iface unicode- = ppModuleContents exports ++++ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html+ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual+ = ppModuleContents qual exports +++ description +++ synopsis +++ divInterface (maybe_doc_hdr +++ bdy)@@ -505,7 +518,7 @@ = case ifaceRnDoc iface of Nothing -> noHtml Just doc -> divDescription $- sectionName << "Description" +++ docSection doc+ sectionName << "Description" +++ docSection qual doc -- omit the synopsis if there are no documentation annotations at all synopsis@@ -514,7 +527,7 @@ = divSynposis $ paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ shortDeclList (- mapMaybe (processExport True linksInfo unicode) exports+ mapMaybe (processExport True linksInfo unicode qual) exports ) ! (collapseSection "syn" False "" ++ collapseToggle "syn") -- if the documentation doesn't begin with a section header, then@@ -527,20 +540,21 @@ bdy = foldr (+++) noHtml $- mapMaybe (processExport False linksInfo unicode) exports+ mapMaybe (processExport False linksInfo unicode qual) exports linksInfo = (maybe_source_url, maybe_wiki_url) -miniSynopsis :: Module -> Interface -> Bool -> Html-miniSynopsis mdl iface unicode =- divInterface << mapMaybe (processForMiniSynopsis mdl unicode) exports+miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html+miniSynopsis mdl iface unicode qual =+ divInterface << mapMaybe (processForMiniSynopsis mdl unicode qual) exports where exports = numberSectionHeadings (ifaceRnExportItems iface) -processForMiniSynopsis :: Module -> Bool -> ExportItem DocName -> Maybe Html-processForMiniSynopsis mdl unicode (ExportDecl (L _loc decl0) _doc _ _insts) =+processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName+ -> Maybe Html+processForMiniSynopsis mdl unicode _ (ExportDecl (L _loc decl0) _doc _ _insts) = ((divTopDecl <<).(declElem <<)) `fmap` case decl0 of TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of (TyFamily{}) -> Just $ ppTyFamHeader True False d unicode@@ -553,11 +567,11 @@ (ClassDecl {}) -> Just $ keyword "class" <+> b _ -> Nothing SigD (TypeSig (L _ n) (L _ _)) ->- Just $ ppNameMini mdl (docNameOcc n)+ Just $ ppNameMini mdl (nameOccName . getName $ n) _ -> Nothing-processForMiniSynopsis _ _ (ExportGroup lvl _id txt) =- Just $ groupTag lvl << docToHtml txt-processForMiniSynopsis _ _ _ = Nothing+processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =+ Just $ groupTag lvl << docToHtml qual txt+processForMiniSynopsis _ _ _ _ = Nothing ppNameMini :: Module -> OccName -> Html@@ -571,11 +585,11 @@ ppTyClBinderWithVarsMini mdl decl = let n = unLoc $ tcdLName decl ns = tyvarNames $ tcdTyVars decl- in ppTypeApp n ns (ppNameMini mdl . docNameOcc) ppTyName+ in ppTypeApp n ns (ppNameMini mdl . nameOccName . getName) ppTyName -ppModuleContents :: [ExportItem DocName] -> Html-ppModuleContents exports+ppModuleContents :: Qualification -> [ExportItem DocName] -> Html+ppModuleContents qual exports | null sections = noHtml | otherwise = contentsDiv where@@ -591,7 +605,7 @@ | lev <= n = ( [], items ) | otherwise = ( html:secs, rest2 ) where- html = linkedAnchor id0 << docToHtml doc +++ mk_subsections ssecs+ html = linkedAnchor (groupId id0) << docToHtml qual doc +++ mk_subsections ssecs (ssecs, rest1) = process lev rest (secs, rest2) = process n rest1 process n (_ : rest) = process n rest@@ -612,18 +626,20 @@ = other : go n es -processExport :: Bool -> LinksInfo -> Bool -> (ExportItem DocName) -> Maybe Html-processExport summary _ _ (ExportGroup lev id0 doc)- = nothingIf summary $ groupTag lev ! [identifier id0] << docToHtml doc-processExport summary links unicode (ExportDecl decl doc subdocs insts)- = processDecl summary $ ppDecl summary links decl doc insts subdocs unicode-processExport summary _ _ (ExportNoDecl y [])- = processDeclOneLiner summary $ ppDocName y-processExport summary _ _ (ExportNoDecl y subs)- = processDeclOneLiner summary $ ppDocName y +++ parenList (map ppDocName subs)-processExport summary _ _ (ExportDoc doc)- = nothingIf summary $ docSection doc-processExport summary _ _ (ExportModule mdl)+processExport :: Bool -> LinksInfo -> Bool -> Qualification+ -> ExportItem DocName -> Maybe Html+processExport summary _ _ qual (ExportGroup lev id0 doc)+ = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc+processExport summary links unicode qual (ExportDecl decl doc subdocs insts)+ = processDecl summary $ ppDecl summary links decl doc insts subdocs unicode qual+processExport summary _ _ qual (ExportNoDecl y [])+ = processDeclOneLiner summary $ ppDocName qual y+processExport summary _ _ qual (ExportNoDecl y subs)+ = processDeclOneLiner summary $+ ppDocName qual y +++ parenList (map (ppDocName qual) subs)+processExport summary _ _ qual (ExportDoc doc)+ = nothingIf summary $ docSection qual doc+processExport summary _ _ _ (ExportModule mdl) = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl @@ -641,6 +657,8 @@ processDeclOneLiner True = Just processDeclOneLiner False = Just . divTopDecl . declElem +groupHeading :: Int -> String -> Html -> Html+groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)] groupTag :: Int -> Html -> Html groupTag lev
src/Haddock/Backends/Xhtml/Decl.hs view
@@ -39,38 +39,40 @@ -- TODO: use DeclInfo DocName or something ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->- DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Html-ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = case decl of- TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode+ DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->+ Bool -> Qualification -> Html+ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of+ TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode qual TyClD d@(TyData {})- | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode+ | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d TyClD d@(TySynonym {})- | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode- | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode- SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode- ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode+ | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual+ | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode qual+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual+ SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode qual+ ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->- DocName -> HsType DocName -> Bool -> Html-ppFunSig summary links loc doc docname typ unicode =+ DocName -> HsType DocName -> Bool -> Qualification -> Html+ppFunSig summary links loc doc docname typ unicode qual = ppTypeOrFunSig summary links loc docname typ doc- (ppTypeSig summary occname typ unicode, ppBinder False occname, dcolon unicode) unicode+ (ppTypeSig summary occname typ unicode qual, ppBinder False occname, dcolon unicode)+ unicode qual where- occname = docNameOcc docname+ occname = nameOccName . getName $ docname ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName ->- DocForDecl DocName -> (Html, Html, Html) -> Bool -> Html-ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode+ DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification-> Html+ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode qual | summary = pref1- | Map.null argDocs = topDeclElem links loc docname pref1 +++ maybeDocSection doc+ | Map.null argDocs = topDeclElem links loc docname pref1 +++ maybeDocSection qual doc | otherwise = topDeclElem links loc docname pref2 +++- subArguments (do_args 0 sep typ) +++ maybeDocSection doc+ subArguments qual (do_args 0 sep typ) +++ maybeDocSection qual doc where argDoc n = Map.lookup n argDocs @@ -79,12 +81,12 @@ do_args n leader (HsForAllTy Explicit tvs lctxt ltype) = (leader <+> hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>- ppLContextNoArrow lctxt unicode,+ ppLContextNoArrow lctxt unicode qual, Nothing, []) : do_largs n (darrow unicode) ltype do_args n leader (HsForAllTy Implicit _ lctxt ltype) | not (null (unLoc lctxt))- = (leader <+> ppLContextNoArrow lctxt unicode,+ = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) : do_largs n (darrow unicode) ltype -- if we're not showing any 'forall' or class constraints or@@ -92,10 +94,10 @@ | otherwise = do_largs n leader ltype do_args n leader (HsFunTy lt r)- = (leader <+> ppLFunLhType unicode lt, argDoc n, [])+ = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t- = (leader <+> ppType unicode t, argDoc n, []) : []+ = (leader <+> ppType unicode qual t, argDoc n, []) : [] ppTyVars :: [LHsTyVarBndr DocName] -> [Html]@@ -106,26 +108,29 @@ tyvarNames = map (getName . hsTyVarName . unLoc) -ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> Html-ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode- = ppFunSig summary links loc doc name typ unicode-ppFor _ _ _ _ _ _ = error "ppFor"+ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool + -> Qualification -> Html+ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode qual+ = ppFunSig summary links loc doc name typ unicode qual+ppFor _ _ _ _ _ _ _ = error "ppFor" -- we skip type patterns for now-ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Html-ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode+ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool+ -> Qualification -> Html+ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode qual = ppTypeOrFunSig summary links loc name (unLoc ltype) doc- (full, hdr, spaceHtml +++ equals) unicode+ (full, hdr, spaceHtml +++ equals) unicode qual where hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)- full = hdr <+> equals <+> ppLType unicode ltype- occ = docNameOcc name-ppTySyn _ _ _ _ _ _ = error "declaration not supported by ppTySyn"+ full = hdr <+> equals <+> ppLType unicode qual ltype+ occ = nameOccName . getName $ name+ppTySyn _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" -ppTypeSig :: Bool -> OccName -> HsType DocName -> Bool -> Html-ppTypeSig summary nm ty unicode = ppBinder summary nm <+> dcolon unicode <+> ppType unicode ty+ppTypeSig :: Bool -> OccName -> HsType DocName -> Bool -> Qualification -> Html+ppTypeSig summary nm ty unicode qual =+ ppBinder summary nm <+> dcolon unicode <+> ppType unicode qual ty ppTyName :: Name -> Html@@ -159,18 +164,18 @@ ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->- TyClDecl DocName -> Bool -> Html-ppTyFam summary associated links loc mbDoc decl unicode+ TyClDecl DocName -> Bool -> Qualification -> Html+ppTyFam summary associated links loc mbDoc decl unicode qual | summary = ppTyFamHeader True associated decl unicode- | otherwise = header_ +++ maybeDocSection mbDoc +++ instancesBit+ | otherwise = header_ +++ maybeDocSection qual mbDoc +++ instancesBit where docname = tcdName decl header_ = topDeclElem links loc docname (ppTyFamHeader summary associated decl unicode) - instancesBit = ppInstances instances docname unicode+ instancesBit = ppInstances instances docname unicode qual -- TODO: get the instances instances = []@@ -199,22 +204,23 @@ ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->- TyClDecl DocName -> Bool -> Html-ppTyInst summary associated links loc mbDoc decl unicode+ TyClDecl DocName -> Bool -> Qualification -> Html+ppTyInst summary associated links loc mbDoc decl unicode qual - | summary = ppTyInstHeader True associated decl unicode- | otherwise = header_ +++ maybeDocSection mbDoc+ | summary = ppTyInstHeader True associated decl unicode qual+ | otherwise = header_ +++ maybeDocSection qual mbDoc where docname = tcdName decl - header_ = topDeclElem links loc docname (ppTyInstHeader summary associated decl unicode)+ header_ = topDeclElem links loc docname+ (ppTyInstHeader summary associated decl unicode qual) -ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html-ppTyInstHeader _ _ decl unicode =+ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html+ppTyInstHeader _ _ decl unicode qual = keyword "type instance" <+>- ppAppNameTypes (tcdName decl) typeArgs unicode+ ppAppNameTypes (tcdName decl) typeArgs unicode qual where typeArgs = map unLoc . fromJust . tcdTyPats $ decl @@ -224,11 +230,12 @@ -------------------------------------------------------------------------------- -ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool -> Html-ppAssocType summ links doc (L loc decl) unicode =+ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool+ -> Qualification -> Html+ppAssocType summ links doc (L loc decl) unicode qual = case decl of- TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode- TySynonym {} -> ppTySyn summ links loc doc decl unicode+ TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode qual+ TySynonym {} -> ppTySyn summ links loc doc decl unicode qual _ -> error "declaration type not supported by ppAssocType" @@ -249,14 +256,15 @@ -- | Print an application of a DocName and a list of HsTypes-ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Html-ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)+ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Qualification -> Html+ppAppNameTypes n ts unicode qual =+ ppTypeApp n ts (ppDocName qual) (ppParendType unicode qual) -- | Print an application of a DocName and a list of Names ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html ppAppDocNameNames summ n ns =- ppTypeApp n ns (ppBinder summ . docNameOcc) ppTyName+ ppTypeApp n ns (ppBinder summ . nameOccName . getName) ppTyName -- | General printing of type applications@@ -276,36 +284,39 @@ ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> Html+ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool+ -> Qualification -> Html ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppContextNoArrow :: HsContext DocName -> Bool -> Html-ppContextNoArrow [] _ = noHtml-ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode+ppContextNoArrow :: HsContext DocName -> Bool -> Qualification -> Html+ppContextNoArrow [] _ _ = noHtml+ppContextNoArrow cxt unicode qual = pp_hs_context (map unLoc cxt) unicode qual -ppContextNoLocs :: [HsPred DocName] -> Bool -> Html-ppContextNoLocs [] _ = noHtml-ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode+ppContextNoLocs :: [HsPred DocName] -> Bool -> Qualification -> Html+ppContextNoLocs [] _ _ = noHtml+ppContextNoLocs cxt unicode qual = pp_hs_context cxt unicode qual + <+> darrow unicode -ppContext :: HsContext DocName -> Bool -> Html-ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode+ppContext :: HsContext DocName -> Bool -> Qualification -> Html+ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual -pp_hs_context :: [HsPred DocName] -> Bool -> Html-pp_hs_context [] _ = noHtml-pp_hs_context [p] unicode = ppPred unicode p-pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt)+pp_hs_context :: [HsPred DocName] -> Bool -> Qualification-> Html+pp_hs_context [] _ _ = noHtml+pp_hs_context [p] unicode qual = ppPred unicode qual p+pp_hs_context cxt unicode qual = parenList (map (ppPred unicode qual) cxt) -ppPred :: Bool -> HsPred DocName -> Html-ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode-ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <+> toHtml "~" <+> ppLType unicode t2-ppPred unicode (HsIParam (IPName n) t)- = toHtml "?" +++ ppDocName n <+> dcolon unicode <+> ppLType unicode t+ppPred :: Bool -> Qualification -> HsPred DocName -> Html+ppPred unicode qual (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode qual+ppPred unicode qual (HsEqualP t1 t2) = ppLType unicode qual t1 <+> toHtml "~"+ <+> ppLType unicode qual t2+ppPred unicode qual (HsIParam (IPName n) t)+ = toHtml "?" +++ ppDocName qual n <+> dcolon unicode <+> ppLType unicode qual t -------------------------------------------------------------------------------@@ -315,83 +326,87 @@ ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]- -> Bool -> Html-ppClassHdr summ lctxt n tvs fds unicode =+ -> Bool -> Qualification -> Html+ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class"- <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else noHtml)+ <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) <+> ppAppDocNameNames summ n (tyvarNames $ tvs)- <+> ppFds fds unicode+ <+> ppFds fds unicode qual -ppFds :: [Located ([DocName], [DocName])] -> Bool -> Html-ppFds fds unicode =+ppFds :: [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html+ppFds fds unicode qual = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where- fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>- hsep (map ppDocName vars2)+ fundep (vars1,vars2) = hsep (map (ppDocName qual) vars1) <+> arrow unicode <+>+ hsep (map (ppDocName qual) vars2) -ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Html-ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode = +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan+ -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification+ -> Html+ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc+ subdocs unicode qual = if null sigs && null ats then (if summary then id else topDeclElem links loc nm) hdr else (if summary then id else topDeclElem links loc nm) (hdr <+> keyword "where") +++ shortSubDecls (- [ ppAssocType summary links doc at unicode | at <- ats+ [ ppAssocType summary links doc at unicode qual | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++ - [ ppFunSig summary links loc doc n typ unicode+ [ ppFunSig summary links loc doc n typ unicode qual | L _ (TypeSig (L _ n) (L _ typ)) <- sigs , let doc = lookupAnySubdoc n subdocs ] ) where- hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode+ hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual nm = unLoc lname-ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"+ppShortClassDecl _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]- -> TyClDecl DocName -> Bool -> Html+ -> TyClDecl DocName -> Bool -> Qualification -> Html ppClassDecl summary links instances loc mbDoc subdocs- decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode- | summary = ppShortClassDecl summary links decl loc subdocs unicode- | otherwise = classheader +++ maybeDocSection mbDoc+ decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode qual+ | summary = ppShortClassDecl summary links decl loc subdocs unicode qual+ | otherwise = classheader +++ maybeDocSection qual mbDoc +++ atBit +++ methodBit +++ instancesBit where classheader- | null lsigs = topDeclElem links loc nm (hdr unicode)- | otherwise = topDeclElem links loc nm (hdr unicode <+> keyword "where")+ | null lsigs = topDeclElem links loc nm (hdr unicode qual)+ | otherwise = topDeclElem links loc nm (hdr unicode qual <+> keyword "where") nm = unLoc $ tcdLName decl hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds - atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode+ atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode qual | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] - methodBit = subMethods [ ppFunSig summary links loc doc n typ unicode+ methodBit = subMethods [ ppFunSig summary links loc doc n typ unicode qual | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs , let doc = lookupAnySubdoc n subdocs ] - instancesBit = ppInstances instances nm unicode+ instancesBit = ppInstances instances nm unicode qual -ppClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"+ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppInstances :: [DocInstance DocName] -> DocName -> Bool -> Html-ppInstances instances baseName unicode- = subInstances instName (map instDecl instances)+ppInstances :: [DocInstance DocName] -> DocName -> Bool -> Qualification -> Html+ppInstances instances baseName unicode qual+ = subInstances qual instName (map instDecl instances) where instName = getOccString $ getName baseName instDecl :: DocInstance DocName -> SubDecl instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])- instHead ([], n, ts) = ppAppNameTypes n ts unicode- instHead (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode+ instHead ([], n, ts) = ppAppNameTypes n ts unicode qual+ instHead (ctxt, n, ts) = ppContextNoLocs ctxt unicode qual+ <+> ppAppNameTypes n ts unicode qual lookupAnySubdoc :: (Eq name1) =>@@ -407,13 +422,14 @@ -- TODO: print contexts-ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool -> Html-ppShortDataDecl summary _links _loc dataDecl unicode+ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool+ -> Qualification -> Html+ppShortDataDecl summary _links _loc dataDecl unicode qual - | [] <- cons = dataHeader+ | [] <- cons = dataHeader | [lcon] <- cons, ResTyH98 <- resTy,- (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode+ (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode qual = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot | ResTyH98 <- resTy = dataHeader@@ -423,9 +439,9 @@ +++ shortSubDecls (map doGADTConstr cons) where- dataHeader = ppDataHeader summary dataDecl unicode- doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode- doGADTConstr con = ppShortConstr summary (unLoc con) unicode+ dataHeader = ppDataHeader summary dataDecl unicode qual+ doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual+ doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons@@ -433,18 +449,19 @@ ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->- SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> Html-ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode+ SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool ->+ Qualification -> Html+ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode qual - | summary = ppShortDataDecl summary links loc dataDecl unicode- | otherwise = header_ +++ maybeDocSection mbDoc +++ constrBit +++ instancesBit+ | summary = ppShortDataDecl summary links loc dataDecl unicode qual+ | otherwise = header_ +++ maybeDocSection qual mbDoc +++ constrBit +++ instancesBit where docname = unLoc . tcdLName $ dataDecl cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons - header_ = topDeclElem links loc docname (ppDataHeader summary dataDecl unicode+ header_ = topDeclElem links loc docname (ppDataHeader summary dataDecl unicode qual <+> whereBit) whereBit@@ -453,33 +470,34 @@ ResTyGADT _ -> keyword "where" _ -> noHtml - constrBit = subConstructors- (map (ppSideBySideConstr subdocs unicode) cons)+ constrBit = subConstructors qual+ (map (ppSideBySideConstr subdocs unicode qual) cons) - instancesBit = ppInstances instances docname unicode+ instancesBit = ppInstances instances docname unicode qual -ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html-ppShortConstr summary con unicode = cHead <+> cBody <+> cFoot+ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Qualification -> Html+ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot where- (cHead,cBody,cFoot) = ppShortConstrParts summary con unicode+ (cHead,cBody,cFoot) = ppShortConstrParts summary con unicode qual -- returns three pieces: header, body, footer so that header & footer can be -- incorporated into the declaration-ppShortConstrParts :: Bool -> ConDecl DocName -> Bool -> (Html, Html, Html)-ppShortConstrParts summary con unicode = case con_res con of+ppShortConstrParts :: Bool -> ConDecl DocName -> Bool -> Qualification -> (Html, Html, Html)+ppShortConstrParts summary con unicode qual = case con_res con of ResTyH98 -> case con_details con of PrefixCon args ->- (header_ unicode +++ hsep (ppBinder summary occ : map (ppLParendType unicode) args),- noHtml, noHtml)+ (header_ unicode qual +++ hsep (ppBinder summary occ+ : map (ppLParendType unicode qual) args), noHtml, noHtml) RecCon fields ->- (header_ unicode +++ ppBinder summary occ <+> char '{',+ (header_ unicode qual +++ ppBinder summary occ <+> char '{', doRecordFields fields, char '}') InfixCon arg1 arg2 ->- (header_ unicode +++ hsep [ppLParendType unicode arg1, ppBinder summary occ, ppLParendType unicode arg2],+ (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,+ ppBinder summary occ, ppLParendType unicode qual arg2], noHtml, noHtml) ResTyGADT resTy -> case con_details con of@@ -491,19 +509,19 @@ -- (except each field gets its own line in docs, to match -- non-GADT records) RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+>- ppForAll forall ltvs lcontext unicode <+> char '{',+ ppForAll forall ltvs lcontext unicode qual <+> char '{', doRecordFields fields,- char '}' <+> arrow unicode <+> ppLType unicode resTy)+ char '}' <+> arrow unicode <+> ppLType unicode qual resTy) InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) where- doRecordFields fields = shortSubDecls (map (ppShortField summary unicode) fields)+ doRecordFields fields = shortSubDecls (map (ppShortField summary unicode qual) fields) doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [- ppForAll forall ltvs lcontext unicode,- ppLType unicode (foldr mkFunTy resTy args) ]+ ppForAll forall ltvs lcontext unicode qual,+ ppLType unicode qual (foldr mkFunTy resTy args) ] header_ = ppConstrHdr forall tyVars context- occ = docNameOcc . unLoc . con_name $ con+ occ = nameOccName . getName . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames ltvs lcontext = con_cxt con@@ -513,36 +531,35 @@ -- ppConstrHdr is for (non-GADT) existentials constructors' syntax-#if __GLASGOW_HASKELL__ == 612-ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> Html-#else-ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> Html-#endif-ppConstrHdr forall tvs ctxt unicode+ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool+ -> Qualification -> Html+ppConstrHdr forall tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++- (if null ctxt then noHtml else ppContextNoArrow ctxt unicode <+> darrow unicode +++ toHtml " ")+ (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual+ <+> darrow unicode +++ toHtml " ") where ppForall = case forall of Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". " Implicit -> noHtml -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> SubDecl-ppSideBySideConstr subdocs unicode (L _ con) = (decl, mbDoc, fieldPart)+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> Qualification+ -> LConDecl DocName -> SubDecl+ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart) where decl = case con_res con of ResTyH98 -> case con_details con of PrefixCon args ->- hsep ((header_ unicode +++ ppBinder False occ)- : map (ppLParendType unicode) args)+ hsep ((header_ unicode qual +++ ppBinder False occ)+ : map (ppLParendType unicode qual) args) - RecCon _ -> header_ unicode +++ ppBinder False occ+ RecCon _ -> header_ unicode qual +++ ppBinder False occ InfixCon arg1 arg2 ->- hsep [header_ unicode+++ppLParendType unicode arg1,+ hsep [header_ unicode qual +++ ppLParendType unicode qual arg1, ppBinder False occ,- ppLParendType unicode arg2]+ ppLParendType unicode qual arg2] ResTyGADT resTy -> case con_details con of -- prefix & infix could also use hsConDeclArgTys if it seemed to@@ -555,16 +572,16 @@ RecCon fields -> [doRecordFields fields] _ -> [] - doRecordFields fields = subFields- (map (ppSideBySideField subdocs unicode) fields)+ doRecordFields fields = subFields qual+ (map (ppSideBySideField subdocs unicode qual) fields) doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html doGADTCon args resTy = ppBinder False occ <+> dcolon unicode- <+> hsep [ppForAll forall ltvs (con_cxt con) unicode,- ppLType unicode (foldr mkFunTy resTy args) ]+ <+> hsep [ppForAll forall ltvs (con_cxt con) unicode qual,+ ppLType unicode qual (foldr mkFunTy resTy args) ] header_ = ppConstrHdr forall tyVars context- occ = docNameOcc . unLoc . con_name $ con+ occ = nameOccName . getName . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con)@@ -576,9 +593,10 @@ mkFunTy a b = noLoc (HsFunTy a b) -ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> SubDecl-ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =- (ppBinder False (docNameOcc name) <+> dcolon unicode <+> ppLType unicode ltype,+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> Qualification+ -> ConDeclField DocName -> SubDecl+ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =+ (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype, mbDoc, []) where@@ -586,22 +604,22 @@ mbDoc = join $ fmap fst $ lookup name subdocs -ppShortField :: Bool -> Bool -> ConDeclField DocName -> Html-ppShortField summary unicode (ConDeclField (L _ name) ltype _)- = ppBinder summary (docNameOcc name)- <+> dcolon unicode <+> ppLType unicode ltype+ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html+ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)+ = ppBinder summary (nameOccName . getName $ name)+ <+> dcolon unicode <+> ppLType unicode qual ltype -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures-ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Html-ppDataHeader summary decl unicode+ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html+ppDataHeader summary decl unicode qual | not (isDataDecl decl) = error "ppDataHeader: illegal argument" | otherwise = -- newtype or data (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> -- context- ppLContext (tcdCtxt decl) unicode <+>+ ppLContext (tcdCtxt decl) unicode qual <+> -- T a b c ..., or a :+: b ppTyClBinderWithVars summary decl @@ -648,85 +666,80 @@ | otherwise = p -ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> Html-ppLType unicode y = ppType unicode (unLoc y)-ppLParendType unicode y = ppParendType unicode (unLoc y)-ppLFunLhType unicode y = ppFunLhType unicode (unLoc y)+ppLType, ppLParendType, ppLFunLhType :: Bool -> Qualification+ -> Located (HsType DocName) -> Html+ppLType unicode qual y = ppType unicode qual (unLoc y)+ppLParendType unicode qual y = ppParendType unicode qual (unLoc y)+ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y) -ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> Html-ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode-ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode-ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode+ppType, ppParendType, ppFunLhType :: Bool -> Qualification-> HsType DocName -> Html+ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual+ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual+ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -#if __GLASGOW_HASKELL__ == 612-ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)]-#else ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)]-#endif- -> Located (HsContext DocName) -> Bool -> Html-ppForAll expl tvs cxt unicode- | show_forall = forall_part <+> ppLContext cxt unicode- | otherwise = ppLContext cxt unicode+ -> Located (HsContext DocName) -> Bool -> Qualification -> Html+ppForAll expl tvs cxt unicode qual+ | show_forall = forall_part <+> ppLContext cxt unicode qual+ | otherwise = ppLContext cxt unicode qual where show_forall = not (null tvs) && is_explicit is_explicit = case expl of {Explicit -> True; Implicit -> False} forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot -ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Html-ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode+ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Qualification -> Html+ppr_mono_lty ctxt_prec ty unicode qual = ppr_mono_ty ctxt_prec (unLoc ty) unicode qual -ppr_mono_ty :: Int -> HsType DocName -> Bool -> Html-ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode+ppr_mono_ty :: Int -> HsType DocName -> Bool -> Qualification -> Html+ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $- hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode]+ hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual] -ppr_mono_ty _ (HsBangTy b ty) u = ppBang b +++ ppLParendType u ty-ppr_mono_ty _ (HsTyVar name) _ = ppDocName name-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u-ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)-ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppKind kind)-ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u)-ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)-ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p)-ppr_mono_ty _ (HsNumTy n) _ = toHtml (show n) -- generics only-ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"-#if __GLASGOW_HASKELL__ == 612-ppr_mono_ty _ (HsSpliceTyOut {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"-#else-ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"-#endif-ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"+ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty+ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q name+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q+ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)+ppr_mono_ty _ (HsKindSig ty kind) u q =+ parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppKind kind)+ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q)+ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)+ppr_mono_ty _ (HsPredTy p) u q = parens (ppPred u q p)+ppr_mono_ty _ (HsNumTy n) _ _ = toHtml (show n) -- generics only+ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"+ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"+ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"+ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual = maybeParen ctxt_prec pREC_CON $- hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]+ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual = maybeParen ctxt_prec pREC_FUN $- ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode+ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where- ppr_op = if not (isSymOcc occName) then quote (ppLDocName op) else ppLDocName op- occName = docNameOcc . unLoc $ op+ ppr_op = if not (isSymOcc occName) then quote (ppLDocName qual op) else ppLDocName qual op+ occName = nameOccName . getName . unLoc $ op -ppr_mono_ty ctxt_prec (HsParTy ty) unicode+ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual -- = parens (ppr_mono_lty pREC_TOP ty)- = ppr_mono_lty ctxt_prec ty unicode+ = ppr_mono_lty ctxt_prec ty unicode qual -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode- = ppr_mono_lty ctxt_prec ty unicode+ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual+ = ppr_mono_lty ctxt_prec ty unicode qual -ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Html-ppr_fun_ty ctxt_prec ty1 ty2 unicode- = let p1 = ppr_mono_lty pREC_FUN ty1 unicode- p2 = ppr_mono_lty pREC_TOP ty2 unicode+ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Qualification -> Html+ppr_fun_ty ctxt_prec ty1 ty2 unicode qual+ = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual+ p2 = ppr_mono_lty pREC_TOP ty2 unicode qual in maybeParen ctxt_prec pREC_FUN $ hsep [p1, arrow unicode <+> p2]
src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -64,20 +64,20 @@ | isTyCon x = x | otherwise = y - examplesToHtml l = (pre $ concatHtml $ map exampleToHtml l) ! [theclass "screen"]+ examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"] exampleToHtml (Example expression result) = htmlExample where- htmlExample = htmlPrompt +++ htmlExpression +++ (toHtml $ unlines result)+ htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result) htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"] htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] -- If the doc is a single paragraph, don't surround it with <P> (this causes -- ugly extra whitespace with some browsers). FIXME: Does this still apply?-docToHtml :: Doc DocName -> Html-docToHtml = markup fmt . cleanup- where fmt = parHtmlMarkup ppDocName (isTyConName . getName)+docToHtml :: Qualification -> Doc DocName -> Html+docToHtml qual = markup fmt . cleanup+ where fmt = parHtmlMarkup (ppDocName qual) (isTyConName . getName) origDocToHtml :: Doc Name -> Html@@ -97,12 +97,12 @@ else el ! [theclass "doc"] << content_ -docSection :: Doc DocName -> Html-docSection = (docElement thediv <<) . docToHtml+docSection :: Qualification -> Doc DocName -> Html+docSection qual = (docElement thediv <<) . docToHtml qual -maybeDocSection :: Maybe (Doc DocName) -> Html-maybeDocSection = maybe noHtml docSection+maybeDocSection :: Qualification -> Maybe (Doc DocName) -> Html+maybeDocSection qual = maybe noHtml (docSection qual) cleanup :: Doc a -> Doc a
src/Haddock/Backends/Xhtml/Layout.hs view
@@ -112,25 +112,26 @@ subCaption = paragraph ! [theclass "caption"] << captionName -subDlist :: [SubDecl] -> Maybe Html-subDlist [] = Nothing-subDlist decls = Just $ dlist << map subEntry decls +++ clearDiv+subDlist :: Qualification -> [SubDecl] -> Maybe Html+subDlist _ [] = Nothing+subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv where subEntry (decl, mdoc, subs) = dterm ! [theclass "src"] << decl +++- docElement ddef << (fmap docToHtml mdoc +++ subs)+ docElement ddef << (fmap (docToHtml qual) mdoc +++ subs)+ clearDiv = thediv ! [ theclass "clear" ] << noHtml -subTable :: [SubDecl] -> Maybe Html-subTable [] = Nothing-subTable decls = Just $ table << aboves (concatMap subRow decls)+subTable :: Qualification -> [SubDecl] -> Maybe Html+subTable _ [] = Nothing+subTable qual decls = Just $ table << aboves (concatMap subRow decls) where subRow (decl, mdoc, subs) = (td ! [theclass "src"] << decl <->- docElement td << fmap docToHtml mdoc)+ docElement td << fmap (docToHtml qual) mdoc) : map (cell . (td <<)) subs @@ -139,28 +140,28 @@ subBlock hs = Just $ toHtml hs -subArguments :: [SubDecl] -> Html-subArguments = divSubDecls "arguments" "Arguments" . subTable+subArguments :: Qualification -> [SubDecl] -> Html+subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual subAssociatedTypes :: [Html] -> Html subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock -subConstructors :: [SubDecl] -> Html-subConstructors = divSubDecls "constructors" "Constructors" . subTable+subConstructors :: Qualification -> [SubDecl] -> Html+subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual -subFields :: [SubDecl] -> Html-subFields = divSubDecls "fields" "Fields" . subDlist+subFields :: Qualification -> [SubDecl] -> Html+subFields qual = divSubDecls "fields" "Fields" . subDlist qual -subInstances :: String -> [SubDecl] -> Html-subInstances nm = maybe noHtml wrap . instTable+subInstances :: Qualification -> String -> [SubDecl] -> Html+subInstances qual nm = maybe noHtml wrap . instTable where wrap = (subSection <<) . (subCaption +++)- instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable- subSection = thediv ! [theclass $ "subs instances"]+ instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual+ subSection = thediv ! [theclass "subs instances"] subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm
src/Haddock/Backends/Xhtml/Names.hs view
@@ -24,6 +24,7 @@ import Haddock.Utils import Text.XHtml hiding ( name, title, p, quote )+import qualified Data.List as List import GHC import Name@@ -38,15 +39,45 @@ ppRdrName = ppOccName . rdrNameOcc -ppLDocName :: Located DocName -> Html-ppLDocName (L _ d) = ppDocName d+ppLDocName :: Qualification -> Located DocName -> Html+ppLDocName qual (L _ d) = ppDocName qual d -ppDocName :: DocName -> Html-ppDocName (Documented name mdl) =- linkIdOcc mdl (Just occName) << ppOccName occName- where occName = nameOccName name-ppDocName (Undocumented name) = toHtml (getOccString name)+ppDocName :: Qualification -> DocName -> Html+ppDocName qual docName =+ case docName of+ Documented name mdl ->+ linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual name mdl+ Undocumented name -> ppQualifyName qual name (nameModule name)+++-- | Render a name depending on the selected qualification mode+ppQualifyName :: Qualification -> Name -> Module -> Html+ppQualifyName qual name mdl =+ case qual of+ NoQual -> ppName name+ FullQual -> ppFullQualName mdl name+ -- this is just in case, it should never happen+ LocalQual Nothing -> ppQualifyName FullQual name mdl+ LocalQual (Just localmdl)+ | moduleString mdl == moduleString localmdl -> ppName name+ | otherwise -> ppFullQualName mdl name+ -- again, this never happens+ RelativeQual Nothing -> ppQualifyName FullQual name mdl+ RelativeQual (Just localmdl) ->+ case List.stripPrefix (moduleString localmdl) (moduleString mdl) of+ -- local, A.x -> x+ Just [] -> ppQualifyName NoQual name mdl+ -- sub-module, A.B.x -> B.x+ Just ('.':m) -> toHtml $ m ++ '.' : getOccString name+ -- some module with same prefix, ABC.x -> ABC.x+ Just _ -> ppQualifyName FullQual name mdl+ -- some other module, D.x -> D.x+ Nothing -> ppQualifyName FullQual name mdl+++ppFullQualName :: Module -> Name -> Html+ppFullQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name ppName :: Name -> Html
src/Haddock/Backends/Xhtml/Themes.hs view
@@ -18,6 +18,7 @@ import Haddock.Options +import Control.Applicative import Control.Monad (liftM) import Data.Char (toLower) import Data.Either (lefts, rights)@@ -97,13 +98,13 @@ -- | Check if we have a built in theme doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool-doesBuiltInExist pts s = pts >>= return . either (const False) test +doesBuiltInExist pts s = fmap (either (const False) test) pts where test = isJust . findTheme s -- | Find a built in theme builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme-builtInTheme pts s = pts >>= return . either Left fetch+builtInTheme pts s = either Left fetch <$> pts where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s @@ -157,9 +158,10 @@ -- * File Utilities -------------------------------------------------------------------------------- + getDirectoryItems :: FilePath -> IO [FilePath] getDirectoryItems path =- getDirectoryContents path >>= return . map (combine path) . filter notDot+ map (combine path) . filter notDot <$> getDirectoryContents path where notDot s = s /= "." && s /= ".." @@ -178,7 +180,7 @@ styleSheet :: Themes -> Html styleSheet ts = toHtml $ zipWith mkLink rels ts where- rels = ("stylesheet" : repeat "alternate stylesheet")+ rels = "stylesheet" : repeat "alternate stylesheet" mkLink aRel t = thelink ! [ href (themeHref t), rel aRel, thetype "text/css",
src/Haddock/Backends/Xhtml/Utils.hs view
@@ -15,6 +15,7 @@ namedAnchor, linkedAnchor, spliceURL,+ groupId, (<+>), char, nonEmpty, keyword, punctuate,@@ -66,7 +67,7 @@ run ('%':'N':rest) = name ++ run rest run ('%':'K':rest) = kind ++ run rest run ('%':'L':rest) = line ++ run rest- run ('%':'%':rest) = "%" ++ run rest+ run ('%':'%':rest) = "%" ++ run rest run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest@@ -84,9 +85,10 @@ run (c:rest) = c : run rest -renderToString :: Html -> String-renderToString = showHtml -- for production---renderToString = prettyHtml -- for debugging+renderToString :: Bool -> Html -> String+renderToString debug html+ | debug = renderHtml html+ | otherwise = showHtml html hsep :: [Html] -> Html@@ -171,6 +173,10 @@ linkedAnchor :: String -> Html -> Html linkedAnchor n = anchor ! [href ('#':n)] ++-- | generate an anchor identifier for a group+groupId :: String -> String+groupId g = makeAnchorId ("g:" ++ g) -- -- A section of HTML which is collapsible.
src/Haddock/Convert.hs view
@@ -20,12 +20,7 @@ import HsSyn import TcType ( tcSplitSigmaTy ) import TypeRep-#if __GLASGOW_HASKELL__ == 612-import Type ( splitKindFunTys )-import BasicTypes-#else-import Coercion ( splitKindFunTys )-#endif+import Coercion ( splitKindFunTys, synTyConResKind ) import Name import Var import Class@@ -101,15 +96,15 @@ [] -- "deriving" needn't be specified: Nothing- | isOpenSynTyCon tc =+ | isSynFamilyTyCon tc = case synTyConRhs tc of- OpenSynTyCon rhs_kind _ ->+ SynFamilyTyCon -> TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))- (Just rhs_kind)+ (Just (synTyConResKind tc)) _ -> error "synifyTyCon: impossible open type synonym?"- | isOpenTyCon tc = --(why no "isOpenAlgTyCon"?)+ | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?) case algTyConRhs tc of- OpenTyCon _ ->+ DataFamilyTyCon -> TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) Nothing --always kind '*' _ -> error "synifyTyCon: impossible open data type?"@@ -175,18 +170,10 @@ linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty in case bang of-#if __GLASGOW_HASKELL__ >= 613 HsUnpackFailed -> noLoc $ HsBangTy HsStrict tySyn HsNoBang -> tySyn -- HsNoBang never appears, it's implied instead. _ -> noLoc $ HsBangTy bang tySyn-#else- MarkedStrict -> noLoc $ HsBangTy HsStrict tySyn- MarkedUnboxed -> noLoc $ HsBangTy HsUnbox tySyn- NotMarkedStrict -> tySyn- -- HsNoBang never appears, it's implied instead.-#endif- ) (dataConOrigArgTys dc) (dataConStrictMarks dc) field_tys = zipWith (\field synTy -> ConDeclField@@ -245,11 +232,7 @@ kind = tyVarKind tv name = getName tv in if isLiftedTypeKind kind-#if __GLASGOW_HASKELL__ == 612- then UserTyVar name-#else then UserTyVar name placeHolderKind-#endif else KindedTyVar name kind
src/Haddock/GhcUtils.hs view
@@ -17,7 +17,6 @@ import Data.Version-import qualified Data.Map as Map import Control.Arrow import Data.Foldable hiding (concatMap) import Data.Traversable@@ -30,12 +29,11 @@ import Packages import Module import RdrName (GlobalRdrEnv)+#if MIN_VERSION_ghc(7,1,0)+import GhcMonad (withSession)+#endif import HscTypes-#if __GLASGOW_HASKELL__ >= 613 import UniqFM-#else-import LazyUniqFM-#endif import GHC @@ -75,10 +73,6 @@ _not_a_home_module -> return Nothing -instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where- ppr m = ppr (Map.toList m)-- isNameSym :: Name -> Bool isNameSym = isSymOcc . nameOccName @@ -90,15 +84,9 @@ getMainDeclBinder :: HsDecl name -> Maybe name getMainDeclBinder (TyClD d) = Just (tcdName d) getMainDeclBinder (ValD d) =-#if __GLASGOW_HASKELL__ == 612- case collectAcc d [] of- [] -> Nothing- (name:_) -> Just (unLoc name)-#else case collectHsBindBinders d of [] -> Nothing (name:_) -> Just name-#endif getMainDeclBinder (SigD d) = sigNameNoLoc d
src/Haddock/Interface.hs view
@@ -46,6 +46,7 @@ import Distribution.Verbosity import System.Directory import System.FilePath+import Text.Printf import Digraph import Exception@@ -101,12 +102,11 @@ -- resulting ModSummaries. (if useTempDir then withTempOutputDir else id) $ do modGraph <- depAnalysis- if needsTemplateHaskell modGraph- then do- modGraph' <- enableCompilation modGraph- createIfaces verbosity flags instIfaceMap modGraph'- else- createIfaces verbosity flags instIfaceMap modGraph+ if needsTemplateHaskell modGraph then do+ modGraph' <- enableCompilation modGraph+ createIfaces verbosity flags instIfaceMap modGraph'+ else+ createIfaces verbosity flags instIfaceMap modGraph where useTempDir :: Bool@@ -156,15 +156,21 @@ processModule verbosity modsum flags modMap instIfaceMap = do out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." tm <- loadModule =<< typecheckModule =<< parseModule modsum- if not $ isBootSummary modsum- then do- out verbosity verbose "Creating interface..."- (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap- liftIO $ mapM_ putStrLn msg- interface' <- liftIO $ evaluate interface- return (Just interface')- else- return Nothing+ if not $ isBootSummary modsum then do+ out verbosity verbose "Creating interface..."+ (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap+ liftIO $ mapM_ putStrLn msg+ let (haddockable, haddocked) = ifaceHaddockCoverage interface+ percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int+ coveragemsg = printf "haddock coverage for %s: %7s %3d%%"+ (ifaceOrigFilename interface)+ (printf "%d/%d" haddocked haddockable :: String)+ percentage+ out verbosity normal coveragemsg+ interface' <- liftIO $ evaluate interface+ return (Just interface')+ else+ return Nothing --------------------------------------------------------------------------------
src/Haddock/Interface/AttachInstances.hs view
@@ -25,7 +25,12 @@ import Name import InstEnv import Class-import HscTypes (withSession, ioMsg)+#if MIN_VERSION_ghc(7,1,0)+import GhcMonad (withSession)+#else+import HscTypes (withSession)+#endif+import MonadUtils (liftIO) import TcRnDriver (tcRnGetInfo) import TypeRep hiding (funTyConName) import Var hiding (varName)@@ -93,7 +98,9 @@ -- | Like GHC's getInfo but doesn't cut things out depending on the -- interative context, which we don't set sufficiently anyway. getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))-getAllInfo name = withSession $ \hsc_env -> ioMsg $ tcRnGetInfo hsc_env name+getAllInfo name = withSession $ \hsc_env -> do + (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name+ return r --------------------------------------------------------------------------------
src/Haddock/Interface/Create.hs view
@@ -79,11 +79,18 @@ let visibleNames = mkVisibleNames exportItems opts + -- measure haddock documentation coverage.+ let+ prunedExportItems0 = pruneExportItems exportItems+ haddockable = 1 + length exportItems -- module + exports+ haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0+ coverage = (haddockable, haddocked)+ -- prune the export list to just those declarations that have -- documentation, if the 'prune' option is on. let prunedExportItems- | OptPrune `elem` opts = pruneExportItems exportItems+ | OptPrune `elem` opts = prunedExportItems0 | otherwise = exportItems return Interface {@@ -101,7 +108,8 @@ ifaceDeclMap = declMap, ifaceSubMap = mkSubMap declMap exportedNames, ifaceInstances = instances,- ifaceInstanceDocMap = instanceDocMap+ ifaceInstanceDocMap = instanceDocMap,+ ifaceHaddockCoverage = coverage } @@ -565,53 +573,52 @@ -- those exported type-inferenced values. isLocalAndTypeInferenced <- liftGhcToErrMsgGhc $ do let mdl = nameModule t- if modulePackageId mdl == thisPackage dflags- then isLoaded (moduleName mdl)- else return False+ if modulePackageId mdl == thisPackage dflags then+ isLoaded (moduleName mdl)+ else return False - if isLocalAndTypeInferenced- then do- -- I don't think there can be any subs in this case,- -- currently? But better not to rely on it.- let subs = subordinatesWithNoDocs (unLoc hsdecl)- return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ]- else- -- We try to get the subs and docs- -- from the installed interface of that package.- case Map.lookup (nameModule t) instIfaceMap of- -- It's Nothing in the cases where I thought- -- Haddock has already warned the user: "Warning: The- -- documentation for the following packages are not- -- installed. No links will be generated to these packages:- -- ..."- -- But I guess it was Cabal creating that warning. Anyway,- -- this is more serious than links: it's exported decls where- -- we don't have the docs that they deserve!+ if isLocalAndTypeInferenced then do+ -- I don't think there can be any subs in this case,+ -- currently? But better not to rely on it.+ let subs = subordinatesWithNoDocs (unLoc hsdecl)+ return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ]+ else+ -- We try to get the subs and docs+ -- from the installed interface of that package.+ case Map.lookup (nameModule t) instIfaceMap of+ -- It's Nothing in the cases where I thought+ -- Haddock has already warned the user: "Warning: The+ -- documentation for the following packages are not+ -- installed. No links will be generated to these packages:+ -- ..."+ -- But I guess it was Cabal creating that warning. Anyway,+ -- this is more serious than links: it's exported decls where+ -- we don't have the docs that they deserve! - -- We could use 'subordinates' to find the Names of the subs- -- (with no docs). Is that necessary? Yes it is, otherwise- -- e.g. classes will be shown without their exported subs.- Nothing -> do- liftErrMsg $ tell- ["Warning: Couldn't find .haddock for exported "- ++ exportInfoString]- let subs = subordinatesWithNoDocs (unLoc hsdecl)- return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ]- Just iface -> do- let subs = case Map.lookup t (instSubMap iface) of- Nothing -> []- Just x -> x- return [ mkExportDecl t- ( hsdecl- , fromMaybe noDocForDecl $- Map.lookup t (instDocMap iface)- , map (\subt ->- ( subt ,- fromMaybe noDocForDecl $- Map.lookup subt (instDocMap iface)- )- ) subs- )]+ -- We could use 'subordinates' to find the Names of the subs+ -- (with no docs). Is that necessary? Yes it is, otherwise+ -- e.g. classes will be shown without their exported subs.+ Nothing -> do+ liftErrMsg $ tell+ ["Warning: Couldn't find .haddock for exported "+ ++ exportInfoString]+ let subs = subordinatesWithNoDocs (unLoc hsdecl)+ return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ]+ Just iface -> do+ let subs = case Map.lookup t (instSubMap iface) of+ Nothing -> []+ Just x -> x+ return [ mkExportDecl t+ ( hsdecl+ , fromMaybe noDocForDecl $+ Map.lookup t (instDocMap iface)+ , map (\subt ->+ ( subt ,+ fromMaybe noDocForDecl $+ Map.lookup subt (instDocMap iface)+ )+ ) subs+ )] mkExportDecl :: Name -> DeclInfo -> ExportItem Name
src/Haddock/InterfaceFile.hs view
@@ -35,6 +35,9 @@ import UniqFM import IfaceEnv import HscTypes+#if MIN_VERSION_ghc(7,1,0)+import GhcMonad (withSession)+#endif import FastMutInt import FastString import Unique@@ -61,13 +64,9 @@ -- because we store GHC datatypes in our interface files, we need to make sure -- we version our interface files accordingly. binaryInterfaceVersion :: Word16-#if __GLASGOW_HASKELL__ == 612-binaryInterfaceVersion = 15-#elif __GLASGOW_HASKELL__ == 613-binaryInterfaceVersion = 15-#elif __GLASGOW_HASKELL__ == 614+#if __GLASGOW_HASKELL__ == 700 binaryInterfaceVersion = 16-#elif __GLASGOW_HASKELL__ == 615+#elif __GLASGOW_HASKELL__ == 701 binaryInterfaceVersion = 16 #else #error Unknown GHC version
src/Haddock/Lex.x view
@@ -8,6 +8,7 @@ -- {+{-# LANGUAGE BangPatterns #-} {-# OPTIONS -Wwarn -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix@@ -184,12 +185,12 @@ strToHsQNames :: DynFlags -> String -> Maybe [RdrName] strToHsQNames dflags str0 = - let buffer = unsafePerformIO (stringToStringBuffer str0)-#if MIN_VERSION_ghc(6,13,0)- pstate = mkPState dflags buffer noSrcLoc+#if MIN_VERSION_ghc(7,1,0)+ let buffer = stringToStringBuffer str0 #else- pstate = mkPState buffer noSrcLoc dflags+ let buffer = unsafePerformIO (stringToStringBuffer str0) #endif+ pstate = mkPState dflags buffer noSrcLoc result = unP parseIdentifier pstate in case result of POk _ name -> Just [unLoc name]
src/Haddock/Options.hs view
@@ -24,6 +24,7 @@ wikiUrls, optDumpInterfaceFile, optLaTeXStyle,+ qualification, verbosity, ghcFlags, readIfaceArgs@@ -35,12 +36,12 @@ import Haddock.Utils import Haddock.Types import System.Console.GetOpt+import qualified Data.Char as Char data Flag = Flag_BuiltInThemes | Flag_CSS String- | Flag_Debug -- | Flag_DocBook | Flag_ReadInterface String | Flag_DumpInterface String@@ -74,6 +75,8 @@ | Flag_NoWarnings | Flag_UseUnicode | Flag_NoTmpCompDir+ | Flag_Qualification String+ | Flag_PrettyHtml deriving (Eq) @@ -120,8 +123,8 @@ "file containing prologue text", Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE") "page heading",- Option ['d'] ["debug"] (NoArg Flag_Debug)- "extra debugging output",+ Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUAL")+ "qualification of names, one of \n'none' (default), 'full', 'local'\nor 'relative'", Option ['?'] ["help"] (NoArg Flag_Help) "display this help and exit", Option ['V'] ["version"] (NoArg Flag_Version)@@ -148,7 +151,9 @@ "output GHC lib dir", Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings", Option [] ["no-tmp-comp-dir"] (NoArg Flag_NoTmpCompDir)- "do not re-direct compilation output to a temporary directory"+ "do not re-direct compilation output to a temporary directory",+ Option [] ["pretty-html"] (NoArg Flag_PrettyHtml)+ "generate html with newlines and indenting (for use with --html)" ] @@ -216,6 +221,15 @@ optLaTeXStyle :: [Flag] -> Maybe String optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]+++qualification :: [Flag] -> Qualification+qualification flags =+ case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of+ "full":_ -> FullQual+ "local":_ -> LocalQual Nothing+ "relative":_ -> RelativeQual Nothing+ _ -> NoQual verbosity :: [Flag] -> Verbosity
src/Haddock/Parse.y view
@@ -1,4 +1,5 @@ {+{-# LANGUAGE BangPatterns #-} {-# OPTIONS -Wwarn -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix
src/Haddock/Types.hs view
@@ -53,96 +53,100 @@ -- lies in creating this structure. Note that the record contains some fields -- that are only used to create the final record, and that are not used by the -- backends.-data Interface = Interface {+data Interface = Interface+ {+ -- | The module behind this interface.+ ifaceMod :: Module - -- | The module represented by this interface.- ifaceMod :: Module,+ -- | Original file name of the module.+ , ifaceOrigFilename :: FilePath - -- | Original file name of the module.- ifaceOrigFilename :: FilePath,+ -- | Textual information about the module.+ , ifaceInfo :: !(HaddockModInfo Name) - -- | Textual information about the module.- ifaceInfo :: !(HaddockModInfo Name),+ -- | Documentation header.+ , ifaceDoc :: !(Maybe (Doc Name)) - -- | Documentation header.- ifaceDoc :: !(Maybe (Doc Name)),+ -- | Documentation header with cross-reference information.+ , ifaceRnDoc :: Maybe (Doc DocName) - -- | Documentation header with link information.- ifaceRnDoc :: Maybe (Doc DocName),+ -- | Haddock options for this module (prune, ignore-exports, etc).+ , ifaceOptions :: ![DocOption] - -- | Haddock options for this module (prune, ignore-exports, etc).- ifaceOptions :: ![DocOption],+ -- | Declarations originating from the module. Excludes declarations without+ -- names (instances and stand-alone documentation comments). Includes+ -- names of subordinate declarations mapped to their parent declarations.+ , ifaceDeclMap :: Map Name DeclInfo - -- | Declarations originating from the module. Excludes declarations without- -- names (instances and stand-alone documentation comments). Includes- -- names of subordinate declarations mapped to their parent declarations.- ifaceDeclMap :: Map Name DeclInfo,+ -- | Documentation of declarations originating from the module (including+ -- subordinates).+ , ifaceRnDocMap :: Map Name (DocForDecl DocName) - -- | Documentation of declarations originating from the module (including- -- subordinates).- ifaceRnDocMap :: Map Name (DocForDecl DocName),+ , ifaceSubMap :: Map Name [Name] - ifaceSubMap :: Map Name [Name],+ , ifaceExportItems :: ![ExportItem Name]+ , ifaceRnExportItems :: [ExportItem DocName] - ifaceExportItems :: ![ExportItem Name],- ifaceRnExportItems :: [ExportItem DocName],+ -- | All names exported by the module.+ , ifaceExports :: ![Name] - -- | All names exported by the module.- ifaceExports :: ![Name],+ -- | All \"visible\" names exported by the module.+ -- A visible name is a name that will show up in the documentation of the+ -- module.+ , ifaceVisibleExports :: ![Name] - -- | All \"visible\" names exported by the module.- -- A visible name is a name that will show up in the documentation of the- -- module.- ifaceVisibleExports :: ![Name],+ -- | Instances exported by the module.+ , ifaceInstances :: ![Instance] - -- | Instances exported by the module.- ifaceInstances :: ![Instance],+ -- | Documentation of instances defined in the module.+ , ifaceInstanceDocMap :: Map Name (Doc Name) - -- | Documentation of instances defined in the module.- ifaceInstanceDocMap :: Map Name (Doc Name)-}+ -- | The number of haddockable and haddocked items in the module, as a+ -- tuple. Haddockable items are the exports and the module itself.+ , ifaceHaddockCoverage :: (Int,Int)+ } --- | A smaller version of 'Interface' that can be created from Haddock's--- interface files ('InterfaceFile').-data InstalledInterface = InstalledInterface {-- -- | The module represented by this interface.- instMod :: Module,+-- | A subset of the fields of 'Interface' that we store in the interface+-- files.+data InstalledInterface = InstalledInterface+ {+ -- | The module represented by this interface.+ instMod :: Module - -- | Textual information about the module.- instInfo :: HaddockModInfo Name,+ -- | Textual information about the module.+ , instInfo :: HaddockModInfo Name - -- | Documentation of declarations originating from the module (including- -- subordinates).- instDocMap :: Map Name (DocForDecl Name),+ -- | Documentation of declarations originating from the module (including+ -- subordinates).+ , instDocMap :: Map Name (DocForDecl Name) - -- | All names exported by this module.- instExports :: [Name],+ -- | All names exported by this module.+ , instExports :: [Name] - -- | All \"visible\" names exported by the module.- -- A visible name is a name that will show up in the documentation of the- -- module.- instVisibleExports :: [Name],+ -- | All \"visible\" names exported by the module.+ -- A visible name is a name that will show up in the documentation of the+ -- module.+ , instVisibleExports :: [Name] - -- | Haddock options for this module (prune, ignore-exports, etc).- instOptions :: [DocOption],+ -- | Haddock options for this module (prune, ignore-exports, etc).+ , instOptions :: [DocOption] - instSubMap :: Map Name [Name]-}+ , instSubMap :: Map Name [Name]+ } -- | Convert an 'Interface' to an 'InstalledInterface' toInstalledIface :: Interface -> InstalledInterface-toInstalledIface interface = InstalledInterface {- instMod = ifaceMod interface,- instInfo = ifaceInfo interface,- instDocMap = fmap unrenameDocForDecl $ ifaceRnDocMap interface,- instExports = ifaceExports interface,- instVisibleExports = ifaceVisibleExports interface,- instOptions = ifaceOptions interface,- instSubMap = ifaceSubMap interface-}+toInstalledIface interface = InstalledInterface+ { instMod = ifaceMod interface+ , instInfo = ifaceInfo interface+ , instDocMap = fmap unrenameDocForDecl $ ifaceRnDocMap interface+ , instExports = ifaceExports interface+ , instVisibleExports = ifaceVisibleExports interface+ , instOptions = ifaceOptions interface+ , instSubMap = ifaceSubMap interface+ } -----------------------------------------------------------------------------@@ -152,53 +156,55 @@ data ExportItem name - = ExportDecl {-- -- | A declaration- expItemDecl :: LHsDecl name,-- -- | Maybe a doc comment, and possibly docs for arguments (if this- -- decl is a function or type-synonym)- expItemMbDoc :: DocForDecl name,-- -- | Subordinate names, possibly with documentation- expItemSubDocs :: [(name, DocForDecl name)],-- -- | Instances relevant to this declaration, possibly with documentation- expItemInstances :: [DocInstance name]-- } -- ^ An exported declaration+ -- | An exported declaration.+ = ExportDecl+ {+ -- | A declaration.+ expItemDecl :: LHsDecl name - | ExportNoDecl {- expItemName :: name,+ -- | Maybe a doc comment, and possibly docs for arguments (if this+ -- decl is a function or type-synonym).+ , expItemMbDoc :: DocForDecl name - -- | Subordinate names- expItemSubs :: [name]+ -- | Subordinate names, possibly with documentation.+ , expItemSubDocs :: [(name, DocForDecl name)] - } -- ^ An exported entity for which we have no- -- documentation (perhaps because it resides in- -- another package)+ -- | Instances relevant to this declaration, possibly with+ -- documentation.+ , expItemInstances :: [DocInstance name]+ } - | ExportGroup {+ -- | An exported entity for which we have no documentation (perhaps because it+ -- resides in another package).+ | ExportNoDecl+ { expItemName :: name - -- | Section level (1, 2, 3, ... )- expItemSectionLevel :: Int,+ -- | Subordinate names.+ , expItemSubs :: [name]+ } - -- | Section id (for hyperlinks)- expItemSectionId :: String,+ -- | A section heading. + | ExportGroup+ {+ -- | Section level (1, 2, 3, ...).+ expItemSectionLevel :: Int - -- | Section heading text- expItemSectionText :: Doc name+ -- | Section id (for hyperlinks).+ , expItemSectionId :: String - } -- ^ A section heading+ -- | Section heading text.+ , expItemSectionText :: Doc name+ } - | ExportDoc (Doc name) -- ^ Some documentation+ -- | Some documentation.+ | ExportDoc (Doc name) - | ExportModule Module -- ^ A cross-reference to another module+ -- | A cross-reference to another module.+ | ExportModule Module -- | A declaration that may have documentation, including its subordinates,--- which may also have documentation+-- which may also have documentation. type DeclInfo = (Decl, DocForDecl Name, [(Name, DocForDecl Name)]) @@ -218,23 +224,24 @@ -------------------------------------------------------------------------------- * Hyperlinking+-- * Cross-referencing ----------------------------------------------------------------------------- --- | An environment used to create hyper-linked syntax.+-- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module --- | An extension of 'Name' that may contain the preferred place to link to in--- the documentation.-data DocName = Documented Name Module | Undocumented Name deriving Eq--- TODO: simplify to data DocName = DocName Name (Maybe Module)----- | The 'OccName' of this name.-docNameOcc :: DocName -> OccName-docNameOcc = nameOccName . getName+-- | Extends 'Name' with cross-reference information.+data DocName+ = Documented Name Module+ -- ^ This thing is part of the (existing or resulting)+ -- documentation. The 'Module' is the preferred place+ -- in the documentation to refer to.+ | Undocumented Name+ -- ^ This thing is not part of the (existing or resulting)+ -- documentation, as far as Haddock knows.+ deriving Eq instance NamedThing DocName where@@ -251,8 +258,8 @@ type DocInstance name = (InstHead name, Maybe (Doc name)) --- | The head of an instance. Consists of a context, a class name and a list of--- instance types.+-- | The head of an instance. Consists of a context, a class name and a list+-- of instance types. type InstHead name = ([HsPred name], name, [HsType name]) @@ -299,41 +306,41 @@ ">>> " ++ expression ++ "\n" ++ unlines result -data DocMarkup id a = Markup {- markupEmpty :: a,- markupString :: String -> a,- markupParagraph :: a -> a,- markupAppend :: a -> a -> a,- markupIdentifier :: [id] -> a,- markupModule :: String -> a,- markupEmphasis :: a -> a,- markupMonospaced :: a -> a,- markupUnorderedList :: [a] -> a,- markupOrderedList :: [a] -> a,- markupDefList :: [(a,a)] -> a,- markupCodeBlock :: a -> a,- markupURL :: String -> a,- markupAName :: String -> a,- markupPic :: String -> a,- markupExample :: [Example] -> a-}+data DocMarkup id a = Markup+ { markupEmpty :: a+ , markupString :: String -> a+ , markupParagraph :: a -> a+ , markupAppend :: a -> a -> a+ , markupIdentifier :: [id] -> a+ , markupModule :: String -> a+ , markupEmphasis :: a -> a+ , markupMonospaced :: a -> a+ , markupUnorderedList :: [a] -> a+ , markupOrderedList :: [a] -> a+ , markupDefList :: [(a,a)] -> a+ , markupCodeBlock :: a -> a+ , markupURL :: String -> a+ , markupAName :: String -> a+ , markupPic :: String -> a+ , markupExample :: [Example] -> a+ } -data HaddockModInfo name = HaddockModInfo {- hmi_description :: Maybe (Doc name),- hmi_portability :: Maybe String,- hmi_stability :: Maybe String,- hmi_maintainer :: Maybe String-}+data HaddockModInfo name = HaddockModInfo+ { hmi_description :: Maybe (Doc name)+ , hmi_portability :: Maybe String+ , hmi_stability :: Maybe String+ , hmi_maintainer :: Maybe String+ } emptyHaddockModInfo :: HaddockModInfo a-emptyHaddockModInfo = HaddockModInfo {- hmi_description = Nothing,- hmi_portability = Nothing,- hmi_stability = Nothing,- hmi_maintainer = Nothing-}+emptyHaddockModInfo = HaddockModInfo+ { hmi_description = Nothing+ , hmi_portability = Nothing+ , hmi_stability = Nothing+ , hmi_maintainer = Nothing+ } -----------------------------------------------------------------------------@@ -344,14 +351,23 @@ {-! for DocOption derive: Binary !-} -- | Source-level options for controlling the documentation. data DocOption- = OptHide -- ^ This module should not appear in the docs+ = OptHide -- ^ This module should not appear in the docs. | OptPrune- | OptIgnoreExports -- ^ Pretend everything is exported- | OptNotHome -- ^ Not the best place to get docs for things- -- exported by this module.+ | OptIgnoreExports -- ^ Pretend everything is exported.+ | OptNotHome -- ^ Not the best place to get docs for things+ -- exported by this module. deriving (Eq, Show) +-- | Option controlling how to qualify names+data Qualification+ = NoQual -- ^ Never qualify any names.+ | FullQual -- ^ Qualify all names fully.+ | LocalQual (Maybe Module) -- ^ Qualify all imported names fully.+ | RelativeQual (Maybe Module) -- ^ Like local, but strip module prefix.+ -- from modules in the same hierarchy.++ ----------------------------------------------------------------------------- -- * Error handling -----------------------------------------------------------------------------@@ -383,7 +399,7 @@ -- Exceptions --- | Haddock's own exception type+-- | Haddock's own exception type. data HaddockException = HaddockException String deriving Typeable
src/Haddock/Utils.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Utils@@ -74,7 +73,7 @@ import System.Exit ( exitWith, ExitCode(..) ) import System.IO ( hPutStr, stderr ) import System.IO.Unsafe ( unsafePerformIO )-import System.FilePath+import qualified System.FilePath.Posix as HtmlPath import Distribution.Verbosity import Distribution.ReadE @@ -179,7 +178,7 @@ moduleHtmlFile mdl = case Map.lookup mdl html_xrefs of Nothing -> mdl' ++ ".html"- Just fp0 -> joinPath [fp0, mdl' ++ ".html"]+ Just fp0 -> HtmlPath.joinPath [fp0, mdl' ++ ".html"] where mdl' = map (\c -> if c == '.' then '-' else c) (moduleNameString (moduleName mdl))@@ -204,10 +203,10 @@ synopsisFrameName = "synopsis" -subIndexHtmlFile :: Char -> String-subIndexHtmlFile a = "doc-index-" ++ b ++ ".html"- where b | isAlpha a = [a]- | otherwise = show (ord a)+subIndexHtmlFile :: String -> String+subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html"+ where b | all isAlpha ls = ls+ | otherwise = concatMap (show . ord) ls -------------------------------------------------------------------------------@@ -245,7 +244,7 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r where escape p c | p c = [c]- | otherwise = '-' : (show (ord c)) ++ "-"+ | otherwise = '-' : show (ord c) ++ "-" isLegal ':' = True isLegal '_' = True isLegal '.' = True
src/Main.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wwarn #-}-{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Main@@ -30,7 +30,7 @@ import Haddock.InterfaceFile import Haddock.Options import Haddock.Utils-import Haddock.GhcUtils+import Haddock.GhcUtils hiding (pretty) import Control.Monad import Control.Exception@@ -78,11 +78,18 @@ (inner `onException` hFlush stdout) `catches` [ Handler (\(code :: ExitCode) -> exitWith code)- , Handler (\(StackOverflow) -> do- putStrLn "stack overflow: use -g +RTS -K<size> to increase it"- exitFailure)++ , Handler (\(ex :: AsyncException) ->+ case ex of+ StackOverflow -> do+ putStrLn "stack overflow: use -g +RTS -K<size> to increase it"+ exitFailure+ _ -> do+ putStrLn ("haddock: " ++ show ex)+ exitFailure)+ , Handler (\(ex :: SomeException) -> do- putStrLn ("haddock: internal Haddock or GHC error: " ++ show ex)+ putStrLn ("haddock: internal error: " ++ show ex) exitFailure) ] @@ -103,9 +110,6 @@ hFlush stdout case e of PhaseFailed _ code -> exitWith code-#if ! MIN_VERSION_ghc(6,13,0)- Interrupted -> exitFailure-#endif _ -> do print (e :: GhcException) exitFailure@@ -124,27 +128,26 @@ (flags, files) <- parseHaddockOpts args shortcutFlags flags - if not (null files)- then do- (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files+ if not (null files) then do+ (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files - -- Dump an "interface file" (.haddock file), if requested.- case optDumpInterfaceFile flags of- Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks- Nothing -> return ()+ -- Dump an "interface file" (.haddock file), if requested.+ case optDumpInterfaceFile flags of+ Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks+ Nothing -> return () - -- Render the interfaces.- renderStep flags packages ifaces+ -- Render the interfaces.+ renderStep flags packages ifaces - else do- when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $- throwE "No input file(s)."+ else do+ when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $+ throwE "No input file(s)." - -- Get packages supplied with --read-interface.- packages <- readInterfaceFiles freshNameCache (readIfaceArgs flags)+ -- Get packages supplied with --read-interface.+ packages <- readInterfaceFiles freshNameCache (readIfaceArgs flags) - -- Render even though there are no input files (usually contents/index).- renderStep flags packages []+ -- Render even though there are no input files (usually contents/index).+ renderStep flags packages [] readPackagesAndProcessModules :: [Flag] -> [String]@@ -187,11 +190,13 @@ let title = fromMaybe "" (optTitle flags) unicode = Flag_UseUnicode `elem` flags+ pretty = Flag_PrettyHtml `elem` flags opt_wiki_urls = wikiUrls flags opt_contents_url = optContentsUrl flags opt_index_url = optIndexUrl flags odir = outputDir flags opt_latex_style = optLaTeXStyle flags+ opt_qualification = qualification flags visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] @@ -210,25 +215,26 @@ libDir <- getHaddockLibDir flags prologue <- getPrologue flags- themes <- getThemes libDir flags >>= either bye return+ themes <- getThemes libDir flags >>= either bye return when (Flag_GenIndex `elem` flags) $ do ppHtmlIndex odir title pkgStr themes opt_contents_url sourceUrls' opt_wiki_urls- allVisibleIfaces+ allVisibleIfaces pretty copyHtmlBits odir libDir themes when (Flag_GenContents `elem` flags) $ do ppHtmlContents odir title pkgStr themes opt_index_url sourceUrls' opt_wiki_urls- allVisibleIfaces True prologue+ allVisibleIfaces True prologue pretty copyHtmlBits odir libDir themes when (Flag_Html `elem` flags) $ do ppHtml title pkgStr visibleIfaces odir prologue themes sourceUrls' opt_wiki_urls- opt_contents_url opt_index_url unicode+ opt_contents_url opt_index_url unicode opt_qualification+ pretty copyHtmlBits odir libDir themes when (Flag_Hoogle `elem` flags) $ do@@ -239,6 +245,7 @@ ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style libDir + ------------------------------------------------------------------------------- -- * Reading and dumping interface files -------------------------------------------------------------------------------@@ -386,12 +393,7 @@ [] -> return Nothing [filename] -> do str <- readFile filename-#if ! MIN_VERSION_ghc(6,13,0)- let f = id-#else- let f = flattenExtensionFlags-#endif- case parseParas (tokenise (f defaultDynFlags) str+ case parseParas (tokenise defaultDynFlags str (1,0) {- TODO: real position -}) of Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename Just doc -> return (Just doc)@@ -402,24 +404,25 @@ getInTreeLibDir :: IO String getInTreeLibDir =- do m <- getExecDir- case m of- Nothing -> error "No GhcLibDir found"+ do m <- getExecDir+ case m of+ Nothing -> error "No GhcLibDir found" #ifdef NEW_GHC_LAYOUT- Just d -> return (d </> ".." </> "lib")+ Just d -> return (d </> ".." </> "lib") #else- Just d -> return (d </> "..")+ Just d -> return (d </> "..") #endif getExecDir :: IO (Maybe String) #if defined(mingw32_HOST_OS) getExecDir = allocaArray len $ \buf -> do- ret <- getModuleFileName nullPtr buf len- if ret == 0- then return Nothing- else do s <- peekCString buf- return (Just (dropFileName s))+ ret <- getModuleFileName nullPtr buf len+ if ret == 0 then+ return Nothing+ else do+ s <- peekCString buf+ return (Just (dropFileName s)) where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.