haddock-api 2.16.1 → 2.17.2
raw patch · 41 files changed
+3076/−874 lines, 41 filesdep +QuickCheckdep +ghc-bootdep +hspecdep ~Cabaldep ~basedep ~ghcnew-uploader
Dependencies added: QuickCheck, ghc-boot, hspec, transformers
Dependency ranges changed: Cabal, base, ghc, ghc-paths, haddock-library
Files
- haddock-api.cabal +36/−4
- resources/html/Classic.theme/xhaddock.css +4/−0
- resources/html/Ocean.std-theme/ocean.css +37/−27
- resources/html/frames.html +1/−1
- resources/html/haddock-util.js +12/−12
- resources/html/highlight.js +27/−0
- resources/html/solarized.css +55/−0
- src/Haddock.hs +82/−22
- src/Haddock/Backends/HaddockDB.hs +9/−9
- src/Haddock/Backends/Hoogle.hs +74/−39
- src/Haddock/Backends/Hyperlinker.hs +64/−0
- src/Haddock/Backends/Hyperlinker/Ast.hs +185/−0
- src/Haddock/Backends/Hyperlinker/Parser.hs +204/−0
- src/Haddock/Backends/Hyperlinker/Renderer.hs +189/−0
- src/Haddock/Backends/Hyperlinker/Types.hs +85/−0
- src/Haddock/Backends/Hyperlinker/Utils.hs +68/−0
- src/Haddock/Backends/LaTeX.hs +150/−105
- src/Haddock/Backends/Xhtml.hs +45/−31
- src/Haddock/Backends/Xhtml/Decl.hs +331/−199
- src/Haddock/Backends/Xhtml/DocMarkup.hs +6/−2
- src/Haddock/Backends/Xhtml/Layout.hs +59/−16
- src/Haddock/Backends/Xhtml/Names.hs +13/−8
- src/Haddock/Backends/Xhtml/Types.hs +1/−1
- src/Haddock/Backends/Xhtml/Utils.hs +25/−8
- src/Haddock/Convert.hs +195/−121
- src/Haddock/GhcUtils.hs +23/−44
- src/Haddock/Interface.hs +2/−2
- src/Haddock/Interface/AttachInstances.hs +32/−26
- src/Haddock/Interface/Create.hs +79/−60
- src/Haddock/Interface/LexParseRn.hs +6/−3
- src/Haddock/Interface/Rename.hs +166/−95
- src/Haddock/Interface/Specialize.hs +406/−0
- src/Haddock/InterfaceFile.hs +26/−9
- src/Haddock/ModuleTree.hs +3/−3
- src/Haddock/Options.hs +16/−0
- src/Haddock/Syb.hs +55/−0
- src/Haddock/Types.hs +144/−20
- src/Haddock/Utils.hs +61/−6
- src/Haddock/Version.hs +1/−1
- test/Haddock/Backends/Hyperlinker/ParserSpec.hs +98/−0
- test/Spec.hs +1/−0
haddock-api.cabal view
@@ -1,5 +1,5 @@ name: haddock-api-version: 2.16.1+version: 2.17.2 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries@@ -18,8 +18,10 @@ data-dir: resources data-files:+ html/solarized.css html/frames.html html/haddock-util.js+ html/highlight.js html/Classic.theme/haskell_icon.gif html/Classic.theme/minus.gif html/Classic.theme/plus.gif@@ -36,19 +38,21 @@ Haskell2010 build-depends:- base >= 4.3 && < 4.9+ base >= 4.3 && < 4.10 , bytestring , filepath , directory , containers+ , transformers , deepseq , array , xhtml >= 3000.2 && < 3000.3 , Cabal >= 1.10- , ghc >= 7.10 && < 7.12+ , ghc-boot+ , ghc >= 8.0 && < 8.2 , ghc-paths- , haddock-library == 1.2.*+ , haddock-library == 1.4.* hs-source-dirs: src@@ -66,6 +70,7 @@ Haddock.Interface.AttachInstances Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader+ Haddock.Interface.Specialize Haddock.Parser Haddock.Utils Haddock.Backends.Xhtml@@ -79,6 +84,12 @@ Haddock.Backends.LaTeX Haddock.Backends.HaddockDB Haddock.Backends.Hoogle+ Haddock.Backends.Hyperlinker+ Haddock.Backends.Hyperlinker.Ast+ Haddock.Backends.Hyperlinker.Parser+ Haddock.Backends.Hyperlinker.Renderer+ Haddock.Backends.Hyperlinker.Types+ Haddock.Backends.Hyperlinker.Utils Haddock.ModuleTree Haddock.Types Haddock.Doc@@ -86,8 +97,29 @@ Haddock.InterfaceFile Haddock.Options Haddock.GhcUtils+ Haddock.Syb Haddock.Convert Paths_haddock_api++test-suite spec+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ main-is: Spec.hs+ ghc-options: -Wall++ hs-source-dirs:+ test+ , src++ other-modules:+ Haddock.Backends.Hyperlinker.ParserSpec++ build-depends:+ base+ , containers+ , ghc+ , hspec+ , QuickCheck == 2.* source-repository head type: git
resources/html/Classic.theme/xhaddock.css view
@@ -116,6 +116,10 @@ cursor: pointer; } +@media print {+ #footer { display: none; }+}+ #package-header { color: #ffffff; padding: 5px 5px 5px 31px;
resources/html/Ocean.std-theme/ocean.css view
@@ -41,6 +41,9 @@ a[href]:visited { color: rgb(171,105,84); } a[href]:hover { text-decoration:underline; } +a[href].def:link, a[href].def:visited { color: black; }+a[href].def:hover { color: rgb(78, 98, 114); }+ /* @end */ /* @group Fonts & Sizes */@@ -143,16 +146,24 @@ background-image: url(plus.gif); background-repeat: no-repeat; }-p.caption.collapser,-p.caption.expander {- background-position: 0 0.4em;-} .collapser, .expander { padding-left: 14px; margin-left: -14px; cursor: pointer; }+p.caption.collapser,+p.caption.expander {+ background-position: 0 0.4em;+} +.instance.collapser, .instance.expander {+ margin-left: 0px;+ background-position: left center;+ min-width: 9px;+ min-height: 9px;+}++ pre { padding: 0.25em; margin: 0.8em 0;@@ -172,6 +183,9 @@ .keyword { font-weight: normal; } .def { font-weight: bold; } +@media print {+ #footer { display: none; }+} /* @end */ @@ -370,21 +384,16 @@ #interface h5 + div.top { margin-top: 1em; }-#interface p.src .link {+#interface .src .selflink,+#interface .src .link { float: right; color: #919191;- border-left: 1px solid #919191; background: #f0f0f0; padding: 0 0.5em 0.2em;- margin: 0 -0.5em 0 0.5em;+ margin: 0 -0.5em 0 0; }--#interface td.src .link {- float: right;- color: #919191;+#interface .src .selflink { border-left: 1px solid #919191;- background: #f0f0f0;- padding: 0 0.5em 0.2em; margin: 0 -0.5em 0 0.5em; } @@ -424,30 +433,31 @@ visibility: hidden; } -.subs dl {+.subs ul {+ list-style: none;+ display: table; margin: 0; } -.subs dt {- float: left;- clear: left;- display: block;+.subs ul li {+ display: table-row;+}++.subs ul li dfn {+ display: table-cell;+ font-style: normal;+ font-weight: bold; margin: 1px 0;+ white-space: nowrap; } -.subs dd {- float: right;- width: 90%;- display: block;+.subs ul li > .doc {+ display: table-cell; padding-left: 0.5em; margin-bottom: 0.5em; } -.subs dd.empty {- display: none;-}--.subs dd p {+.subs ul li > .doc p { margin: 0; }
resources/html/frames.html view
@@ -1,4 +1,4 @@-<!DOCTYPE html +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd"> <html xmlns="http://www.w3.org/1999/xhtml">
resources/html/haddock-util.js view
@@ -131,11 +131,11 @@ var text = document.getElementById("searchbox").value.toLowerCase(); if (text == last_search && !full) return; last_search = text;- + var table = document.getElementById("indexlist"); var status = document.getElementById("searchmsg"); var children = table.firstChild.childNodes;- + // first figure out the first node with the prefix var first = bisect(-1); var last = (first == -1 ? -1 : bisect(1));@@ -166,7 +166,7 @@ status.innerHTML = ""; } - + function setclass(first, last, status) { for (var i = first; i <= last; i++)@@ -174,8 +174,8 @@ children[i].className = status; } }- - ++ // do a binary search, treating 0 as ... // return either -1 (no 0's found) or location of most far match function bisect(dir)@@ -201,9 +201,9 @@ if (checkitem(i) == 0) return i; } return -1;- } - - + }++ // from an index, decide what the result is // 0 = match, -1 is lower, 1 is higher function checkitem(i)@@ -212,8 +212,8 @@ if (s == text) return 0; else return (s > text ? -1 : 1); }- - ++ // from an index, get its string // this abstracts over alternates function getitem(i)@@ -229,7 +229,7 @@ } function setSynopsis(filename) {- if (parent.window.synopsis) {+ if (parent.window.synopsis && parent.window.synopsis.location) { if (parent.window.synopsis.location.replace) { // In Firefox this avoids adding the change to the history. parent.window.synopsis.location.replace(filename);@@ -250,7 +250,7 @@ function adjustForFrames() { var bodyCls;- + if (parent.location.href == window.location.href) { // not in frames, so add Frames button addMenuItem("<a href='#' onclick='reframe();return true;'>Frames</a>");
+ resources/html/highlight.js view
@@ -0,0 +1,27 @@++var highlight = function (on) {+ return function () {+ var links = document.getElementsByTagName('a');+ for (var i = 0; i < links.length; i++) {+ var that = links[i];++ if (this.href != that.href) {+ continue;+ }++ if (on) {+ that.classList.add("hover-highlight");+ } else {+ that.classList.remove("hover-highlight");+ }+ }+ }+};++window.onload = function () {+ var links = document.getElementsByTagName('a');+ for (var i = 0; i < links.length; i++) {+ links[i].onmouseover = highlight(true);+ links[i].onmouseout = highlight(false);+ }+};
+ resources/html/solarized.css view
@@ -0,0 +1,55 @@+body {+ background-color: #fdf6e3;+}++.hs-identifier {+ color: #073642;+}++.hs-identifier.hs-var {+}++.hs-identifier.hs-type {+ color: #5f5faf;+}++.hs-keyword {+ color: #af005f;+}++.hs-string, .hs-char {+ color: #cb4b16;+}++.hs-number {+ color: #268bd2;+}++.hs-operator {+ color: #d33682;+}++.hs-glyph, .hs-special {+ color: #dc322f;+}++.hs-comment {+ color: #8a8a8a;+}++.hs-pragma {+ color: #2aa198;+}++.hs-cpp {+ color: #859900;+}++a:link, a:visited {+ text-decoration: none;+ border-bottom: 1px solid #eee8d5;+}++a:hover, a.hover-highlight {+ background-color: #eee8d5;+}
src/Haddock.hs view
@@ -30,6 +30,7 @@ import Haddock.Backends.Xhtml.Themes (getThemes) import Haddock.Backends.LaTeX import Haddock.Backends.Hoogle+import Haddock.Backends.Hyperlinker import Haddock.Interface import Haddock.Parser import Haddock.Types@@ -45,6 +46,7 @@ import Control.Exception import Data.Maybe import Data.IORef+import Data.Map (Map) import qualified Data.Map as Map import System.IO import System.Exit@@ -119,11 +121,8 @@ -- error messages propagated as exceptions handleGhcException $ \e -> do hFlush stdout- case e of- PhaseFailed _ code -> exitWith code- _ -> do- print (e :: GhcException)- exitFailure+ print (e :: GhcException)+ exitFailure -------------------------------------------------------------------------------@@ -158,6 +157,7 @@ _ -> return flags unless (Flag_NoWarnings `elem` flags) $ do+ hypSrcWarnings flags forM_ (warnings args) $ \warning -> do hPutStrLn stderr warning @@ -226,13 +226,16 @@ let ifaceFiles = map snd pkgs installedIfaces = concatMap ifInstalledIfaces ifaceFiles- srcMap = Map.fromList [ (ifPackageKey if_, x) | ((_, Just x), if_) <- pkgs ]- render dflags flags qual interfaces installedIfaces srcMap+ extSrcMap = Map.fromList $ do+ ((_, Just path), ifile) <- pkgs+ iface <- ifInstalledIfaces ifile+ return (instMod iface, path)+ render dflags flags qual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags.-render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()-render dflags flags qual ifaces installedIfaces srcMap = do+render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO ()+render dflags flags qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags)@@ -243,6 +246,11 @@ opt_index_url = optIndexUrl flags odir = outputDir flags opt_latex_style = optLaTeXStyle flags+ opt_source_css = optSourceCssFile flags+ opt_mathjax = optMathjax flags+ dflags'+ | unicode = gopt_set dflags Opt_PrintUnicodeSyntax+ | otherwise = dflags visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] @@ -251,37 +259,57 @@ allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = ifaceMod (head ifaces)- pkgKey = modulePackageKey pkgMod- pkgStr = Just (packageKeyString pkgKey)+ pkgKey = moduleUnitId pkgMod+ pkgStr = Just (unitIdString pkgKey) pkgNameVer = modulePackageInfo dflags flags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags- srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity++ srcModule'+ | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat+ | otherwise = srcModule++ srcMap = mkSrcMap $ Map.union+ (Map.map SrcExternal extSrcMap)+ (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])++ pkgSrcMap = Map.mapKeys moduleUnitId extSrcMap+ pkgSrcMap'+ | Flag_HyperlinkedSource `elem` flags =+ Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap+ | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl pkgSrcMap+ | otherwise = pkgSrcMap+ -- TODO: Get these from the interface files as with srcMap- srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity- sourceUrls' = (srcBase, srcModule, srcMap', srcLMap')+ pkgSrcLMap'+ | Flag_HyperlinkedSource `elem` flags =+ Map.singleton pkgKey hypSrcModuleLineUrlFormat+ | Just path <- srcLEntity = Map.singleton pkgKey path+ | otherwise = Map.empty + sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap')+ libDir <- getHaddockLibDir flags- prologue <- getPrologue dflags flags+ prologue <- getPrologue dflags' flags 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+ themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls allVisibleIfaces pretty copyHtmlBits odir libDir themes when (Flag_GenContents `elem` flags) $ do- ppHtmlContents dflags odir title pkgStr- themes opt_index_url sourceUrls' opt_wiki_urls+ ppHtmlContents dflags' odir title pkgStr+ themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty (makeContentsQual qual) copyHtmlBits odir libDir themes when (Flag_Html `elem` flags) $ do- ppHtml dflags title pkgStr visibleIfaces odir+ ppHtml dflags' title pkgStr visibleIfaces odir prologue- themes sourceUrls' opt_wiki_urls+ themes opt_mathjax sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode qual pretty copyHtmlBits odir libDir themes@@ -301,13 +329,16 @@ Just (PackageName pkgNameFS, pkgVer) -> let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title | otherwise = unpackFS pkgNameFS- in ppHoogle dflags pkgNameStr pkgVer title (fmap _doc prologue)+ in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue) visibleIfaces odir when (Flag_LaTeX `elem` flags) $ do ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir + when (Flag_HyperlinkedSource `elem` flags) $ do+ ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces+ -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because -- package name and versions can no longer reliably be extracted in@@ -326,7 +357,7 @@ cmdline <|> pkgDb where cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags- pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (modulePackageKey modu)+ pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (moduleUnitId modu) -------------------------------------------------------------------------------@@ -474,6 +505,35 @@ byeVersion = bye $ "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n" ++ "Ported to use the GHC API by David Waern 2006-2008\n"+++-- | Generate some warnings about potential misuse of @--hyperlinked-source@.+hypSrcWarnings :: [Flag] -> IO ()+hypSrcWarnings flags = do++ when (hypSrc && any isSourceUrlFlag flags) $+ hPutStrLn stderr $ concat+ [ "Warning: "+ , "--source-* options are ignored when "+ , "--hyperlinked-source is enabled."+ ]++ when (not hypSrc && any isSourceCssFlag flags) $+ hPutStrLn stderr $ concat+ [ "Warning: "+ , "source CSS file is specified but "+ , "--hyperlinked-source is disabled."+ ]++ where+ hypSrc = Flag_HyperlinkedSource `elem` flags+ isSourceUrlFlag (Flag_SourceBaseURL _) = True+ isSourceUrlFlag (Flag_SourceModuleURL _) = True+ isSourceUrlFlag (Flag_SourceEntityURL _) = True+ isSourceUrlFlag (Flag_SourceLEntityURL _) = True+ isSourceUrlFlag _ = False+ isSourceCssFlag (Flag_SourceCss _) = True+ isSourceCssFlag _ = False updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
src/Haddock/Backends/HaddockDB.hs view
@@ -40,7 +40,7 @@ where do_mod (Module mod, iface) = text "<sect1 id=\"sec-" <> text mod <> text "\">"- $$ text "<title><literal>" + $$ text "<title><literal>" <> text mod <> text "</literal></title>" $$ text "<indexterm><primary><literal>"@@ -50,10 +50,10 @@ $$ vcat (map (do_export mod) (eltsFM (iface_decls iface))) $$ text "</variablelist>" $$ text "</sect1>"- + do_export mod decl | (nm:_) <- declBinders decl = text "<varlistentry id=" <> ppLinkId mod nm <> char '>'- $$ text "<term><literal>" + $$ text "<term><literal>" <> do_decl decl <> text "</literal></term>" $$ text "<listitem>"@@ -63,11 +63,11 @@ $$ text "</varlistentry>" do_export _ _ = empty - do_decl (HsTypeSig _ [nm] ty _) + do_decl (HsTypeSig _ [nm] ty _) = ppHsName nm <> text " :: " <> ppHsType ty do_decl (HsTypeDecl _ nm args ty _) = hsep ([text "type", ppHsName nm ]- ++ map ppHsName args + ++ map ppHsName args ++ [equals, ppHsType ty]) do_decl (HsNewTypeDecl loc ctx nm args con drv _) = hsep ([text "data", ppHsName nm] -- data, not newtype@@ -87,7 +87,7 @@ ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) = ppHsName name <> (braces . hsep . punctuate comma . map ppField $ fieldList)-ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = +ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = hsep (ppHsName name : map ppHsBangType typeList) ppField (HsFieldDecl ns ty doc)@@ -100,7 +100,7 @@ ppHsContext :: HsContext -> Doc ppHsContext [] = empty-ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> +ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> hsep (map ppHsAType b)) context) ppHsType :: HsType -> Doc@@ -109,7 +109,7 @@ ppHsType (HsForAllType (Just tvs) [] htype) = hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype]) ppHsType (HsForAllType (Just tvs) context htype) =- hsep (text "forall" : map ppHsName tvs ++ text "." : + hsep (text "forall" : map ppHsName tvs ++ text "." : ppHsContext context : text "=>" : [ppHsType htype]) ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b] ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t]@@ -135,7 +135,7 @@ ppHsQName n@(Qual (Module mod) str) | n == unit_con_name = ppHsName str | isSpecial str = ppHsName str- | otherwise + | otherwise = text "<link linkend=" <> ppLinkId mod str <> char '>' <> ppHsName str <> text "</link>"
src/Haddock/Backends/Hoogle.hs view
@@ -20,13 +20,17 @@ import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out)+ import GHC import Outputable+import NameSet import Data.Char import Data.List import Data.Maybe import Data.Version++import System.Directory import System.FilePath import System.IO @@ -45,6 +49,7 @@ ["@version " ++ showVersion version | not (null (versionBranch version)) ] ++ concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i]+ createDirectoryIfMissing True odir h <- openFile (odir </> filename) WriteMode hSetEncoding h utf8 hPutStr h (unlines contents)@@ -65,7 +70,8 @@ dropHsDocTy = f where g (L src x) = L src (f x)- f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e)+ f (HsForAllTy a e) = HsForAllTy a (g e)+ f (HsQualTy a e) = HsQualTy a (g e) f (HsBangTy a b) = HsBangTy a (g b) f (HsAppTy a b) = HsAppTy (g a) (g b) f (HsFunTy a b) = HsFunTy (g a) (g b)@@ -82,14 +88,6 @@ outHsType dflags = out dflags . dropHsDocTy -makeExplicit :: HsType a -> HsType a-makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d-makeExplicit x = x--makeExplicitL :: LHsType a -> LHsType a-makeExplicitL (L src x) = L src (makeExplicit x)-- dropComment :: String -> String dropComment (' ':'-':'-':' ':_) = [] dropComment (x:xs) = x : dropComment xs@@ -120,54 +118,73 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemMbDoc = (dc, _) , expItemSubDocs = subdocs+ , expItemFixities = fixities } = ppDocumentation dflags dc ++ f decl where f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = ppSynonym dflags d f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs- f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []- f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []- f (SigD sig) = ppSig dflags sig+ f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]+ f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]+ f (SigD sig) = ppSig dflags sig ++ ppFixities f _ = []++ ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String]-ppSigWithDoc dflags (TypeSig names sig _) subdocs+ppSigWithDoc dflags (TypeSig names sig) subdocs = concatMap mkDocSig names where mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n)- ++ [mkSig n]- mkSig n = operator (out dflags n) ++ " :: " ++ outHsType dflags typ+ ++ [pp_sig dflags names (hsSigWcType sig)] getDoc :: Located Name -> [Documentation Name] getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs) - typ = case unL sig of- HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d- HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d- x -> x ppSigWithDoc _ _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] ppSig dflags x = ppSigWithDoc dflags x [] +pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> String+pp_sig dflags names (L _ typ) =+ operator prettyNames ++ " :: " ++ outHsType dflags typ+ where+ prettyNames = intercalate ", " $ map (out dflags) names -- note: does not yet output documentation for class methods ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]-ppClass dflags x subdocs = out dflags x{tcdSigs=[]} :- concatMap (flip (ppSigWithDoc dflags) subdocs . addContext . unL) (tcdSigs x)+ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods where- addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs- addContext (MinimalSig src sig) = MinimalSig src sig- addContext _ = error "expected TypeSig" - f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d- f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t)+ ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl+ ppSig' = flip (ppSigWithDoc dflags) subdocs - context = nlHsTyConApp (tcdName x)- (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x)))+ add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVars decl) + ppTyFams+ | null $ tcdATs decl = ""+ | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat+ [ map ppr (tcdATs decl)+ , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)+ ] + whereWrapper elems = vcat'+ [ text "where" <+> lbrace+ , nest 4 . vcat . map (<> semi) $ elems+ , rbrace+ ]++ tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name+ tyFamEqnToSyn tfe = SynDecl+ { tcdLName = tfe_tycon tfe+ , tcdTyVars = tfe_pats tfe+ , tcdRhs = tfe_rhs tfe+ , tcdFVs = emptyNameSet+ }++ ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls]@@ -205,31 +222,42 @@ _ -> [] ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]-ppCtor dflags dat subdocs con- = concatMap (lookupCon dflags subdocs) (con_names con) ++ f (con_details con)+ppCtor dflags dat subdocs con@ConDeclH98 {}+ -- AZ:TODO get rid of the concatMap+ = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat- [(concatMap (lookupCon dflags subdocs) (cd_fld_names r)) ++- [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]+ [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) +++ [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y))+ funs = foldr1 (\x y -> reL $ HsFunTy x y) apps = foldl1 (\x y -> reL $ HsAppTy x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds)+ typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with.- name = commaSeparate dflags . map unL $ con_names con+ name = commaSeparate dflags . map unL $ getConNames con - resType = case con_res con of- ResTyH98 -> apps $ map (reL . HsTyVar) $- (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat]- ResTyGADT _ x -> x+ resType = apps $ map (reL . HsTyVar . reL) $+ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] +ppCtor dflags _dat subdocs con@ConDeclGADT {}+ = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f+ where+ f = [typeSig name (hsib_body $ con_type con)] + typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)+ name = out dflags $ map unL $ getConNames con+++ppFixity :: DynFlags -> (Name, Fixity) -> [String]+ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)]++ --------------------------------------------------------------------- -- DOCUMENTATION @@ -283,6 +311,8 @@ markupBold = box (TagInline "b"), markupMonospaced = box (TagInline "tt"), markupPic = const $ str " ",+ markupMathInline = const $ str "<math>",+ markupMathDisplay = const $ str "<math>", markupUnorderedList = box (TagL 'u'), markupOrderedList = box (TagL 'o'), markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),@@ -358,3 +388,8 @@ f '>' = ">" f '&' = "&" f x = [x]+++-- | Just like 'vcat' but uses '($+$)' instead of '($$)'.+vcat' :: [SDoc] -> SDoc+vcat' = foldr ($+$) empty
+ src/Haddock/Backends/Hyperlinker.hs view
@@ -0,0 +1,64 @@+module Haddock.Backends.Hyperlinker+ ( ppHyperlinkedSource+ , module Haddock.Backends.Hyperlinker.Types+ , module Haddock.Backends.Hyperlinker.Utils+ ) where+++import Haddock.Types+import Haddock.Backends.Hyperlinker.Renderer+import Haddock.Backends.Hyperlinker.Types+import Haddock.Backends.Hyperlinker.Utils++import Text.XHtml hiding ((</>))++import Data.Maybe+import System.Directory+import System.FilePath+++-- | Generate hyperlinked source for given interfaces.+--+-- Note that list of interfaces should also contain interfaces normally hidden+-- when generating documentation. Otherwise this could lead to dead links in+-- produced source.+ppHyperlinkedSource :: FilePath -- ^ Output directory+ -> FilePath -- ^ Resource directory+ -> Maybe FilePath -- ^ Custom CSS file path+ -> Bool -- ^ Flag indicating whether to pretty-print HTML+ -> SrcMap -- ^ Paths to sources+ -> [Interface] -- ^ Interfaces for which we create source+ -> IO ()+ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do+ createDirectoryIfMissing True srcdir+ let cssFile = fromMaybe (defaultCssFile libdir) mstyle+ copyFile cssFile $ srcdir </> srcCssFile+ copyFile (libdir </> "html" </> highlightScript) $+ srcdir </> highlightScript+ mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces+ where+ srcdir = outdir </> hypSrcDir++-- | Generate hyperlinked source for particular interface.+ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface+ -> IO ()+ppHyperlinkedModuleSource srcdir pretty srcs iface =+ case ifaceTokenizedSrc iface of+ Just tokens -> writeFile path . html . render' $ tokens+ Nothing -> return ()+ where+ render' = render (Just srcCssFile) (Just highlightScript) srcs+ html = if pretty then renderHtml else showHtml+ path = srcdir </> hypSrcModuleFile (ifaceMod iface)++-- | Name of CSS file in output directory.+srcCssFile :: FilePath+srcCssFile = "style.css"++-- | Name of highlight script in output and resource directory.+highlightScript :: FilePath+highlightScript = "highlight.js"++-- | Path to default CSS file.+defaultCssFile :: FilePath -> FilePath+defaultCssFile libdir = libdir </> "html" </> "solarized.css"
+ src/Haddock/Backends/Hyperlinker/Ast.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+++module Haddock.Backends.Hyperlinker.Ast (enrich) where+++import Haddock.Syb+import Haddock.Backends.Hyperlinker.Types++import qualified GHC++import Control.Applicative+import Data.Data+import Data.Maybe+++-- | Add more detailed information to token stream using GHC API.+enrich :: GHC.RenamedSource -> [Token] -> [RichToken]+enrich src =+ map $ \token -> RichToken+ { rtkToken = token+ , rtkDetails = enrichToken token detailsMap+ }+ where+ detailsMap = concatMap ($ src)+ [ variables+ , types+ , decls+ , binds+ , imports+ ]++-- | A map containing association between source locations and "details" of+-- this location.+--+-- For the time being, it is just a list of pairs. However, looking up things+-- in such structure has linear complexity. We cannot use any hashmap-like+-- stuff because source locations are not ordered. In the future, this should+-- be replaced with interval tree data structure.+type DetailsMap = [(GHC.SrcSpan, TokenDetails)]++lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails+lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)++enrichToken :: Token -> DetailsMap -> Maybe TokenDetails+enrichToken (Token typ _ spn) dm+ | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm+enrichToken _ _ = Nothing++-- | Obtain details map for variables ("normally" used identifiers).+variables :: GHC.RenamedSource -> DetailsMap+variables =+ everything (<|>) (var `combine` rec)+ where+ var term = case cast term of+ (Just (GHC.L sspan (GHC.HsVar name))) ->+ pure (sspan, RtkVar (GHC.unLoc name))+ (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) ->+ pure (sspan, RtkVar name)+ _ -> empty+ rec term = case cast term of+ Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.Name) _) ->+ pure (sspan, RtkVar name)+ _ -> empty++-- | Obtain details map for types.+types :: GHC.RenamedSource -> DetailsMap+types =+ everything (<|>) ty+ where+ ty term = case cast term of+ (Just (GHC.L sspan (GHC.HsTyVar name))) ->+ pure (sspan, RtkType (GHC.unLoc name))+ _ -> empty++-- | Obtain details map for identifier bindings.+--+-- That includes both identifiers bound by pattern matching or declared using+-- ordinary assignment (in top-level declarations, let-expressions and where+-- clauses).+binds :: GHC.RenamedSource -> DetailsMap+binds =+ everything (<|>) (fun `combine` pat `combine` tvar)+ where+ fun term = case cast term of+ (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) ->+ pure (sspan, RtkBind name)+ _ -> empty+ pat term = case cast term of+ (Just (GHC.L sspan (GHC.VarPat name))) ->+ pure (sspan, RtkBind (GHC.unLoc name))+ (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->+ [(sspan, RtkVar name)] ++ everything (<|>) rec recs+ (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->+ pure (sspan, RtkBind name)+ _ -> empty+ rec term = case cast term of+ (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) ->+ pure (sspan, RtkVar name)+ _ -> empty+ tvar term = case cast term of+ (Just (GHC.L sspan (GHC.UserTyVar name))) ->+ pure (sspan, RtkBind (GHC.unLoc name))+ (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->+ pure (sspan, RtkBind name)+ _ -> empty++-- | Obtain details map for top-level declarations.+decls :: GHC.RenamedSource -> DetailsMap+decls (group, _, _, _) = concatMap ($ group)+ [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds+ , everything (<|>) fun . GHC.hs_valds+ , everything (<|>) (con `combine` ins)+ ]+ where+ typ (GHC.L _ t) = case t of+ GHC.DataDecl { tcdLName = name } -> pure . decl $ name+ GHC.SynDecl name _ _ _ -> pure . decl $ name+ GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam+ GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs+ fun term = case cast term of+ (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name))+ | GHC.isExternalName name -> pure (sspan, RtkDecl name)+ _ -> empty+ con term = case cast term of+ (Just cdcl) ->+ map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl+ Nothing -> empty+ ins term = case cast term of+ (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst+ (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) ->+ pure . tyref $ GHC.tfe_tycon eqn+ _ -> empty+ fld term = case cast term of+ Just (field :: GHC.ConDeclField GHC.Name)+ -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field+ Nothing -> empty+ sig (GHC.L _ (GHC.TypeSig names _)) = map decl names+ sig _ = []+ decl (GHC.L sspan name) = (sspan, RtkDecl name)+ tyref (GHC.L sspan name) = (sspan, RtkType name)++-- | Obtain details map for import declarations.+--+-- This map also includes type and variable details for items in export and+-- import lists.+imports :: GHC.RenamedSource -> DetailsMap+imports src@(_, imps, _, _) =+ everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps+ where+ ie term = case cast term of+ (Just (GHC.IEVar v)) -> pure $ var v+ (Just (GHC.IEThingAbs t)) -> pure $ typ t+ (Just (GHC.IEThingAll t)) -> pure $ typ t+ (Just (GHC.IEThingWith t _ vs _fls)) ->+ [typ t] ++ map var vs+ _ -> empty+ typ (GHC.L sspan name) = (sspan, RtkType name)+ var (GHC.L sspan name) = (sspan, RtkVar name)+ imp idecl | not . GHC.ideclImplicit $ idecl =+ let (GHC.L sspan name) = GHC.ideclName idecl+ in Just (sspan, RtkModule name)+ imp _ = Nothing++-- | Check whether token stream span matches GHC source span.+--+-- Currently, it is implemented as checking whether "our" span is contained+-- in GHC span. The reason for that is because GHC span are generally wider+-- and may spread across couple tokens. For example, @(>>=)@ consists of three+-- tokens: @(@, @>>=@, @)@, but GHC source span associated with @>>=@ variable+-- contains @(@ and @)@. Similarly, qualified identifiers like @Foo.Bar.quux@+-- are tokenized as @Foo@, @.@, @Bar@, @.@, @quux@ but GHC source span+-- associated with @quux@ contains all five elements.+matches :: Span -> GHC.SrcSpan -> Bool+matches tspan (GHC.RealSrcSpan aspan)+ | saspan <= stspan && etspan <= easpan = True+ where+ stspan = (posRow . spStart $ tspan, posCol . spStart $ tspan)+ etspan = (posRow . spEnd $ tspan, posCol . spEnd $ tspan)+ saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan)+ easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan)+matches _ _ = False
+ src/Haddock/Backends/Hyperlinker/Parser.hs view
@@ -0,0 +1,204 @@+module Haddock.Backends.Hyperlinker.Parser (parse) where+++import Data.Char+import Data.List+import Data.Maybe++import Haddock.Backends.Hyperlinker.Types+++-- | Turn source code string into a stream of more descriptive tokens.+--+-- Result should retain original file layout (including comments, whitespace,+-- etc.), i.e. the following "law" should hold:+--+-- @concat . map 'tkValue' . 'parse' = id@+parse :: String -> [Token]+parse = tokenize . tag . chunk++-- | Split raw source string to more meaningful chunks.+--+-- This is the initial stage of tokenization process. Each chunk is either+-- a comment (including comment delimiters), a whitespace string, preprocessor+-- macro (and all its content until the end of a line) or valid Haskell lexeme.+chunk :: String -> [String]+chunk [] = []+chunk str@(c:_)+ | isSpace c =+ let (space, mcpp, rest) = spanSpaceOrCpp str+ in [space] ++ maybeToList mcpp ++ chunk rest+chunk str+ | "--" `isPrefixOf` str = chunk' $ spanToNewline str+ | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str+ | otherwise = case lex str of+ (tok:_) -> chunk' tok+ [] -> [str]+ where+ chunk' (c, rest) = c:(chunk rest)++-- | Split input to "first line" string and the rest of it.+--+-- Ideally, this should be done simply with @'break' (== '\n')@. However,+-- Haskell also allows line-unbreaking (or whatever it is called) so things+-- are not as simple and this function deals with that.+spanToNewline :: String -> (String, String)+spanToNewline [] = ([], [])+spanToNewline ('\\':'\n':str) =+ let (str', rest) = spanToNewline str+ in ('\\':'\n':str', rest)+spanToNewline str@('\n':_) = ("", str)+spanToNewline (c:str) =+ let (str', rest) = spanToNewline str+ in (c:str', rest)++-- | Split input to whitespace string, (optional) preprocessor directive and+-- the rest of it.+--+-- Again, using something like @'span' 'isSpace'@ would be nice to chunk input+-- to whitespace. The problem is with /#/ symbol - if it is placed at the very+-- beginning of a line, it should be recognized as preprocessor macro. In any+-- other case, it is ordinary Haskell symbol and can be used to declare+-- operators. Hence, while dealing with whitespace we also check whether there+-- happens to be /#/ symbol just after a newline character - if that is the+-- case, we begin treating the whole line as preprocessor macro.+spanSpaceOrCpp :: String -> (String, Maybe String, String)+spanSpaceOrCpp ('\n':'#':str) =+ let (str', rest) = spanToNewline str+ in ("\n", Just $ '#':str', rest)+spanSpaceOrCpp (c:str')+ | isSpace c =+ let (space, mcpp, rest) = spanSpaceOrCpp str'+ in (c:space, mcpp, rest)+spanSpaceOrCpp str = ("", Nothing, str)++-- | Split input to comment content (including delimiters) and the rest.+--+-- Again, some more logic than simple 'span' is required because of Haskell+-- comment nesting policy.+chunkComment :: Int -> String -> (String, String)+chunkComment _ [] = ("", "")+chunkComment depth ('{':'-':str) =+ let (c, rest) = chunkComment (depth + 1) str+ in ("{-" ++ c, rest)+chunkComment depth ('-':'}':str)+ | depth == 1 = ("-}", str)+ | otherwise =+ let (c, rest) = chunkComment (depth - 1) str+ in ("-}" ++ c, rest)+chunkComment depth (e:str) =+ let (c, rest) = chunkComment depth str+ in (e:c, rest)++-- | Assign source location for each chunk in given stream.+tag :: [String] -> [(Span, String)]+tag =+ reverse . snd . foldl aux (Position 1 1, [])+ where+ aux (pos, cs) str =+ let pos' = foldl move pos str+ in (pos', (Span pos pos', str):cs)+ move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 }+ move pos _ = pos { posCol = posCol pos + 1 }++-- | Turn unrecognised chunk stream to more descriptive token stream.+tokenize :: [(Span, String)] -> [Token]+tokenize =+ map aux+ where+ aux (sp, str) = Token+ { tkType = classify str+ , tkValue = str+ , tkSpan = sp+ }++-- | Classify given string as appropriate Haskell token.+--+-- This method is based on Haskell 98 Report lexical structure description:+-- https://www.haskell.org/onlinereport/lexemes.html+--+-- However, this is probably far from being perfect and most probably does not+-- handle correctly all corner cases.+classify :: String -> TokenType+classify str+ | "--" `isPrefixOf` str = TkComment+ | "{-#" `isPrefixOf` str = TkPragma+ | "{-" `isPrefixOf` str = TkComment+classify str@(c:_)+ | isSpace c = TkSpace+ | isDigit c = TkNumber+ | c `elem` special = TkSpecial+ | str `elem` glyphs = TkGlyph+ | all (`elem` symbols) str = TkOperator+ | c == '#' = TkCpp+ | c == '"' = TkString+ | c == '\'' = TkChar+classify str+ | str `elem` keywords = TkKeyword+ | isIdentifier str = TkIdentifier+ | otherwise = TkUnknown++keywords :: [String]+keywords =+ [ "as"+ , "case"+ , "class"+ , "data"+ , "default"+ , "deriving"+ , "do"+ , "else"+ , "hiding"+ , "if"+ , "import"+ , "in"+ , "infix"+ , "infixl"+ , "infixr"+ , "instance"+ , "let"+ , "module"+ , "newtype"+ , "of"+ , "qualified"+ , "then"+ , "type"+ , "where"+ , "forall"+ , "family"+ , "mdo"+ ]++glyphs :: [String]+glyphs =+ [ ".."+ , ":"+ , "::"+ , "="+ , "\\"+ , "|"+ , "<-"+ , "->"+ , "@"+ , "~"+ , "~#"+ , "=>"+ , "-"+ , "!"+ ]++special :: [Char]+special = "()[]{},;`"++-- TODO: Add support for any Unicode symbol or punctuation.+-- source: http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators+symbols :: [Char]+symbols = "!#$%&*+./<=>?@\\^|-~:"++isIdentifier :: String -> Bool+isIdentifier (s:str)+ | (isLower' s || isUpper s) && all isAlphaNum' str = True+ where+ isLower' c = isLower c || c == '_'+ isAlphaNum' c = isAlphaNum c || c == '_' || c == '\''+isIdentifier _ = False
+ src/Haddock/Backends/Hyperlinker/Renderer.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE RecordWildCards #-}+++module Haddock.Backends.Hyperlinker.Renderer (render) where+++import Haddock.Backends.Hyperlinker.Types+import Haddock.Backends.Hyperlinker.Utils++import qualified GHC+import qualified Name as GHC+import qualified Unique as GHC++import System.FilePath.Posix ((</>))++import Data.List+import Data.Maybe+import Data.Monoid+import qualified Data.Map as Map++import Text.XHtml (Html, HtmlAttr, (!))+import qualified Text.XHtml as Html+++type StyleClass = String+++render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken]+ -> Html+render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens+++data TokenGroup+ = GrpNormal Token+ | GrpRich TokenDetails [Token]+++-- | Group consecutive tokens pointing to the same element.+--+-- We want to render qualified identifiers as one entity. For example,+-- @Bar.Baz.foo@ consists of 5 tokens (@Bar@, @.@, @Baz@, @.@, @foo@) but for+-- better user experience when highlighting and clicking links, these tokens+-- should be regarded as one identifier. Therefore, before rendering we must+-- group consecutive elements pointing to the same 'GHC.Name' (note that even+-- dot token has it if it is part of qualified name).+groupTokens :: [RichToken] -> [TokenGroup]+groupTokens [] = []+groupTokens ((RichToken tok Nothing):rest) = (GrpNormal tok):(groupTokens rest)+groupTokens ((RichToken tok (Just det)):rest) =+ let (grp, rest') = span same rest+ in (GrpRich det (tok:(map rtkToken grp))):(groupTokens rest')+ where+ same (RichToken _ (Just det')) = det == det'+ same _ = False+++body :: SrcMap -> [RichToken] -> Html+body srcs tokens =+ Html.body . Html.pre $ hypsrc+ where+ hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens+++header :: Maybe FilePath -> Maybe FilePath -> Html+header mcss mjs+ | isNothing mcss && isNothing mjs = Html.noHtml+header mcss mjs =+ Html.header $ css mcss <> js mjs+ where+ css Nothing = Html.noHtml+ css (Just cssFile) = Html.thelink Html.noHtml !+ [ Html.rel "stylesheet"+ , Html.thetype "text/css"+ , Html.href cssFile+ ]+ js Nothing = Html.noHtml+ js (Just scriptFile) = Html.script Html.noHtml !+ [ Html.thetype "text/javascript"+ , Html.src scriptFile+ ]+++tokenGroup :: SrcMap -> TokenGroup -> Html+tokenGroup _ (GrpNormal tok@(Token { .. }))+ | tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue+ | otherwise = tokenSpan tok ! attrs+ where+ attrs = [ multiclass . tokenStyle $ tkType ]+tokenGroup srcs (GrpRich det tokens) =+ externalAnchor det . internalAnchor det . hyperlink srcs det $ content+ where+ content = mconcat . map (richToken det) $ tokens+++richToken :: TokenDetails -> Token -> Html+richToken det tok =+ tokenSpan tok ! [ multiclass style ]+ where+ style = (tokenStyle . tkType) tok ++ richTokenStyle det+++tokenSpan :: Token -> Html+tokenSpan = Html.thespan . Html.toHtml . tkValue+++richTokenStyle :: TokenDetails -> [StyleClass]+richTokenStyle (RtkVar _) = ["hs-var"]+richTokenStyle (RtkType _) = ["hs-type"]+richTokenStyle _ = []++tokenStyle :: TokenType -> [StyleClass]+tokenStyle TkIdentifier = ["hs-identifier"]+tokenStyle TkKeyword = ["hs-keyword"]+tokenStyle TkString = ["hs-string"]+tokenStyle TkChar = ["hs-char"]+tokenStyle TkNumber = ["hs-number"]+tokenStyle TkOperator = ["hs-operator"]+tokenStyle TkGlyph = ["hs-glyph"]+tokenStyle TkSpecial = ["hs-special"]+tokenStyle TkSpace = []+tokenStyle TkComment = ["hs-comment"]+tokenStyle TkCpp = ["hs-cpp"]+tokenStyle TkPragma = ["hs-pragma"]+tokenStyle TkUnknown = []++multiclass :: [StyleClass] -> HtmlAttr+multiclass = Html.theclass . intercalate " "++externalAnchor :: TokenDetails -> Html -> Html+externalAnchor (RtkDecl name) content =+ Html.anchor content ! [ Html.name $ externalAnchorIdent name ]+externalAnchor _ content = content++internalAnchor :: TokenDetails -> Html -> Html+internalAnchor (RtkBind name) content =+ Html.anchor content ! [ Html.name $ internalAnchorIdent name ]+internalAnchor _ content = content++externalAnchorIdent :: GHC.Name -> String+externalAnchorIdent = hypSrcNameUrl++internalAnchorIdent :: GHC.Name -> String+internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique++hyperlink :: SrcMap -> TokenDetails -> Html -> Html+hyperlink srcs details = case rtkName details of+ Left name ->+ if GHC.isInternalName name+ then internalHyperlink name+ else externalNameHyperlink srcs name+ Right name -> externalModHyperlink srcs name++internalHyperlink :: GHC.Name -> Html -> Html+internalHyperlink name content =+ Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]++externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html+externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of+ Just SrcLocal -> Html.anchor content !+ [ Html.href $ hypSrcModuleNameUrl mdl name ]+ Just (SrcExternal path) -> Html.anchor content !+ [ Html.href $ path </> hypSrcModuleNameUrl mdl name ]+ Nothing -> content+ where+ mdl = GHC.nameModule name++externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html+externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of+ Just SrcLocal -> Html.anchor content !+ [ Html.href $ hypSrcModuleUrl' name ]+ Just (SrcExternal path) -> Html.anchor content !+ [ Html.href $ path </> hypSrcModuleUrl' name ]+ Nothing -> content+++renderSpace :: Int -> String -> Html+renderSpace _ [] = Html.noHtml+renderSpace line ('\n':rest) = mconcat+ [ Html.thespan . Html.toHtml $ "\n"+ , lineAnchor (line + 1)+ , renderSpace (line + 1) rest+ ]+renderSpace line space =+ let (hspace, rest) = span (/= '\n') space+ in (Html.thespan . Html.toHtml) hspace <> renderSpace line rest+++lineAnchor :: Int -> Html+lineAnchor line = Html.anchor Html.noHtml ! [ Html.name $ hypSrcLineUrl line ]
+ src/Haddock/Backends/Hyperlinker/Types.hs view
@@ -0,0 +1,85 @@+module Haddock.Backends.Hyperlinker.Types where+++import qualified GHC++import Data.Map (Map)+import qualified Data.Map as Map+++data Token = Token+ { tkType :: TokenType+ , tkValue :: String+ , tkSpan :: Span+ }++data Position = Position+ { posRow :: !Int+ , posCol :: !Int+ }++data Span = Span+ { spStart :: Position+ , spEnd :: Position+ }++data TokenType+ = TkIdentifier+ | TkKeyword+ | TkString+ | TkChar+ | TkNumber+ | TkOperator+ | TkGlyph+ | TkSpecial+ | TkSpace+ | TkComment+ | TkCpp+ | TkPragma+ | TkUnknown+ deriving (Show, Eq)+++data RichToken = RichToken+ { rtkToken :: Token+ , rtkDetails :: Maybe TokenDetails+ }++data TokenDetails+ = RtkVar GHC.Name+ | RtkType GHC.Name+ | RtkBind GHC.Name+ | RtkDecl GHC.Name+ | RtkModule GHC.ModuleName+ deriving (Eq)+++rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName+rtkName (RtkVar name) = Left name+rtkName (RtkType name) = Left name+rtkName (RtkBind name) = Left name+rtkName (RtkDecl name) = Left name+rtkName (RtkModule name) = Right name+++-- | Path for making cross-package hyperlinks in generated sources.+--+-- Used in 'SrcMap' to determine whether module originates in current package+-- or in an external package.+data SrcPath+ = SrcExternal FilePath+ | SrcLocal++-- | Mapping from modules to cross-package source paths.+--+-- This mapping is actually a pair of maps instead of just one map. The reason+-- for this is because when hyperlinking modules in import lists we have no+-- 'GHC.Module' available. On the other hand, we can't just use map with+-- 'GHC.ModuleName' as indices because certain modules may have common name+-- but originate in different packages. Hence, we use both /rich/ and /poor/+-- versions, where the /poor/ is just projection of /rich/ one cached in pair+-- for better performance.+type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath)++mkSrcMap :: Map GHC.Module SrcPath -> SrcMap+mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs)
+ src/Haddock/Backends/Hyperlinker/Utils.hs view
@@ -0,0 +1,68 @@+module Haddock.Backends.Hyperlinker.Utils+ ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile'+ , hypSrcModuleUrl, hypSrcModuleUrl'+ , hypSrcNameUrl+ , hypSrcLineUrl+ , hypSrcModuleNameUrl, hypSrcModuleLineUrl+ , hypSrcModuleUrlFormat+ , hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat+ ) where+++import Haddock.Backends.Xhtml.Utils++import GHC+import FastString+import System.FilePath.Posix ((</>))+++hypSrcDir :: FilePath+hypSrcDir = "src"++hypSrcModuleFile :: Module -> FilePath+hypSrcModuleFile = hypSrcModuleFile' . moduleName++hypSrcModuleFile' :: ModuleName -> FilePath+hypSrcModuleFile' mdl = spliceURL'+ Nothing (Just mdl) Nothing Nothing moduleFormat++hypSrcModuleUrl :: Module -> String+hypSrcModuleUrl = hypSrcModuleFile++hypSrcModuleUrl' :: ModuleName -> String+hypSrcModuleUrl' = hypSrcModuleFile'++hypSrcNameUrl :: Name -> String+hypSrcNameUrl name = spliceURL+ Nothing Nothing (Just name) Nothing nameFormat++hypSrcLineUrl :: Int -> String+hypSrcLineUrl line = spliceURL+ Nothing Nothing Nothing (Just spn) lineFormat+ where+ loc = mkSrcLoc nilFS line 1+ spn = mkSrcSpan loc loc++hypSrcModuleNameUrl :: Module -> Name -> String+hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name++hypSrcModuleLineUrl :: Module -> Int -> String+hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line++hypSrcModuleUrlFormat :: String+hypSrcModuleUrlFormat = hypSrcDir </> moduleFormat++hypSrcModuleNameUrlFormat :: String+hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat++hypSrcModuleLineUrlFormat :: String+hypSrcModuleLineUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ lineFormat++moduleFormat :: String+moduleFormat = "%{MODULE}.html"++nameFormat :: String+nameFormat = "%{NAME}"++lineFormat :: String+lineFormat = "line-%{LINE}"
src/Haddock/Backends/LaTeX.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.LaTeX@@ -212,9 +213,9 @@ isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)-isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t) _))+isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }- | Map.null argDocs = Just (map unLoc lnames, t)+ | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -249,8 +250,8 @@ declNames :: LHsDecl DocName -> [DocName] declNames (L _ decl) = case decl of TyClD d -> [tcdName d]- SigD (TypeSig lnames _ _) -> map unLoc lnames- SigD (PatSynSig lname _ _ _ _) -> [unLoc lname]+ SigD (TypeSig lnames _ ) -> map unLoc lnames+ SigD (PatSynSig lname _) -> [unLoc lname] ForD (ForeignImport (L _ n) _ _ _) -> [n] ForD (ForeignExport (L _ n) _ _ _) -> [n] _ -> error "declaration not supported by declNames"@@ -292,10 +293,11 @@ -- TyClD d@(TySynonym {}) -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now- TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode- SigD (TypeSig lnames (L _ t) _) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode- SigD (PatSynSig lname qtvs prov req ty) ->- ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode+ TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode+ SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames)+ (hsSigWcType t) unicode+ SigD (PatSynSig lname ty) ->+ ppLPatSig loc (doc, fnArgsDoc) lname ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl"@@ -310,8 +312,8 @@ ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX-ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode =- ppFunSig loc doc [name] typ unicode+ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode =+ ppFunSig loc doc [name] (hsSigType typ) unicode ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -328,7 +330,9 @@ , tcdRhs = ltype }) unicode = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode where- hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)+ hdr = hsep (keyword "type"+ : ppDocBinder name+ : map ppSymName (tyvarNames ltyvars)) full = hdr <+> char '=' <+> ppLType unicode ltype ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"@@ -339,9 +343,9 @@ ------------------------------------------------------------------------------- -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName+ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName -> Bool -> LaTeX-ppFunSig loc doc docnames typ unicode =+ppFunSig loc doc docnames (L _ typ) unicode = ppTypeOrFunSig loc docnames typ doc ( ppTypeSig names typ False , hsep . punctuate comma $ map ppSymName names@@ -351,29 +355,17 @@ names = map getName docnames ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName- -> (HsExplicitFlag, LHsTyVarBndrs DocName)- -> LHsContext DocName -> LHsContext DocName- -> LHsType DocName+ -> LHsSigType DocName -> Bool -> LaTeX-ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode+ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode = declWithDoc pref1 (documentationToLaTeX doc) where pref1 = hsep [ keyword "pattern" , ppDocBinder name , dcolon unicode- , ppLTyVarBndrs expl qtvs unicode- , ctx- , ppType unicode ty+ , ppLType unicode (hsSigType ty) ] - ctx = case (ppLContextMaybe lprov unicode, ppLContextMaybe lreq unicode) of- (Nothing, Nothing) -> empty- (Nothing, Just req) -> parens empty <+> darr <+> req <+> darr- (Just prov, Nothing) -> prov <+> darr- (Just prov, Just req) -> prov <+> darr <+> req <+> darr-- darr = darrow unicode- ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) -> Bool -> LaTeX@@ -392,23 +384,15 @@ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs - do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX- do_args n leader (HsForAllTy Explicit _ tvs lctxt ltype)- = decltt leader <->- decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>- ppLContextNoArrow lctxt unicode) <+> nl $$- do_largs n (darrow unicode) ltype-- do_args n leader (HsForAllTy Qualified e a lctxt ltype)- = do_args n leader (HsForAllTy Implicit e a lctxt ltype)- do_args n leader (HsForAllTy Implicit _ _ lctxt ltype)- | not (null (unLoc lctxt))- = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$- do_largs n (darrow unicode) ltype- -- if we're not showing any 'forall' or class constraints or- -- anything, skip having an empty line for the context.- | otherwise- = do_largs n leader ltype+ do_args :: Int -> LaTeX -> HsType DocName -> LaTeX+ do_args _n leader (HsForAllTy tvs ltype)+ = decltt leader+ <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))+ <+> ppLType unicode ltype+ do_args n leader (HsQualTy lctxt ltype)+ = decltt leader+ <-> ppLContextNoArrow lctxt unicode <+> nl $$+ do_largs n (darrow unicode) ltype do_args n leader (HsFunTy lt r) = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ do_largs (n+1) (arrow unicode) r@@ -423,12 +407,12 @@ <+> ppType unicode ty -ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX]-ppTyVars tvs = map ppSymName (tyvarNames tvs)+ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX]+ppTyVars = map (ppSymName . getName . hsLTyVarName) -tyvarNames :: LHsTyVarBndrs DocName -> [Name]-tyvarNames = map getName . hsLTyVarNames+tyvarNames :: LHsQTyVars DocName -> [Name]+tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX@@ -477,12 +461,12 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName- -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])]+ -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)- <+> ppAppDocNameNames summ n (tyvarNames $ tvs)+ <+> ppAppDocNameNames summ n (tyvarNames tvs) <+> ppFds fds unicode @@ -520,8 +504,8 @@ methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$- vcat [ ppFunSig loc doc names typ unicode- | L _ (TypeSig lnames (L _ typ) _) <- lsigs+ vcat [ ppFunSig loc doc names (hsSigWcType typ) unicode+ | L _ (TypeSig lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that@@ -560,12 +544,13 @@ ppInstHead :: Bool -> InstHead DocName -> LaTeX-ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode-ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type"- <+> ppAppNameTypes n ks ts unicode- <+> maybe empty (\t -> equals <+> ppType unicode t) rhs-ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) =- error "data instances not supported by --latex yet"+ppInstHead unicode (InstHead {..}) = case ihdInstType of+ ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ+ TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs+ DataInst _ -> error "data instances not supported by --latex yet"+ where+ typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode+ tibody = maybe empty (\t -> equals <+> ppType unicode t) lookupAnySubdoc :: (Eq name1) => name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2@@ -591,14 +576,14 @@ where cons = dd_cons (tcdDataDefn dataDecl)- resTy = (con_res . unLoc . head) cons+ resTy = (unLoc . head) cons body = catMaybes [constrBit, doc >>= documentationToLaTeX] (whereBit, leaders) | null cons = (empty,[]) | otherwise = case resTy of- ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty)+ ConDeclGADT{} -> (decltt (keyword "where"), repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit@@ -612,22 +597,86 @@ -- ppConstrHdr is for (non-GADT) existentials constructors' syntax-ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX+ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX ppConstrHdr forall tvs ctxt unicode = (if null tvs then empty else ppForall) <+> (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") where ppForall = case forall of- Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "- Qualified -> empty- Implicit -> empty+ True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "+ False -> empty ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX -> LConDecl DocName -> LaTeX-ppSideBySideConstr subdocs unicode leader (L _ con) =+ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = leader <->+ case con_details con of++ PrefixCon args ->+ decltt (hsep ((header_ unicode <+> ppOcc) :+ map (ppLParendType unicode) args))+ <-> rDoc mbDoc <+> nl++ RecCon (L _ fields) ->+ (decltt (header_ unicode <+> ppOcc)+ <-> rDoc mbDoc <+> nl)+ $$+ doRecordFields fields++ InfixCon arg1 arg2 ->+ decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,+ ppOcc,+ ppLParendType unicode arg2 ])+ <-> rDoc mbDoc <+> nl++ where+ doRecordFields fields =+ vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))+++ header_ = ppConstrHdr False tyVars context+ occ = map (nameOccName . getName . unLoc) $ getConNames con+ ppOcc = case occ of+ [one] -> ppBinder one+ _ -> cat (punctuate comma (map ppBinder occ))+ tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con))+ context = unLoc (fromMaybe (noLoc []) (con_cxt con))++ -- don't use "con_doc con", in case it's reconstructed from a .hi file,+ -- or also because we want Haddock to do the doc-parsing, not GHC.+ mbDoc = case getConNames con of+ [] -> panic "empty con_names"+ (cn:_) -> lookup (unLoc cn) subdocs >>=+ fmap _doc . combineDocumentation . fst++ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) =+ leader <->+ doGADTCon (hsib_body $ con_type con)++ where+ doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+>+ ppLType unicode resTy+ ) <-> rDoc mbDoc++ occ = map (nameOccName . getName . unLoc) $ getConNames con+ ppOcc = case occ of+ [one] -> ppBinder one+ _ -> cat (punctuate comma (map ppBinder occ))++ -- don't use "con_doc con", in case it's reconstructed from a .hi file,+ -- or also because we want Haddock to do the doc-parsing, not GHC.+ mbDoc = case getConNames con of+ [] -> panic "empty con_names"+ (cn:_) -> lookup (unLoc cn) subdocs >>=+ fmap _doc . combineDocumentation . fst+{- old++ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX+ -> LConDecl DocName -> LaTeX+ppSideBySideConstr subdocs unicode leader (L loc con) =+ leader <-> case con_res con of ResTyH98 -> case con_details con of @@ -660,13 +709,13 @@ doRecordFields fields = vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> hsep [- ppForAll forall ltvs (con_cxt con) unicode,- ppLType unicode (foldr mkFunTy resTy args) ]+ doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+>+ ppLType unicode (mk_forall $ mk_phi $+ foldr mkFunTy resTy args) ) <-> rDoc mbDoc - header_ = ppConstrHdr forall tyVars context+ header_ = ppConstrHdr (con_explicit con) tyVars context occ = map (nameOccName . getName . unLoc) $ con_names con ppOcc = case occ of [one] -> ppBinder one@@ -674,7 +723,12 @@ ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con)- forall = con_explicit con++ mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty)+ | otherwise = ty+ mk_phi ty | null context = ty+ | otherwise = L loc (HsQualTy (con_cxt con) ty)+ -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. mbDoc = case con_names con of@@ -682,16 +736,16 @@ (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b)-+-} ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) =- decltt (cat (punctuate comma (map (ppBinder . nameOccName . getName . unL) names))+ decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation- mbDoc = lookup (unL $ head names) subdocs >>= fmap _doc . combineDocumentation . fst+ mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX@@ -790,9 +844,6 @@ ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppLContextMaybe :: Located (HsContext DocName) -> Bool -> Maybe LaTeX-ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc- ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode@@ -822,9 +873,10 @@ ------------------------------------------------------------------------------- -ppBang :: HsBang -> LaTeX-ppBang HsNoBang = empty-ppBang _ = char '!' -- Unpacked args is an implementation detail,+ppBang :: HsSrcBang -> LaTeX+ppBang (HsSrcBang _ _ SrcStrict) = char '!'+ppBang (HsSrcBang _ _ SrcLazy) = char '~'+ppBang _ = empty tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX@@ -877,33 +929,22 @@ -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName- -> Located (HsContext DocName) -> Bool -> LaTeX-ppForAll expl tvs cxt unicode = ppLTyVarBndrs expl tvs unicode <+> ppLContext cxt unicode--ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName- -> Bool -> LaTeX-ppLTyVarBndrs expl tvs unicode- | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) <> dot- | otherwise = empty- where- show_forall = not (null (hsQTvBndrs tvs)) && is_explicit- is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False}- ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX-ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode+ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode = maybeParen ctxt_prec pREC_FUN $- hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode]- where ctxt' = case extra of- Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt- Nothing -> ctxt+ sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot+ , ppr_mono_lty pREC_TOP ty unicode ]+ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode+ = maybeParen ctxt_prec pREC_FUN $+ sep [ ppLContext ctxt unicode+ , ppr_mono_lty pREC_TOP ty unicode ] ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty-ppr_mono_ty _ (HsTyVar name) _ = ppDocName name+ppr_mono_ty _ (HsTyVar (L _ 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 <+> ppLKind u kind)@@ -911,12 +952,10 @@ ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"-ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys-ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode = maybeParen ctxt_prec pREC_OP $@@ -926,7 +965,7 @@ = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode where@@ -940,13 +979,13 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode = ppr_mono_lty ctxt_prec ty unicode -ppr_mono_ty _ HsWildcardTy _ = char '_'--ppr_mono_ty _ (HsNamedWildcardTy name) _ = ppDocName name+ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u +ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy" + ppr_tylit :: HsTyLit -> Bool -> LaTeX ppr_tylit (HsNumTy _ n) _ = integer n ppr_tylit (HsStrTy _ s) _ = text (show s)@@ -1066,6 +1105,8 @@ markupMonospaced = \p _ -> tt (p Mono), markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", markupPic = \p _ -> markupPic p,+ markupMathInline = \p _ -> markupMathInline p,+ markupMathDisplay = \p _ -> markupMathDisplay p, markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "",@@ -1097,6 +1138,10 @@ imageText (Just t) = beg <> text " " <> text t beg = text "image: " <> text uri++ markupMathInline mathjax = text "\\(" <> text mathjax <> text "\\)"++ markupMathDisplay mathjax = text "\\[" <> text mathjax <> text "\\]" markupId ppId_ id v = case v of
src/Haddock/Backends/Xhtml.hs view
@@ -63,6 +63,7 @@ -> FilePath -- ^ Destination directory -> Maybe (MDoc GHC.RdrName) -- ^ Prologue text, maybe -> Themes -- ^ Themes+ -> Maybe String -- ^ The mathjax URL (--mathjax) -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki) -> Maybe String -- ^ The contents URL (--use-contents)@@ -73,7 +74,7 @@ -> IO () ppHtml dflags doctitle maybe_package ifaces odir prologue- themes maybe_source_url maybe_wiki_url+ themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode qual debug = do let@@ -82,18 +83,18 @@ when (isNothing maybe_contents_url) $ ppHtmlContents dflags odir doctitle maybe_package- themes maybe_index_url maybe_source_url maybe_wiki_url+ themes maybe_mathjax_url 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 (makeContentsQual qual) when (isNothing maybe_index_url) $ ppHtmlIndex odir doctitle maybe_package- themes maybe_contents_url maybe_source_url maybe_wiki_url+ themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces) debug mapM_ (ppHtmlModule odir doctitle themes- maybe_source_url maybe_wiki_url+ maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces @@ -107,13 +108,14 @@ mapM_ copyLibFile [ jsFile, framesFile ] -headHtml :: String -> Maybe String -> Themes -> Html-headHtml docTitle miniPage themes =+headHtml :: String -> Maybe String -> Themes -> Maybe String -> Html+headHtml docTitle miniPage themes mathjax_url = header << [ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], thetitle << docTitle, styleSheet themes, script ! [src jsFile, thetype "text/javascript"] << noHtml,+ script ! [src mjUrl, thetype "text/javascript"] << noHtml, script ! [thetype "text/javascript"] -- NB: Within XHTML, the content of script tags needs to be -- a <![CDATA[ section. Will break if the miniPage name could@@ -124,6 +126,7 @@ ] where setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage+ mjUrl = maybe "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url srcButton :: SourceURLs -> Maybe Interface -> Maybe Html@@ -242,6 +245,7 @@ -> Maybe String -> Themes -> Maybe String+ -> Maybe String -> SourceURLs -> WikiURLs -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName)@@ -249,12 +253,12 @@ -> Qualification -- ^ How to qualify names -> IO () ppHtmlContents dflags odir doctitle _maybe_package- themes maybe_index_url+ themes mathjax_url maybe_index_url maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do let tree = mkModuleTree dflags showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces] html =- headHtml doctitle Nothing themes ++++ headHtml doctitle Nothing themes mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [@@ -265,7 +269,7 @@ writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html) -- XXX: think of a better place for this?- ppHtmlContentsFrame odir doctitle themes ifaces debug+ ppHtmlContentsFrame odir doctitle themes mathjax_url ifaces debug ppPrologue :: Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html@@ -304,7 +308,7 @@ htmlModule = thespan ! modAttrs << (cBtn +++ if leaf- then ppModule (mkModule (stringToPackageKey (fromMaybe "" pkg))+ then ppModule (mkModule (stringToUnitId (fromMaybe "" pkg)) (mkModuleName mdl)) else toHtml s )@@ -338,12 +342,12 @@ << toHtml txt -ppHtmlContentsFrame :: FilePath -> String -> Themes+ppHtmlContentsFrame :: FilePath -> String -> Themes -> Maybe String -> [InstalledInterface] -> Bool -> IO ()-ppHtmlContentsFrame odir doctitle themes ifaces debug = do+ppHtmlContentsFrame odir doctitle themes maybe_mathjax_url ifaces debug = do let mods = flatModuleTree ifaces html =- headHtml doctitle Nothing themes ++++ headHtml doctitle Nothing themes maybe_mathjax_url +++ miniBody << divModuleList << (sectionName << "Modules" +++ ulist << [ li ! [theclass "module"] << m | m <- mods ])@@ -361,13 +365,14 @@ -> Maybe String -> Themes -> Maybe String+ -> Maybe String -> SourceURLs -> WikiURLs -> [InstalledInterface] -> Bool -> IO () ppHtmlIndex odir doctitle _maybe_package themes- maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do+ maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do let html = indexPage split_indices Nothing (if split_indices then [] else index) @@ -383,7 +388,7 @@ where indexPage showLetters ch items =- headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes ++++ headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes maybe_mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url maybe_contents_url Nothing << [@@ -483,11 +488,11 @@ ppHtmlModule :: FilePath -> String -> Themes- -> SourceURLs -> WikiURLs+ -> Maybe String -> SourceURLs -> WikiURLs -> Maybe String -> Maybe String -> Bool -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes- maybe_source_url maybe_wiki_url+ maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode qual debug iface = do let mdl = ifaceMod iface@@ -495,7 +500,7 @@ mdl_str = moduleString mdl real_qual = makeModuleQual qual aliases mdl html =- headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes ++++ headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [@@ -505,14 +510,14 @@ createDirectoryIfMissing True odir writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)- ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug+ ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes- -> Interface -> Bool -> Qualification -> Bool -> IO ()-ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do+ -> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO ()+ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do let mdl = ifaceMod iface html =- headHtml (moduleString mdl) Nothing themes ++++ headHtml (moduleString mdl) Nothing themes maybe_mathjax_url +++ miniBody << (divModuleHeader << sectionName << moduleString mdl +++ miniSynopsis mdl iface unicode qual)@@ -522,10 +527,10 @@ ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual- = ppModuleContents qual exports ++++ = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++ description +++ synopsis +++- divInterface (maybe_doc_hdr +++ bdy)+ divInterface (maybe_doc_hdr +++ bdy +++ orphans) where exports = numberSectionHeadings (ifaceRnExportItems iface) @@ -546,7 +551,7 @@ synopsis | no_doc_at_all = noHtml | otherwise- = divSynposis $+ = divSynopsis $ paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ shortDeclList ( mapMaybe (processExport True linksInfo unicode qual) exports@@ -564,6 +569,9 @@ foldr (+++) noHtml $ mapMaybe (processExport False linksInfo unicode qual) exports + orphans =+ ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode qual+ linksInfo = (maybe_source_url, maybe_wiki_url) @@ -583,7 +591,7 @@ (DataDecl{}) -> [keyword "data" <+> b] (SynDecl{}) -> [keyword "type" <+> b] (ClassDecl {}) -> [keyword "class" <+> b]- SigD (TypeSig lnames (L _ _) _) ->+ SigD (TypeSig lnames _) -> map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =@@ -604,16 +612,22 @@ ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName -ppModuleContents :: Qualification -> [ExportItem DocName] -> Html-ppModuleContents qual exports- | null sections = noHtml- | otherwise = contentsDiv+ppModuleContents :: Qualification+ -> [ExportItem DocName]+ -> Bool -- ^ Orphans sections+ -> Html+ppModuleContents qual exports orphan+ | null sections && not orphan = noHtml+ | otherwise = contentsDiv where contentsDiv = divTableOfContents << ( sectionName << "Contents" +++- unordList sections)+ unordList (sections ++ orphanSection)) (sections, _leftovers{-should be []-}) = process 0 exports+ orphanSection+ | orphan = [ linkedAnchor "section.orphans" << "Orphan instances" ]+ | otherwise = [] process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName]) process _ [] = ([], [])
src/Haddock/Backends/Xhtml/Decl.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE TransformListComp #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Html.Decl@@ -14,7 +16,7 @@ module Haddock.Backends.Xhtml.Decl ( ppDecl, - ppTyName, ppTyFamHeader, ppTypeApp,+ ppTyName, ppTyFamHeader, ppTypeApp, ppOrphanInstances, tyvarNames ) where @@ -36,18 +38,20 @@ import GHC.Exts import Name import BooleanFormula+import RdrName ( rdrNameOcc ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of- TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual- TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual- SigD (TypeSig lnames lty _) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual- SigD (PatSynSig lname qtvs prov req ty) ->- ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual+ TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual+ TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual+ SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames+ (hsSigWcType lty) fixities splice unicode qual+ SigD (PatSynSig lname ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname+ ty fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl"@@ -57,26 +61,23 @@ [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =- ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities+ ppFunSig summary links loc doc (map unLoc lnames) lty fixities splice unicode qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->- [DocName] -> HsType DocName -> [(DocName, Fixity)] ->+ [DocName] -> LHsType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppFunSig summary links loc doc docnames typ fixities splice unicode qual =- ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ)+ ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) splice unicode qual where- pp_typ = ppType unicode qual typ+ pp_typ = ppLType unicode qual typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->- Located DocName ->- (HsExplicitFlag, LHsTyVarBndrs DocName) ->- LHsContext DocName -> LHsContext DocName ->- LHsType DocName ->+ Located DocName -> LHsSigType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html-ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual+ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual | summary = pref1 | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual) +++ docSection Nothing qual doc@@ -84,18 +85,9 @@ pref1 = hsep [ keyword "pattern" , ppBinder summary occname , dcolon unicode- , ppLTyVarBndrs expl qtvs unicode qual- , cxt- , ppLType unicode qual typ+ , ppLType unicode qual (hsSigType typ) ] - cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of- (Nothing, Nothing) -> noHtml- (Nothing, Just req) -> parens noHtml <+> darr <+> req <+> darr- (Just prov, Nothing) -> prov <+> darr- (Just prov, Just req) -> prov <+> darr <+> req <+> darr-- darr = darrow unicode occname = nameOccName . getName $ name ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->@@ -129,22 +121,29 @@ argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t+ do_args :: Int -> Html -> HsType DocName -> [SubDecl]- do_args n leader (HsForAllTy _ _ tvs lctxt ltype)- = case unLoc lctxt of- [] -> do_largs n leader' ltype- _ -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])- : do_largs n (darrow unicode) ltype- where leader' = leader <+> ppForAll tvs unicode qual+ do_args n leader (HsForAllTy tvs ltype)+ = do_largs n leader' ltype+ where+ leader' = leader <+> ppForAll tvs unicode qual++ do_args n leader (HsQualTy lctxt ltype)+ | null (unLoc lctxt)+ = do_largs n leader ltype+ | otherwise+ = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])+ : do_largs n (darrow unicode) ltype+ do_args n leader (HsFunTy lt r) = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t = [(leader <+> ppType unicode qual t, argDoc n, [])] -ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html+ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual =- case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs tvs] of+ case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of [] -> noHtml ts -> forallSymbol unicode <+> hsep ts +++ dot where ppKTv n k = parens $@@ -165,27 +164,27 @@ _:[] -> const noHtml -- Don't display names for fixities on single names _ -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False) - uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs+ uniq_fs = [ (n, the p, the d') | (n, Fixity _ p d) <- fs , let d' = ppDir d , then group by Down (p,d') using groupWith ] rightEdge = thespan ! [theclass "rightedge"] << noHtml -ppTyVars :: LHsTyVarBndrs DocName -> [Html]-ppTyVars tvs = map ppTyName (tyvarNames tvs)-+-- | Pretty-print type variables.+ppTyVars :: [LHsTyVarBndr DocName] -> [Html]+ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs -tyvarNames :: LHsTyVarBndrs DocName -> [Name]-tyvarNames = map getName . hsLTyVarNames+tyvarNames :: LHsQTyVars DocName -> [Name]+tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html-ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities+ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities splice unicode qual- = ppFunSig summary links loc doc [name] typ fixities splice unicode qual+ = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -200,7 +199,8 @@ (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) splice unicode qual where- hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)+ hdr = hsep ([keyword "type", ppBinder summary occ]+ ++ ppTyVars (hsQTvExplicit ltyvars)) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs@@ -209,7 +209,7 @@ ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" -ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html+ppTypeSig :: Bool -> [OccName] -> Html -> Unicode -> Html ppTypeSig summary nms pp_ty unicode = concatHtml htmlNames <+> dcolon unicode <+> pp_ty where@@ -220,15 +220,37 @@ ppTyName = ppName Prefix +ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan+ -> [DocName] -> HsType DocName+ -> Html+ppSimpleSig links splice unicode qual loc names typ =+ topDeclElem' names $ ppTypeSig True occNames ppTyp unicode+ where+ topDeclElem' = topDeclElem links loc splice+ ppTyp = ppType unicode qual typ+ occNames = map getOccName names++ -------------------------------------------------------------------------------- -- * Type families -------------------------------------------------------------------------------- +ppFamilyInfo :: Bool -> FamilyInfo DocName -> Html+ppFamilyInfo assoc OpenTypeFamily+ | assoc = keyword "type"+ | otherwise = keyword "type family"+ppFamilyInfo assoc DataFamily+ | assoc = keyword "data"+ | otherwise = keyword "data family"+ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family"++ ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info- , fdKindSig = mkind })+ , fdResultSig = L _ result+ , fdInjectivityAnn = injectivity }) unicode qual = (case info of OpenTypeFamily@@ -241,13 +263,38 @@ -> keyword "type family" ) <+> - ppFamDeclBinderWithVars summary d <+>+ ppFamDeclBinderWithVars summary unicode qual d <+>+ ppResultSig result unicode qual <+> - (case mkind of- Just kind -> dcolon unicode <+> ppLKind unicode qual kind- Nothing -> noHtml+ (case injectivity of+ Nothing -> noHtml+ Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn+ ) <+>++ (case info of+ ClosedTypeFamily _ -> keyword "where ..."+ _ -> mempty ) +ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html+ppResultSig result unicode qual = case result of+ NoSig -> noHtml+ KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind+ TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr++ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName+ -> Html+ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =+ ppFamilyInfo True pfdInfo <+>+ ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+>+ ppResultSig (unLoc pfdKindSig) unicode qual++ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html+ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) =+ char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+>+ hsep (map (ppLDocName qual Raw) rhs)++ ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html@@ -263,20 +310,32 @@ ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual instancesBit- | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl+ | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl , not summary- = subEquations qual $ map (ppTyFamEqn . unLoc) eqns+ = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns | otherwise- = ppInstances links instances docname unicode qual+ = ppInstances links (OriginFamily docname) instances splice unicode qual -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs- , tfe_pats = HsWB { hswb_cts = ts }}+ , tfe_pats = HsIB { hsib_body = ts }} = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual (unLoc rhs) , Nothing, [] ) +++ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification+ -> PseudoFamilyDecl DocName+ -> Html+ppPseudoFamilyDecl links splice unicode qual+ decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) =+ wrapper $ ppPseudoFamilyHeader unicode qual decl+ where+ wrapper = topDeclElem links loc splice [name]++ -------------------------------------------------------------------------------- -- * Associated Types --------------------------------------------------------------------------------@@ -293,9 +352,9 @@ -------------------------------------------------------------------------------- -- | Print a type family and its variables-ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html-ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =- ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs)+ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocName -> Html+ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =+ ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (map unLoc $ hsq_explicit tvs) -- | Print a newtype / data binder and its variables ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html@@ -306,15 +365,22 @@ -- * Type applications -------------------------------------------------------------------------------- +ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [HsTyVarBndr DocName] -> Html+ppAppDocNameTyVarBndrs summ unicode qual n vs =+ ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual)+ where+ ppDN notation = ppBinderFixity notation summ . nameOccName . getName+ ppBinderFixity Infix = ppBinderInfix+ ppBinderFixity _ = ppBinder --- | Print an application of a DocName and two lists of HsTypes (kinds, types)+-- | Print an application of a 'DocName' and two lists of 'HsTypes' (kinds, types) ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Unicode -> Qualification -> Html ppAppNameTypes n ks ts unicode qual = ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual) --- | Print an application of a DocName and a list of Names+-- | Print an application of a 'DocName' and a list of 'Names' ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html ppAppDocNameNames summ n ns = ppTypeApp n [] ns ppDN ppTyName@@ -345,10 +411,6 @@ ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc --ppLContextMaybe :: Located (HsContext DocName) -> Unicode -> Qualification -> Maybe Html-ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc- ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ ppContextNoLocsMaybe (map unLoc cxt) unicode qual@@ -379,7 +441,7 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName- -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])]+ -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class"@@ -402,7 +464,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc subdocs splice unicode qual =- if not (any isVanillaLSig sigs) && null ats+ if not (any isUserLSig sigs) && null ats then (if summary then id else topDeclElem links loc splice [nm]) hdr else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") +++ shortSubDecls False@@ -412,8 +474,9 @@ -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names typ [] splice unicode qual- | L _ (TypeSig lnames (L _ typ) _) <- sigs+ [ ppFunSig summary links loc doc names (hsSigWcType typ)+ [] splice unicode qual+ | L _ (TypeSig lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that@@ -439,8 +502,10 @@ | otherwise = classheader +++ docSection Nothing qual d +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where+ sigs = map unLoc lsigs+ classheader- | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)+ | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) -- Only the fixity relevant to the class header@@ -457,8 +522,9 @@ doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual- | L _ (TypeSig lnames (L _ typ) _) <- lsigs+ methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ)+ subfixs splice unicode qual+ | L _ (ClassOpSig _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities@@ -468,15 +534,15 @@ -- there are different subdocs for different names in a single -- type signature? - minimalBit = case [ s | L _ (MinimalSig _ s) <- lsigs ] of+ minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method- And xs : _ | sort [getName n | Var (L _ n) <- xs] ==- sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns]+ And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==+ sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] ==- [getName n' | L _ (TypeSig ns _ _) <- lsigs, L _ n' <- ns]+ [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing@@ -486,36 +552,123 @@ _ -> noHtml ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n- ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs- ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs+ ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs+ ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs where wrap | p = parens | otherwise = id+ ppMinimal p (Parens x) = ppMinimal p (unLoc x) - instancesBit = ppInstances links instances nm unicode qual+ instancesBit = ppInstances links (OriginClass nm) instances+ splice unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppInstances :: LinksInfo -> [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html-ppInstances links instances baseName unicode qual- = subInstances qual instName links True (map instDecl instances)+ppInstances :: LinksInfo+ -> InstOrigin DocName -> [DocInstance DocName]+ -> Splice -> Unicode -> Qualification+ -> Html+ppInstances links origin instances splice unicode qual+ = subInstances qual instName links True (zipWith instDecl [1..] instances) -- force Splice = True to use line URLs where- instName = getOccString $ getName baseName- instDecl :: DocInstance DocName -> (SubDecl,Located DocName)- instDecl (inst, maybeDoc,l) = ((instHead inst, maybeDoc, []),l)- instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual- <+> ppAppNameTypes n ks ts unicode qual- instHead (n, ks, ts, TypeInst rhs) = keyword "type"- <+> ppAppNameTypes n ks ts unicode qual- <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs- instHead (n, ks, ts, DataInst dd) = keyword "data"- <+> ppAppNameTypes n ks ts unicode qual- <+> ppShortDataDecl False True dd unicode qual+ instName = getOccString origin+ instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)+ instDecl no (inst, mdoc, loc) =+ ((ppInstHead links splice unicode qual mdoc origin False no inst), loc) ++ppOrphanInstances :: LinksInfo+ -> [DocInstance DocName]+ -> Splice -> Unicode -> Qualification+ -> Html+ppOrphanInstances links instances splice unicode qual+ = subOrphanInstances qual links True (zipWith instDecl [1..] instances)+ where+ instOrigin :: InstHead name -> InstOrigin name+ instOrigin inst = OriginClass (ihdClsName inst)++ instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)+ instDecl no (inst, mdoc, loc) =+ ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc)+++ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification+ -> Maybe (MDoc DocName)+ -> InstOrigin DocName+ -> Bool -- ^ Is instance orphan+ -> Int -- ^ Normal+ -> InstHead DocName+ -> SubDecl+ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =+ case ihdInstType of+ ClassInst { .. } ->+ ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ+ , mdoc+ , [subInstDetails iid ats sigs]+ )+ where+ sigs = ppInstanceSigs links splice unicode qual clsiSigs+ ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys+ TypeInst rhs ->+ ( subInstHead iid ptype+ , mdoc+ , [subFamInstDetails iid prhs]+ )+ where+ ptype = keyword "type" <+> typ+ prhs = ptype <+> maybe noHtml+ (\t -> equals <+> ppType unicode qual t) rhs+ DataInst dd ->+ ( subInstHead iid pdata+ , mdoc+ , [subFamInstDetails iid pdecl])+ where+ pdata = keyword "data" <+> typ+ pdecl = pdata <+> ppShortDataDecl False True dd unicode qual+ where+ iid = instanceId origin no orphan ihd+ typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual+++ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification+ -> [PseudoFamilyDecl DocName]+ -> [Html]+ppInstanceAssocTys links splice unicode qual =+ map ppFamilyDecl'+ where+ ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual+++ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification+ -> [Sig DocName]+ -> [Html]+ppInstanceSigs links splice unicode qual sigs = do+ TypeSig lnames typ <- sigs+ let names = map unLoc lnames+ L loc rtyp = get_type typ+ return $ ppSimpleSig links splice unicode qual loc names rtyp+ where+ get_type = hswc_body . hsib_body++ lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n +instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocName -> String+instanceId origin no orphan ihd = concat $+ [ "o:" | orphan ] +++ [ qual origin+ , ":" ++ getOccString origin+ , ":" ++ (occNameString . getOccName . ihdClsName) ihd+ , ":" ++ show no+ ]+ where+ qual (OriginClass _) = "ic"+ qual (OriginData _) = "id"+ qual (OriginFamily _) = "if"++ ------------------------------------------------------------------------------- -- * Data & newtype declarations -------------------------------------------------------------------------------@@ -527,11 +680,11 @@ | [] <- cons = dataHeader - | [lcon] <- cons, ResTyH98 <- resTy,+ | [lcon] <- cons, isH98, (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot - | ResTyH98 <- resTy = dataHeader+ | isH98 = dataHeader +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) | otherwise = (dataHeader <+> keyword "where")@@ -545,7 +698,9 @@ doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual cons = dd_cons (tcdDataDefn dataDecl)- resTy = (con_res . unLoc . head) cons+ isH98 = case unLoc (head cons) of+ ConDeclH98 {} -> True+ ConDeclGADT{} -> False ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->@@ -561,7 +716,9 @@ where docname = tcdName dataDecl cons = dd_cons (tcdDataDefn dataDecl)- resTy = (con_res . unLoc . head) cons+ isH98 = case unLoc (head cons) of+ ConDeclH98 {} -> True+ ConDeclGADT{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix@@ -570,18 +727,17 @@ whereBit | null cons = noHtml- | otherwise = case resTy of- ResTyGADT _ _ -> keyword "where"- _ -> noHtml+ | otherwise = if isH98 then noHtml else keyword "where" constrBit = subConstructors qual [ ppSideBySideConstr subdocs subfixs unicode qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)- (map unLoc (con_names (unLoc c)))) fixities+ (map unLoc (getConNames (unLoc c)))) fixities ] - instancesBit = ppInstances links instances docname unicode qual+ instancesBit = ppInstances links (OriginData docname) instances+ splice unicode qual @@ -594,8 +750,8 @@ -- returns three pieces: header, body, footer so that header & footer can be -- incorporated into the declaration ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html)-ppShortConstrParts summary dataInst con unicode qual = case con_res con of- ResTyH98 -> case con_details con of+ppShortConstrParts summary dataInst con unicode qual = case con of+ ConDeclH98{} -> case con_details con of PrefixCon args -> (header_ unicode qual +++ hsep (ppOcc : map (ppLParendType unicode qual) args), noHtml, noHtml)@@ -608,28 +764,15 @@ ppOccInfix, ppLParendType unicode qual arg2], noHtml, noHtml) - ResTyGADT _ resTy -> case con_details con of- -- prefix & infix could use hsConDeclArgTys if it seemed to- -- simplify the code.- PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml)- -- display GADT records with the new syntax,- -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b)- -- (except each field gets its own line in docs, to match- -- non-GADT records)- RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+>- ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{',- doRecordFields fields,- char '}' <+> arrow unicode <+> ppLType unicode qual resTy)- InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)+ ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml) where+ resTy = hsib_body (con_type con)+ doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields))- doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [- ppForAllCon forall_ ltvs lcontext unicode qual,- ppLType unicode qual (foldr mkFunTy resTy args) ] header_ = ppConstrHdr forall_ tyVars context- occ = map (nameOccName . getName . unLoc) $ con_names con+ occ = map (nameOccName . getName . unLoc) $ getConNames con ppOcc = case occ of [one] -> ppBinder summary one@@ -639,35 +782,34 @@ [one] -> ppBinderInfix summary one _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) - ltvs = con_qvars con+ ltvs = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con) tyVars = tyvarNames ltvs- lcontext = con_cxt con- context = unLoc (con_cxt con)- forall_ = con_explicit con- mkFunTy a b = noLoc (HsFunTy a b)+ lcontext = fromMaybe (noLoc []) (con_cxt con)+ context = unLoc lcontext+ forall_ = False -- ppConstrHdr is for (non-GADT) existentials constructors' syntax-ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode+ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Unicode -> Qualification -> Html ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++- (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual- <+> darrow unicode +++ toHtml " ")+ (if null ctxt then noHtml+ else ppContextNoArrow ctxt unicode qual+ <+> darrow unicode +++ toHtml " ") where- ppForall = case forall_ of- Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". "- Qualified -> noHtml- Implicit -> noHtml-+ ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs)+ <+> toHtml ". "+ | otherwise = noHtml ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> Unicode -> Qualification -> LConDecl DocName -> SubDecl-ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart)+ppSideBySideConstr subdocs fixities unicode qual (L _ con)+ = (decl, mbDoc, fieldPart) where- decl = case con_res con of- ResTyH98 -> case con_details con of+ decl = case con of+ ConDeclH98{} -> case con_details con of PrefixCon args -> hsep ((header_ +++ ppOcc) : map (ppLParendType unicode qual) args)@@ -681,28 +823,26 @@ ppLParendType unicode qual arg2] <+> fixity - ResTyGADT _ resTy -> case con_details con of- -- prefix & infix could also use hsConDeclArgTys if it seemed to- -- simplify the code.- PrefixCon args -> doGADTCon args resTy- cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy- InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy+ ConDeclGADT{} -> doGADTCon resTy - fieldPart = case con_details con of+ resTy = hsib_body (con_type con)++ fieldPart = case getConDetails con of RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))- doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html- doGADTCon args resTy = ppOcc <+> dcolon unicode- <+> hsep [ppForAllCon forall_ ltvs (con_cxt con) unicode qual,- ppLType unicode qual (foldr mkFunTy resTy args) ]++ doGADTCon :: Located (HsType DocName) -> Html+ doGADTCon ty = ppOcc <+> dcolon unicode+ -- ++AZ++ make this prepend "{..}" when it is a record style GADT+ <+> ppLType unicode qual ty <+> fixity fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual- occ = map (nameOccName . getName . unLoc) $ con_names con+ occ = map (nameOccName . getName . unLoc) $ getConNames con ppOcc = case occ of [one] -> ppBinder False one@@ -712,32 +852,30 @@ [one] -> ppBinderInfix False one _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - ltvs = con_qvars con- tyVars = tyvarNames (con_qvars con)- context = unLoc (con_cxt con)- forall_ = con_explicit con+ tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con))+ context = unLoc (fromMaybe (noLoc []) (con_cxt con))+ forall_ = False -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC.- mbDoc = lookup (unLoc $ head $ con_names con) subdocs >>=+ mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>= combineDocumentation . fst- mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocName -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =- (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype,+ (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, mbDoc, []) where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation- mbDoc = lookup (unL $ head names) subdocs >>= combineDocumentation . fst+ mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html ppShortField summary unicode qual (ConDeclField names ltype _)- = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names))+ = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype @@ -767,10 +905,10 @@ -------------------------------------------------------------------------------- -ppBang :: HsBang -> Html-ppBang HsNoBang = noHtml-ppBang _ = toHtml "!" -- Unpacked args is an implementation detail,- -- so we just show the strictness annotation+ppBang :: HsSrcBang -> Html+ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!"+ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~"+ppBang _ = noHtml tupleParens :: HsTupleSort -> [Html] -> Html@@ -816,52 +954,42 @@ ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual +ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html+ppHsTyVarBndr _ qual (UserTyVar (L _ name)) =+ ppDocName qual Raw False name+ppHsTyVarBndr unicode qual (KindedTyVar name kind) =+ parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>+ ppLKind unicode qual kind)+ ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocName -> Html ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual --- Drop top-level for-all type variables in user style--- since they are implicit in Haskell--ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName- -> Located (HsContext DocName) -> Unicode -> Qualification -> Html-ppForAllCon expl tvs cxt unicode qual =- forall_part <+> ppLContext cxt unicode qual- where- forall_part = ppLTyVarBndrs expl tvs unicode qual--ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName- -> Unicode -> Qualification- -> Html-ppLTyVarBndrs expl tvs unicode _qual- | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot- | otherwise = noHtml- where- show_forall = not (null (hsQTvBndrs tvs)) && is_explicit- is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False}-+ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html+ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html-ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual- = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual- <+> ppr_mono_lty pREC_TOP ty unicode qual- where ctxt' = case extra of- Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt- Nothing -> ctxt+ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual+ = maybeParen ctxt_prec pREC_FUN $+ ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual+ = maybeParen ctxt_prec pREC_FUN $+ ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual+ -- UnicodeSyntax alternatives-ppr_mono_ty _ (HsTyVar name) True _+ppr_mono_ty _ (HsTyVar (L _ name)) True _ | getOccString (getName name) == "*" = toHtml "★" | getOccString (getName name) == "(->)" = toHtml "(→)" ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty-ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name+ppr_mono_ty _ (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) ppr_mono_ty _ (HsKindSig ty kind) u q =@@ -871,12 +999,14 @@ ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"-ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"-ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy"+ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}"+ -- Can now legally occur in ConDeclGADT, the output here is to provide a+ -- placeholder in the signature, which is followed by the field+ -- declarations. ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"-ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys-ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys-ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy"+ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys+ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys+ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual = maybeParen ctxt_prec pREC_CTX $@@ -886,11 +1016,16 @@ = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where- ppr_op = ppLDocName qual Infix op+ -- `(:)` is valid in type signature only as constructor to promoted list+ -- and needs to be quoted in code so we explicitly quote it here too.+ ppr_op+ | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op'+ | otherwise = ppr_op'+ ppr_op' = ppLDocName qual Infix op ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual -- = parens (ppr_mono_lty pREC_TOP ty)@@ -899,10 +1034,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual = ppr_mono_lty ctxt_prec ty unicode qual -ppr_mono_ty _ HsWildcardTy _ _ = char '_'--ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name-+ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html
src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -33,6 +33,7 @@ import GHC import Name + parHtmlMarkup :: Qualification -> Bool -> (Bool -> a -> Html) -> DocMarkup a Html parHtmlMarkup qual insertAnchors ppId = Markup {@@ -67,6 +68,8 @@ then namedAnchor aname << "" else noHtml, markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),+ markupMathInline = \mathjax -> toHtml ("\\(" ++ mathjax ++ "\\)"),+ markupMathDisplay = \mathjax -> toHtml ("\\[" ++ mathjax ++ "\\]"), markupProperty = pre . toHtml, markupExample = examplesToHtml, markupHeader = \(Header l t) -> makeHeader l t@@ -161,8 +164,9 @@ UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n- col' = collapseControl id_ True "caption"- instTable = (thediv ! collapseSection id_ False [] <<)+ expanded = False+ col' = collapseControl id_ expanded "caption"+ instTable = (thediv ! collapseSection id_ expanded [] <<) lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] getHeader = fromMaybe caption (lookup lvl lvs) subCaption = getHeader ! col' << markup fmt titl
src/Haddock/Backends/Xhtml/Layout.hs view
@@ -14,7 +14,7 @@ miniBody, divPackageHeader, divContent, divModuleHeader, divFooter,- divTableOfContents, divDescription, divSynposis, divInterface,+ divTableOfContents, divDescription, divSynopsis, divInterface, divIndex, divAlphabet, divModuleList, sectionName,@@ -31,7 +31,8 @@ subConstructors, subEquations, subFields,- subInstances,+ subInstances, subOrphanInstances,+ subInstHead, subInstDetails, subFamInstDetails, subMethods, subMinimal, @@ -43,12 +44,13 @@ import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Types-import Haddock.Utils (makeAnchorId)+import Haddock.Utils (makeAnchorId, nameAnchorId) import qualified Data.Map as Map import Text.XHtml hiding ( name, title, p, quote ) import FastString ( unpackFS ) import GHC+import Name (nameOccName) -------------------------------------------------------------------------------- -- * Sections of the document@@ -76,7 +78,7 @@ divPackageHeader, divContent, divModuleHeader, divFooter,- divTableOfContents, divDescription, divSynposis, divInterface,+ divTableOfContents, divDescription, divSynopsis, divInterface, divIndex, divAlphabet, divModuleList :: Html -> Html @@ -86,7 +88,7 @@ divFooter = sectionDiv "footer" divTableOfContents = sectionDiv "table-of-contents" divDescription = sectionDiv "description"-divSynposis = sectionDiv "synopsis"+divSynopsis = sectionDiv "synopsis" divInterface = sectionDiv "interface" divIndex = sectionDiv "index" divAlphabet = sectionDiv "alphabet"@@ -127,14 +129,12 @@ subDlist :: Qualification -> [SubDecl] -> Maybe Html subDlist _ [] = Nothing-subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv+subDlist qual decls = Just $ ulist << map subEntry decls where subEntry (decl, mdoc, subs) =- dterm ! [theclass "src"] << decl- +++- docElement ddef << (fmap (docToHtml Nothing qual) mdoc +++ subs)-- clearDiv = thediv ! [ theclass "clear" ] << noHtml+ li <<+ (define ! [theclass "src"] << decl ++++ docElement thediv << (fmap (docToHtml Nothing qual) mdoc +++ subs)) subTable :: Qualification -> [SubDecl] -> Maybe Html@@ -180,7 +180,6 @@ subConstructors :: Qualification -> [SubDecl] -> Html subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual - subFields :: Qualification -> [SubDecl] -> Html subFields qual = divSubDecls "fields" "Fields" . subDlist qual @@ -202,6 +201,48 @@ subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm ++subOrphanInstances :: Qualification+ -> LinksInfo -> Bool+ -> [(SubDecl,Located DocName)] -> Html+subOrphanInstances qual lnks splice = maybe noHtml wrap . instTable+ where+ wrap = ((h1 << "Orphan instances") +++)+ instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice+ id_ = makeAnchorId $ "orphans"+++subInstHead :: String -- ^ Instance unique id (for anchor generation)+ -> Html -- ^ Header content (instance name and type)+ -> Html+subInstHead iid hdr =+ expander noHtml <+> hdr+ where+ expander = thespan ! collapseControl (instAnchorId iid) False "instance"+++subInstDetails :: String -- ^ Instance unique id (for anchor generation)+ -> [Html] -- ^ Associated type contents+ -> [Html] -- ^ Method contents (pretty-printed signatures)+ -> Html+subInstDetails iid ats mets =+ subInstSection iid << (subAssociatedTypes ats <+> subMethods mets)++subFamInstDetails :: String -- ^ Instance unique id (for anchor generation)+ -> Html -- ^ Type or data family instance+ -> Html+subFamInstDetails iid fi =+ subInstSection iid << thediv ! [theclass "src"] << fi++subInstSection :: String -- ^ Instance unique id (for anchor generation)+ -> Html+ -> Html+subInstSection iid = thediv ! collapseSection (instAnchorId iid) False "inst-details"++instAnchorId :: String -> String+instAnchorId iid = makeAnchorId $ "i:" ++ iid++ subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock @@ -224,9 +265,11 @@ -- | Adds a source and wiki link at the right hand side of the box. -- Name must be documented, otherwise we wouldn't get here. links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html-links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice (Documented n mdl) =- (srcLink <+> wikiLink)- where srcLink = let nameUrl = Map.lookup origPkg sourceMap+links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice docName@(Documented n mdl) =+ srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << "#")+ where selfLink = linkedAnchor (nameAnchorId (nameOccName (getName docName)))++ srcLink = let nameUrl = Map.lookup origPkg sourceMap lineUrl = Map.lookup origPkg lineMap mUrl | splice = lineUrl -- Use the lineUrl as a backup@@ -249,7 +292,7 @@ -- TODO: do something about type instances. They will point to -- the module defining the type family, which is wrong. origMod = nameModule n- origPkg = modulePackageKey origMod+ origPkg = moduleUnitId origMod fname = case loc of RealSrcSpan l -> unpackFS (srcSpanFile l)
src/Haddock/Backends/Xhtml/Names.hs view
@@ -110,16 +110,21 @@ ppBinder :: Bool -> OccName -> Html--- The Bool indicates whether we are generating the summary, in which case--- the binder will be a link to the full definition.-ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n-ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"]- << ppBinder' Prefix n+ppBinder = ppBinderWith Prefix ppBinderInfix :: Bool -> OccName -> Html-ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n-ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"]- << ppBinder' Infix n+ppBinderInfix = ppBinderWith Infix++ppBinderWith :: Notation -> Bool -> OccName -> Html+-- 'isRef' indicates whether this is merely a reference from another part of+-- the documentation or is the actual definition; in the latter case, we also+-- set the 'id' and 'class' attributes.+ppBinderWith notation isRef n =+ makeAnchor << ppBinder' notation n+ where+ name = nameAnchorId n+ makeAnchor | isRef = linkedAnchor name+ | otherwise = namedAnchor name ! [theclass "def"] ppBinder' :: Notation -> OccName -> Html ppBinder' notation n = wrapInfix notation n $ ppOccName n
src/Haddock/Backends/Xhtml/Types.hs view
@@ -23,7 +23,7 @@ -- the base, module and entity URLs for the source code and wiki links.-type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageKey FilePath, Map PackageKey FilePath)+type SourceURLs = (Maybe FilePath, Maybe FilePath, Map UnitId FilePath, Map UnitId FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)
src/Haddock/Backends/Xhtml/Utils.hs view
@@ -14,14 +14,14 @@ renderToString, namedAnchor, linkedAnchor,- spliceURL,+ spliceURL, spliceURL', groupId, (<+>), (<=>), char, keyword, punctuate, braces, brackets, pabrackets, parens, parenList, ubxParenList,- arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote,+ arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, hsep, vcat, @@ -29,7 +29,6 @@ ) where -import Haddock.GhcUtils import Haddock.Utils import Data.Maybe@@ -38,18 +37,31 @@ import qualified Text.XHtml as XHtml import GHC ( SrcSpan(..), srcSpanStartLine, Name )-import Module ( Module )+import Module ( Module, ModuleName, moduleName, moduleNameString ) import Name ( getOccString, nameOccName, isValOcc ) +-- | Replace placeholder string elements with provided values.+--+-- Used to generate URL for customized external paths, usually provided with+-- @--source-module@, @--source-entity@ and related command-line arguments.+--+-- >>> spliceURL Nothing mmod mname Nothing "output/%{MODULE}.hs#%{NAME}"+-- "output/Foo.hs#foo" spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> Maybe SrcSpan -> String -> String-spliceURL maybe_file maybe_mod maybe_name maybe_loc = run+spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod)+++-- | Same as 'spliceURL' but takes 'ModuleName' instead of 'Module'.+spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name ->+ Maybe SrcSpan -> String -> String+spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run where file = fromMaybe "" maybe_file mdl = case maybe_mod of Nothing -> ""- Just m -> moduleString m+ Just m -> moduleNameString m (name, kind) = case maybe_name of@@ -138,6 +150,11 @@ quote h = char '`' +++ h +++ '`' +-- | Promoted type quote (e.g. @'[a, b]@, @'(a, b, c)@).+promoQuote :: Html -> Html+promoQuote h = char '\'' +++ h++ parens, brackets, pabrackets, braces :: Html -> Html parens h = char '(' +++ h +++ char ')' brackets h = char '[' +++ h +++ char ']'@@ -178,7 +195,7 @@ -- | Generate a named anchor namedAnchor :: String -> Html -> Html-namedAnchor n = anchor ! [XHtml.name n]+namedAnchor n = anchor ! [XHtml.identifier n] linkedAnchor :: String -> Html -> Html@@ -203,7 +220,7 @@ collapseToggle :: String -> [HtmlAttr] collapseToggle id_ = [ strAttr "onclick" js ] where js = "toggleSection('" ++ id_ ++ "')";- + -- | Attributes for an area that toggles a collapsed area, -- and displays a control. collapseControl :: String -> Bool -> String -> [HtmlAttr]
src/Haddock/Convert.hs view
@@ -1,3 +1,4 @@+ {-# LANGUAGE CPP, PatternGuards #-} ----------------------------------------------------------------------------- -- |@@ -22,27 +23,31 @@ import CoAxiom import ConLike import Data.Either (lefts, rights)-import Data.List( partition ) import DataCon import FamInstEnv-import Haddock.Types import HsSyn-import Kind ( splitKindFunTys, synTyConResKind, isKind ) import Name+import NameSet ( emptyNameSet )+import RdrName ( mkVarUnqual ) import PatSyn-import PrelNames (ipClassName)-import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )+import SrcLoc ( Located, noLoc, unLoc ) import TcType ( tcSplitSigmaTy ) import TyCon-import Type (isStrLitTy, mkFunTys)-import TypeRep-import TysPrim ( alphaTyVars )-import TysWiredIn ( listTyConName, eqTyCon )+import Type+import TyCoRep+import TysPrim ( alphaTyVars, unliftedTypeKindTyConName )+import TysWiredIn ( listTyConName, starKindTyConName, unitTy )+import PrelNames ( hasKey, eqTyConKey, ipClassKey+ , tYPETyConKey, ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey ) import Unique ( getUnique )+import Util ( filterByList, filterOut ) import Var +import Haddock.Types+import Haddock.Interface.Specialize + -- the main function here! yay! tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl Name)) tyThingToLHsDecl t = case t of@@ -76,7 +81,7 @@ , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl- , tcdSigs = noLoc (MinimalSig mempty . fmap noLoc $ classMinimalDef cl) :+ , tcdSigs = noLoc (MinimalSig mempty . noLoc . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature@@ -94,17 +99,10 @@ -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc]- (synifyType ImplicitizeForAll (dataConUserType dc)) [])+ (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) ->- let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps- qtvs = univ_tvs ++ ex_tvs- ty = mkFunTys arg_tys res_ty- in allOK . SigD $ PatSynSig (synifyName ps)- (Implicit, synifyTyVars qtvs)- (synifyCtx req_theta)- (synifyCtx prov_theta)- (synifyType WithinType ty)+ allOK . SigD $ PatSynSig (synifyName ps) (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x)@@ -114,12 +112,9 @@ = let name = synifyName tc typats = map (synifyType WithinType) args hs_rhs = synifyType WithinType rhs- (kvs, tvs) = partition isKindVar tkvs in TyFamEqn { tfe_tycon = name- , tfe_pats = HsWB { hswb_cts = typats- , hswb_kvs = map tyVarName kvs- , hswb_tvs = map tyVarName tvs- , hswb_wcs = [] }+ , tfe_pats = HsIB { hsib_body = typats+ , hsib_vars = map tyVarName tkvs } , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name)@@ -130,7 +125,7 @@ (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch , tfid_fvs = placeHolderNamesTc })) - | Just ax' <- isClosedSynFamilyTyCon_maybe tc+ | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error = synifyTyCon (Just ax) tc >>= return . TyClD @@ -139,7 +134,7 @@ -- | Turn type constructors into type class declarations synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name)-synifyTyCon coax tc+synifyTyCon _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ DataDecl { tcdLName = synifyName tc@@ -147,10 +142,10 @@ let mk_hs_tv realKind fakeTyVar = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) (synifyKindSig realKind)- in HsQTvs { hsq_kvs = [] -- No kind polymorphism- , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc)))+ in HsQTvs { hsq_implicit = [] -- No kind polymorphism+ , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind *- }+ , hsq_dependent = emptyNameSet } , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype:@@ -160,35 +155,40 @@ -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = Nothing }+ , tcdDataCusk = False , tcdFVs = placeHolderNamesTc } - | isTypeFamilyTyCon tc- = case famTyConFlav_maybe tc of- Just rhs ->- let info = case rhs of- OpenSynFamilyTyCon -> return OpenTypeFamily- ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) ->- return $ ClosedTypeFamily- (brListMap (noLoc . synifyAxBranch tc) branches)- BuiltInSynFamTyCon {} -> return $ ClosedTypeFamily []- AbstractClosedSynFamilyTyCon {} -> return $ ClosedTypeFamily []- in info >>= \i ->- return (FamDecl- (FamilyDecl { fdInfo = i- , fdLName = synifyName tc- , fdTyVars = synifyTyVars (tyConTyVars tc)- , fdKindSig =- Just (synifyKindSig (synTyConResKind tc))- }))- Nothing -> Left "synifyTyCon: impossible open type synonym?"+synifyTyCon _coax tc+ | Just flav <- famTyConFlav_maybe tc+ = case flav of+ -- Type families+ OpenSynFamilyTyCon -> mkFamDecl OpenTypeFamily+ ClosedSynFamilyTyCon mb+ | Just (CoAxiom { co_ax_branches = branches }) <- mb+ -> mkFamDecl $ ClosedTypeFamily $ Just+ $ map (noLoc . synifyAxBranch tc) (fromBranches branches)+ | otherwise+ -> mkFamDecl $ ClosedTypeFamily $ Just []+ BuiltInSynFamTyCon {}+ -> mkFamDecl $ ClosedTypeFamily $ Just []+ AbstractClosedSynFamilyTyCon {}+ -> mkFamDecl $ ClosedTypeFamily Nothing+ DataFamilyTyCon {}+ -> mkFamDecl DataFamily+ where+ resultVar = famTcResVar tc+ mkFamDecl i = return $ FamDecl $+ FamilyDecl { fdInfo = i+ , fdLName = synifyName tc+ , fdTyVars = synifyTyVars (tyConTyVars tc)+ , fdResultSig =+ synifyFamilyResultSig resultVar (tyConResKind tc)+ , fdInjectivityAnn =+ synifyInjectivityAnn resultVar (tyConTyVars tc)+ (familyTyConInjectivityInfo tc)+ } - | isDataFamilyTyCon tc- = --(why no "isOpenAlgTyCon"?)- case algTyConRhs tc of- DataFamilyTyCon -> return $- FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))- Nothing) --always kind '*'- _ -> Left "synifyTyCon: impossible open data type?"+synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConTyVars tc)@@ -235,9 +235,23 @@ in case lefts consRaw of [] -> return $ DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn- , tcdFVs = placeHolderNamesTc }+ , tcdDataCusk = False, tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs +synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity+ -> Maybe (LInjectivityAnn Name)+synifyInjectivityAnn Nothing _ _ = Nothing+synifyInjectivityAnn _ _ NotInjective = Nothing+synifyInjectivityAnn (Just lhs) tvs (Injective inj) =+ let rhs = map (noLoc . tyVarName) (filterByList inj tvs)+ in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs++synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig Name+synifyFamilyResultSig Nothing kind =+ noLoc $ KindSig (synifyKindSig kind)+synifyFamilyResultSig (Just name) kind =+ noLoc $ TyVarSig (noLoc $ KindedTyVar (noLoc name) (synifyKindSig kind))+ -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its -- result-type.@@ -261,21 +275,18 @@ -- skip any EqTheta, use 'orig'inal syntax ctx = synifyCtx theta - linear_tys = zipWith (\ty bang ->- let tySyn = synifyType WithinType ty- src_bang = case bang of- HsUnpack {} -> HsSrcBang Nothing (Just True) True- HsStrict -> HsSrcBang Nothing (Just False) True- _ -> bang- in case src_bang of- HsNoBang -> tySyn- _ -> noLoc $ HsBangTy bang tySyn- -- HsNoBang never appears, it's implied instead.- )- arg_tys (dataConSrcBangs dc)- field_tys = zipWith (\field synTy -> noLoc $ ConDeclField- [synifyName field] synTy Nothing)- (dataConFieldLabels dc) linear_tys+ linear_tys =+ zipWith (\ty bang ->+ let tySyn = synifyType WithinType ty+ in case bang of+ (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn+ bang' -> noLoc $ HsBangTy bang' tySyn)+ arg_tys (dataConSrcBangs dc)++ field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys+ con_decl_field fl synTy = noLoc $+ ConDeclField [noLoc $ FieldOcc (noLoc $ mkVarUnqual $ flLabel fl) (flSelector fl)] synTy+ Nothing hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" (True,False) -> return $ RecCon (noLoc field_tys)@@ -283,39 +294,46 @@ (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?"- hs_res_ty = if use_gadt_syntax- then ResTyGADT noSrcSpan (synifyType WithinType res_ty)- else ResTyH98+ gadt_ty = HsIB [] (synifyType WithinType res_ty) -- finally we get synifyDataCon's result! in hs_arg_tys >>=- \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care- qvars ctx hat hs_res_ty Nothing- -- we don't want any "deprecated GADT syntax" warnings!- False+ \hat ->+ if use_gadt_syntax+ then return $ noLoc $+ ConDeclGADT { con_names = [name]+ , con_type = gadt_ty+ , con_doc = Nothing }+ else return $ noLoc $+ ConDeclH98 { con_name = name+ , con_qvars = Just qvars+ , con_cxt = Just ctx+ , con_details = hat+ , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName synifyIdSig :: SynifyTypeState -> Id -> Sig Name-synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) []+synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) synifyCtx :: [PredType] -> LHsContext Name synifyCtx = noLoc . map (synifyType WithinType) -synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name-synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs- , hsq_tvs = map synifyTyVar tvs }+synifyTyVars :: [TyVar] -> LHsQTyVars Name+synifyTyVars ktvs = HsQTvs { hsq_implicit = []+ , hsq_explicit = map synifyTyVar ktvs+ , hsq_dependent = emptyNameSet }++synifyTyVar :: TyVar -> LHsTyVarBndr Name+synifyTyVar tv+ | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name))+ | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) where- (kvs, tvs) = partition isKindVar ktvs- synifyTyVar tv- | isLiftedTypeKind kind = noLoc (UserTyVar name)- | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))- where- kind = tyVarKind tv- name = getName tv+ kind = tyVarKind tv+ name = getName tv --states of what to do with foralls: data SynifyTypeState@@ -333,12 +351,35 @@ -- the defining class gets to quantify all its functions for free! +synifySigType :: SynifyTypeState -> Type -> LHsSigType Name+-- The empty binders is a bit suspicious;+-- what if the type has free variables?+synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty)++synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name+-- Ditto (see synifySigType)+synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty))++synifyPatSynSigType :: PatSyn -> LHsSigType Name+-- Ditto (see synifySigType)+synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)+ synifyType :: SynifyTypeState -> Type -> LHsType Name-synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)+synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv) synifyType _ (TyConApp tc tys)+ -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)+ | tc `hasKey` tYPETyConKey+ , [TyConApp lev []] <- tys+ , lev `hasKey` ptrRepLiftedDataConKey+ = noLoc (HsTyVar (noLoc starKindTyConName))+ | tc `hasKey` tYPETyConKey+ , [TyConApp lev []] <- tys+ , lev `hasKey` ptrRepUnliftedDataConKey+ = noLoc (HsTyVar (noLoc unliftedTypeKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer.- | isTupleTyCon tc, tyConArity tc == length tys =- noLoc $ HsTupleTy (case tupleTyConSort tc of+ | Just sort <- tyConTuple_maybe tc+ , tyConArity tc == length tys+ = noLoc $ HsTupleTy (case sort of BoxedTuple -> HsBoxedTuple ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple)@@ -347,41 +388,59 @@ | getName tc == listTyConName, [ty] <- tys = noLoc $ HsListTy (synifyType WithinType ty) -- ditto for implicit parameter tycons- | tyConName tc == ipClassName+ | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) -- and equalities- | tc == eqTyCon+ | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))- (noLoc $ HsTyVar (getName tc))- (map (synifyType WithinType) tys)+ (noLoc $ HsTyVar $ noLoc (getName tc))+ (map (synifyType WithinType) $+ filterOut isCoercionTy tys)+synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsAppTy s1 s2-synifyType _ (FunTy t1 t2) = let+synifyType _ (ForAllTy (Anon t1) t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsFunTy s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTy forallty- sTvs = synifyTyVars tvs- sCtx = synifyCtx ctx- sTau = synifyType WithinType tau- mkHsForAllTy forallPlicitness =- noLoc $ HsForAllTy forallPlicitness Nothing sTvs sCtx sTau+ sPhi = HsQualTy { hst_ctxt = synifyCtx ctx+ , hst_body = synifyType WithinType tau } in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau- WithinType -> mkHsForAllTy Explicit- ImplicitizeForAll -> mkHsForAllTy Implicit+ WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs+ , hst_body = noLoc sPhi }+ ImplicitizeForAll -> noLoc sPhi synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t+synifyType s (CastTy t _) = synifyType s t+synifyType _ (CoercionTy {}) = error "synifyType:Coercion" +synifyPatSynType :: PatSyn -> LHsType Name+synifyPatSynType ps = let+ (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps+ req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy]+ -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",+ -- i.e., an explicit empty context, which is what we need. This is not+ -- possible by taking theta = [], as that will print no context at all+ | otherwise = req_theta+ sForAll [] s = s+ sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs+ , hst_body = noLoc s }+ sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta+ , hst_body = noLoc s }+ sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty+ in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau+ synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy mempty n synifyTyLit (StrTyLit s) = HsStrTy mempty s@@ -390,23 +449,38 @@ synifyKindSig k = synifyType WithinType k synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name-synifyInstHead (_, preds, cls, types) =- ( getName cls- , map (unLoc . synifyType WithinType) ks- , map (unLoc . synifyType WithinType) ts- , ClassInst $ map (unLoc . synifyType WithinType) preds- )- where (ks,ts) = break (not . isKind) types+synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead+ { ihdClsName = getName cls+ , ihdKinds = map (unLoc . synifyType WithinType) ks+ , ihdTypes = map (unLoc . synifyType WithinType) ts+ , ihdInstType = ClassInst+ { clsiCtx = map (unLoc . synifyType WithinType) preds+ , clsiTyVars = synifyTyVars $ classTyVars cls+ , clsiSigs = map synifyClsIdSig $ classMethods cls+ , clsiAssocTys = do+ (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls+ pure $ mkPseudoFamilyDecl fam+ }+ }+ where+ (ks,ts) = partitionInvisibles (classTyCon cls) id types+ synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification -- Convert a family instance, this could be a type family or data family synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name)-synifyFamInst fi opaque =- let fff = case fi_flavor fi of- SynFamilyInst | opaque -> return $ TypeInst Nothing- SynFamilyInst ->- return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi- DataFamilyInst c ->- synifyTyCon (Just $ famInstAxiom fi) c >>= return . DataInst- in fff >>= \f' -> return (fi_fam fi , map (unLoc . synifyType WithinType) ks,- map (unLoc . synifyType WithinType) ts , f')- where (ks,ts) = break (not . isKind) $ fi_tys fi+synifyFamInst fi opaque = do+ ityp' <- ityp $ fi_flavor fi+ return InstHead+ { ihdClsName = fi_fam fi+ , ihdKinds = synifyTypes ks+ , ihdTypes = synifyTypes ts+ , ihdInstType = ityp'+ }+ where+ ityp SynFamilyInst | opaque = return $ TypeInst Nothing+ ityp SynFamilyInst =+ return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi+ ityp (DataFamilyInst c) =+ DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c+ (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi+ synifyTypes = map (unLoc. synifyType WithinType)
src/Haddock/GhcUtils.hs view
@@ -35,13 +35,6 @@ moduleString :: Module -> String moduleString = moduleNameString . moduleName -lookupLoadedHomeModuleGRE :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv)-lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env ->- case lookupUFM (hsc_HPT hsc_env) mod_name of- Just mod_info -> return (mi_globals (hm_iface mod_info))- _not_a_home_module -> return Nothing-- isNameSym :: Name -> Bool isNameSym = isSymOcc . nameOccName @@ -68,7 +61,7 @@ -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan-getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l+getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l getInstLoc (TyFamInstD (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances@@ -91,10 +84,14 @@ [] -> Nothing filtered -> Just (FixSig (FixitySig filtered ty)) filterSigNames _ orig@(MinimalSig _ _) = Just orig-filterSigNames p (TypeSig ns ty nwcs) =+filterSigNames p (TypeSig ns ty) = case filter (p . unLoc) ns of [] -> Nothing- filtered -> Just (TypeSig filtered ty nwcs)+ filtered -> Just (TypeSig filtered ty)+filterSigNames p (ClassOpSig is_default ns ty) =+ case filter (p . unLoc) ns of+ [] -> Nothing+ filtered -> Just (ClassOpSig is_default filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name@@ -105,34 +102,25 @@ sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [name]-sigNameNoLoc (TypeSig ns _ _) = map unLoc ns-sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n]-sigNameNoLoc (SpecSig n _ _) = [unLoc n]-sigNameNoLoc (InlineSig n _) = [unLoc n]+sigNameNoLoc (TypeSig ns _) = map unLoc ns+sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns+sigNameNoLoc (PatSynSig n _) = [unLoc n]+sigNameNoLoc (SpecSig n _ _) = [unLoc n]+sigNameNoLoc (InlineSig n _) = [unLoc n] sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns sigNameNoLoc _ = [] --isTyClD :: HsDecl a -> Bool-isTyClD (TyClD _) = True-isTyClD _ = False+-- | Was this signature given by the user?+isUserLSig :: LSig name -> Bool+isUserLSig (L _(TypeSig {})) = True+isUserLSig (L _(ClassOpSig {})) = True+isUserLSig _ = False isClassD :: HsDecl a -> Bool isClassD (TyClD d) = isClassDecl d isClassD _ = False --isDocD :: HsDecl a -> Bool-isDocD (DocD _) = True-isDocD _ = False---isInstD :: HsDecl a -> Bool-isInstD (InstD _) = True-isInstD _ = False-- isValD :: HsDecl a -> Bool isValD (ValD _) = True isValD _ = False@@ -146,11 +134,6 @@ pretty :: Outputable a => DynFlags -> a -> String pretty = showPpr --trace_ppr :: Outputable a => DynFlags -> a -> b -> b-trace_ppr dflags x y = trace (pretty dflags x) y-- ------------------------------------------------------------------------------- -- * Located -------------------------------------------------------------------------------@@ -163,11 +146,6 @@ reL :: a -> Located a reL = L undefined --before :: Located a -> Located a -> Bool-before = (<) `on` getLoc-- ------------------------------------------------------------------------------- -- * NamedThing instances -------------------------------------------------------------------------------@@ -187,17 +165,18 @@ instance Parent (ConDecl Name) where children con =- case con_details con of- RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields)+ case getConDetails con of+ RecCon fields -> map (selectorFieldOcc . unL) $+ concatMap (cd_fld_names . unL) (unL fields) _ -> [] instance Parent (TyClDecl Name) where children d- | isDataDecl d = map unL $ concatMap (con_names . unL)+ | isDataDecl d = map unL $ concatMap (getConNames . unL) $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++- [ unL n | L _ (TypeSig ns _ _) <- tcdSigs d, n <- ns ]+ [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] | otherwise = [] @@ -207,7 +186,7 @@ familyConDecl :: ConDecl Name -> [(Name, [Name])]-familyConDecl d = zip (map unL (con_names d)) (repeat $ children d)+familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d) -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively.
src/Haddock/Interface.hs view
@@ -228,7 +228,7 @@ foldl' keep_old old_env exported_names | otherwise = foldl' keep_new old_env exported_names where- exported_names = ifaceVisibleExports iface+ exported_names = ifaceVisibleExports iface ++ map getName (ifaceInstances iface) mdl = ifaceMod iface keep_old env n = Map.insertWith (\_ old -> old) n mdl env keep_new env n = Map.insert n mdl env@@ -239,6 +239,6 @@ -------------------------------------------------------------------------------- -withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a+withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a withTempDir dir = gbracket_ (liftIO $ createDirectory dir) (liftIO $ removeDirectoryRecursive dir)
src/Haddock/Interface/AttachInstances.hs view
@@ -22,17 +22,18 @@ import Data.List import Data.Ord (comparing) import Data.Function (on)+import Data.Maybe ( maybeToList, mapMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set import Class import DynFlags+import CoreSyn (isOrphan) import ErrUtils import FamInstEnv import FastString import GHC import GhcMonad (withSession)-import Id import InstEnv import MonadUtils (liftIO) import Name@@ -40,9 +41,8 @@ import PrelNames import SrcLoc import TcRnDriver (tcRnGetInfo)-import TcType (tcSplitSigmaTy) import TyCon-import TypeRep+import TyCoRep import TysPrim( funTyCon ) import Var hiding (varName) #define FSLIT(x) (mkFastString# (x#))@@ -61,9 +61,20 @@ attach iface = do newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap) (ifaceExportItems iface)- return $ iface { ifaceExportItems = newItems }+ let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface)+ return $ iface { ifaceExportItems = newItems+ , ifaceOrphanInstances = orphanInstances+ } +attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name]+attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =+ [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n))+ | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]+ , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is+ , not $ isInstanceHidden expInfo cls tys+ ] + attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name)@@ -82,7 +93,7 @@ , let opaque = isTypeHidden expInfo (fi_rhs i) ] cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d)))- | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]+ | let is = [ (instanceSig i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys ]@@ -108,7 +119,7 @@ attachFixities e = e -- spanName: attach the location to the name that is the same file as the instance location- spanName s (clsn,_,_,_) (L instL instn) =+ spanName s (InstHead { ihdClsName = clsn }) (L instL instn) = let s1 = getSrcSpan s sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL then instn@@ -131,20 +142,6 @@ iface' <- Map.lookup (nameModule name) ifaceMaps Map.lookup name (f iface') --- | Like GHC's 'instanceHead' but drops "silent" arguments.-instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type])-instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys)- where- dfun = is_dfun ispec- (tvs, cls, tys) = instanceHead ispec- (_, theta, _) = tcSplitSigmaTy (idType dfun)---- | Drop "silent" arguments. See GHC Note [Silent superclass--- arguments].-dropSilentArgs :: DFunId -> ThetaType -> ThetaType-dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta-- -- | 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,[ClsInst],[FamInst]))@@ -174,19 +171,27 @@ argCount :: Type -> Int argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts-argCount (FunTy _ _ ) = 2+argCount (ForAllTy (Anon _) _ ) = 2 argCount (ForAllTy _ t) = argCount t+argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType+simplify (ForAllTy (Anon t1) t2) = SimpleType funTyConName [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t-simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]-simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])+simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1 simplify (TyVarTy v) = SimpleType (tyVarName v) []-simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)+simplify (TyConApp tc ts) = SimpleType (tyConName tc)+ (mapMaybe simplify_maybe ts) simplify (LitTy l) = SimpleTyLit l+simplify (CastTy ty _) = simplify ty+simplify (CoercionTy _) = error "simplify:Coercion" +simplify_maybe :: Type -> Maybe SimpleType+simplify_maybe (CoercionTy {}) = Nothing+simplify_maybe ty = Just (simplify ty)+ -- Used for sorting instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType) instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t }@@ -235,9 +240,10 @@ TyVarTy {} -> False AppTy t1 t2 -> typeHidden t1 || typeHidden t2 TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args- FunTy t1 t2 -> typeHidden t1 || typeHidden t2- ForAllTy _ ty -> typeHidden ty+ ForAllTy bndr ty -> typeHidden (binderType bndr) || typeHidden ty LitTy _ -> False+ CastTy ty _ -> typeHidden ty+ CoercionTy {} -> False nameHidden :: Name -> Bool nameHidden = isNameHidden expInfo
src/Haddock/Interface/Create.hs view
@@ -21,6 +21,9 @@ import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn+import Haddock.Backends.Hyperlinker.Types+import Haddock.Backends.Hyperlinker.Ast as Hyperlinker+import Haddock.Backends.Hyperlinker.Parser as Hyperlinker import qualified Data.Map as M import Data.Map (Map)@@ -45,7 +48,9 @@ import RdrName import TcRnTypes import FastString (concatFS)+import BasicTypes ( StringLiteral(..) ) import qualified Outputable as O+import HsDecls ( gadtDeclDetails,getConDetails ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological@@ -122,6 +127,8 @@ mkAliasMap dflags $ tm_renamed_source tm modWarn = moduleWarning dflags gre warnings + tokenizedSrc <- mkMaybeTokenizedSrc flags tm+ return $! Interface { ifaceMod = mdl , ifaceOrigFilename = msHsFilePath ms@@ -143,8 +150,11 @@ , ifaceModuleAliases = aliases , ifaceInstances = instances , ifaceFamInstances = fam_instances+ , ifaceOrphanInstances = [] -- Filled in `attachInstances`+ , ifaceRnOrphanInstances = [] -- Filled in `renameInterface` , ifaceHaddockCoverage = coverage , ifaceWarningMap = warningMap+ , ifaceTokenizedSrc = tokenizedSrc } mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName@@ -157,21 +167,21 @@ alias <- ideclAs impDecl return $ (lookupModuleDyn dflags- (fmap Module.fsToPackageKey $- ideclPkgQual impDecl)+ (fmap Module.fsToUnitId $+ fmap sl_fs $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls -- similar to GHC.lookupModule lookupModuleDyn ::- DynFlags -> Maybe PackageKey -> ModuleName -> Module+ DynFlags -> Maybe UnitId -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName lookupModuleDyn dflags Nothing mdlName = case Packages.lookupModuleInAllPackages dflags mdlName of (m,_):_ -> m- [] -> Module.mkModule Module.mainPackageKey mdlName+ [] -> Module.mkModule Module.mainUnitId mdlName -------------------------------------------------------------------------------@@ -194,8 +204,8 @@ parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name parseWarning dflags gre w = force $ case w of- DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map unLoc msg)- WarningTxt _ msg -> format "Warning: " (concatFS $ map unLoc msg)+ DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg)+ WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) . processDocString dflags gre $ HsDocString xs@@ -328,30 +338,30 @@ classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ]+ dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields where cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)- | c <- cons, cname <- con_names c ]- fields = [ (unL n, maybeToList $ fmap unL doc, M.empty)- | RecCon flds <- map con_details cons+ | c <- cons, cname <- getConNames c ]+ fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty)+ | RecCon flds <- map getConDetails cons , L _ (ConDeclField ns _ doc) <- (unLoc flds)- , n <- ns ]+ , L _ n <- ns ] -- | Extract function argument docs from inside types. typeDocs :: HsDecl Name -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of- SigD (TypeSig _ ty _) -> docs (unLoc ty)- SigD (PatSynSig _ _ req prov ty) ->- let allTys = ty : concat [ unLoc req, unLoc prov ]- in F.foldMap (docs . unLoc) allTys- ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)+ SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty))+ SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty))+ ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty)) TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) _ -> M.empty where- go n (HsForAllTy _ _ _ _ ty) = go n (unLoc ty)+ go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)+ go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty go n (HsFunTy _ ty) = go (n+1) (unLoc ty) go n (HsDocTy _ (L _ doc)) = M.singleton n doc@@ -394,7 +404,7 @@ mkDecls (typesigs . hs_valds) SigD group_ ++ mkDecls (valbinds . hs_valds) ValD group_ where- typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs+ typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut" valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds@@ -426,7 +436,7 @@ isHandled (ForD (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True- isHandled (SigD d) = isVanillaLSig (reL d)+ isHandled (SigD d) = isUserLSig (reL d) isHandled (ValD _) = True -- we keep doc declarations to be able to get at named docs isHandled (DocD _) = True@@ -439,7 +449,7 @@ | x@(L loc d, doc) <- decls ] where filterClass (TyClD c) =- TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c }+ TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } filterClass _ = error "expected TyClD" @@ -498,7 +508,7 @@ lookupExport (IEVar (L _ x)) = declWith x lookupExport (IEThingAbs (L _ t)) = declWith t lookupExport (IEThingAll (L _ t)) = declWith t- lookupExport (IEThingWith (L _ t) _) = declWith t+ lookupExport (IEThingWith (L _ t) _ _ _) = declWith t lookupExport (IEModuleContents (L _ m)) = moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $@@ -523,7 +533,7 @@ let declNames = getMainDeclBinder (unL decl) in case () of _- -- temp hack: we filter out separately exported ATs, since we haven't decided how+ -- TODO: temp hack: we filter out separately exported ATs, since we haven't decided how -- to handle them yet. We should really give an warning message also, and filter the -- name out in mkVisibleNames... | t `elem` declATs (unL decl) -> return []@@ -553,7 +563,7 @@ L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t- let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef+ let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] @@ -695,8 +705,8 @@ "documentation for exported module: " ++ pretty dflags expMod] return [] where- m = mkModule packageKey expMod- packageKey = modulePackageKey thisMod+ m = mkModule unitId expMod+ unitId = moduleUnitId thisMod -- Note [1]:@@ -730,8 +740,8 @@ expandSig = foldr f [] where f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]- f (L l (SigD (TypeSig names t nwcs))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t nwcs)) : acc) xs names- f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names+ f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names+ f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names f x xs = x : xs mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))@@ -751,7 +761,7 @@ return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name- let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef+ let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name mkExportItem decl@(L l d) | name:_ <- getMainDeclBinder d = expDecl decl l name@@ -775,64 +785,49 @@ case unLoc decl of TyClD d@ClassDecl {} -> let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,- isVanillaLSig sig ] -- TODO: document fixity+ isTypeLSig sig ] -- TODO: document fixity in case matches of- [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d)- L pos sig = extractClassDecl n tyvar_names s0+ [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)+ L pos sig = addClassContext n tyvar_names s0 in L pos (SigD sig) _ -> error "internal: extractDecl (ClassDecl)" TyClD d@DataDecl {} ->- let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d)- in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d))+ let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))+ in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d)) InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n- , dfid_pats = HsWB { hswb_cts = tys }+ , dfid_pats = HsIB { hsib_body = tys } , dfid_defn = defn }) -> SigD <$> extractRecSel name mdl n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)+ -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)+ , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns- , n == name+ , selectorFieldOcc n == name ] in case matches of [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl"- where- getTyVars = hsLTyVarLocNames . tyClDeclTyVars --toTypeNoLoc :: Located Name -> LHsType Name-toTypeNoLoc = noLoc . HsTyVar . unLoc---extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name-extractClassDecl c tvs0 (L pos (TypeSig lname ltype _)) = case ltype of- L _ (HsForAllTy expl _ tvs (L _ preds) ty) ->- L pos (TypeSig lname (noLoc (HsForAllTy expl Nothing tvs (lctxt preds) ty)) [])- _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit Nothing emptyHsQTvs (lctxt []) ltype)) [])- where- lctxt = noLoc . ctxt- ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds-extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"-- extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) =- case con_details con of- RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->- L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) [])+ case getConDetails con of+ RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->+ L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) _ -> extractRecSel nm mdl t tvs rest where- matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ]+ matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]+ matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds+ , L l n <- ns, selectorFieldOcc n == nm ] data_ty- | ResTyGADT _ ty <- con_res con = ty- | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs-+ -- | ResTyGADT _ ty <- con_res con = ty+ | ConDeclGADT{} <- con = hsib_body $ con_type con+ | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs -- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name]@@ -860,6 +855,30 @@ seqList :: [a] -> () seqList [] = () seqList (x : xs) = x `seq` seqList xs++mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule+ -> ErrMsgGhc (Maybe [RichToken])+mkMaybeTokenizedSrc flags tm+ | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of+ Just src -> do+ tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src+ return $ Just tokens+ Nothing -> do+ liftErrMsg . tell . pure $ concat+ [ "Warning: Cannot hyperlink module \""+ , moduleNameString . ms_mod_name $ summary+ , "\" because renamed source is not available"+ ]+ return Nothing+ | otherwise = return Nothing+ where+ summary = pm_mod_summary . tm_parsed_module $ tm++mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken]+mkTokenizedSrc ms src =+ Hyperlinker.enrich src . Hyperlinker.parse <$> rawSrc+ where+ rawSrc = readFile $ msHsFilePath ms -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
src/Haddock/Interface/LexParseRn.hs view
@@ -21,14 +21,15 @@ import Data.IntSet (toList) import Data.List import Documentation.Haddock.Doc (metaDocConcat)-import DynFlags (ExtensionFlag(..), languageExtensions)+import DynFlags (languageExtensions)+import qualified GHC.LanguageExtensions as LangExt import FastString import GHC import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types import Name-import Outputable (showPpr)+import Outputable ( showPpr ) import RdrName import RnEnv (dataTcOccs) @@ -64,7 +65,7 @@ doc' = overDoc (rename dflags gre) doc return (hmi', Just doc') - let flags :: [ExtensionFlag]+ let flags :: [LangExt.Extension] -- We remove the flags implied by the language setting and we display the language instead flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags) return (hmi { hmi_safety = Just $ showPpr dflags safety@@ -131,6 +132,8 @@ DocModule str -> DocModule str DocHyperlink l -> DocHyperlink l DocPic str -> DocPic str+ DocMathInline str -> DocMathInline str+ DocMathDisplay str -> DocMathDisplay str DocAName str -> DocAName str DocProperty p -> DocProperty p DocExamples e -> DocExamples e
src/Haddock/Interface/Rename.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename@@ -21,8 +21,6 @@ import Bag (emptyBag) import GHC hiding (NoLink) import Name-import NameSet-import Coercion import Control.Applicative import Control.Monad hiding (mapM)@@ -49,13 +47,17 @@ (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface)) - (finalModuleDoc, missingNames4)+ (renamedOrphanInstances, missingNames4)+ = runRnFM localEnv (mapM renameDocInstance (ifaceOrphanInstances iface))++ (finalModuleDoc, missingNames5) = runRnFM localEnv (renameDocumentation (ifaceDoc iface)) -- combine the missing names and filter out the built-ins, which would- -- otherwise allways be missing.+ -- otherwise always be missing. missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much- (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4)+ (missingNames1 ++ missingNames2 ++ missingNames3+ ++ missingNames4 ++ missingNames5) -- filter out certain built in type constructors using their string -- representation. TODO: use the Name constants from the GHC API.@@ -74,7 +76,8 @@ return $ iface { ifaceRnDoc = finalModuleDoc, ifaceRnDocMap = rnDocMap, ifaceRnArgMap = rnArgMap,- ifaceRnExportItems = renamedExportItems }+ ifaceRnExportItems = renamedExportItems,+ ifaceRnOrphanInstances = renamedOrphanInstances} --------------------------------------------------------------------------------@@ -93,13 +96,13 @@ instance Monad RnM where (>>=) = thenRn- return = returnRn+ return = pure instance Functor RnM where fmap f x = do a <- x; return (f a) instance Applicative RnM where- pure = return+ pure = returnRn (<*>) = ap returnRn :: a -> RnM a@@ -172,22 +175,51 @@ renameLType :: LHsType Name -> RnM (LHsType DocName) renameLType = mapM renameType +renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName)+renameLSigType = renameImplicit renameLType++renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName)+renameLSigWcType = renameImplicit (renameWc renameLType)+ renameLKind :: LHsKind Name -> RnM (LHsKind DocName) renameLKind = renameLType renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind = traverse renameLKind +renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName)+renameFamilyResultSig (L loc NoSig)+ = return (L loc NoSig)+renameFamilyResultSig (L loc (KindSig ki))+ = do { ki' <- renameLKind ki+ ; return (L loc (KindSig ki')) }+renameFamilyResultSig (L loc (TyVarSig bndr))+ = do { bndr' <- renameLTyVarBndr bndr+ ; return (L loc (TyVarSig bndr')) } +renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName)+renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))+ = do { lhs' <- renameL lhs+ ; rhs' <- mapM renameL rhs+ ; return (L loc (InjectivityAnn lhs' rhs')) }++renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn Name)+ -> RnM (Maybe (LInjectivityAnn DocName))+renameMaybeInjectivityAnn = traverse renameInjectivityAnn+ renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of- HsForAllTy expl extra tyvars lcontext ltype -> do- tyvars' <- renameLTyVarBndrs tyvars+ HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do+ tyvars' <- mapM renameLTyVarBndr tyvars+ ltype' <- renameLType ltype+ return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' })++ HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype- return (HsForAllTy expl extra tyvars' lcontext' ltype')+ return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar n -> return . HsTyVar =<< rename n+ HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype HsAppTy a b -> do@@ -207,11 +239,11 @@ HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - HsOpTy a (w, L loc op) b -> do+ HsOpTy a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b- return (HsOpTy a' (w, L loc op') b')+ return (HsOpTy a' (L loc op') b') HsParTy ty -> return . HsParTy =<< renameLType ty @@ -227,29 +259,24 @@ HsTyLit x -> return (HsTyLit x) - HsWrapTy a b -> HsWrapTy a <$> renameType b HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a HsCoreTy a -> pure (HsCoreTy a) HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b- HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a HsSpliceTy _ _ -> error "renameType: HsSpliceTy"- HsWildcardTy -> pure HsWildcardTy- HsNamedWildcardTy a -> HsNamedWildcardTy <$> rename a--renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName)-renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c+ HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a+ HsAppsTy _ -> error "renameType: HsAppsTy" -renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)-renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })+renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)+renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs- ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) }+ ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) } -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)-renameLTyVarBndr (L loc (UserTyVar n))+renameLTyVarBndr (L loc (UserTyVar (L l n))) = do { n' <- rename n- ; return (L loc (UserTyVar n')) }+ ; return (L loc (UserTyVar (L l n'))) } renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind@@ -260,17 +287,28 @@ context' <- mapM renameLType context return (L loc context') +renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName)+renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name+ renameInstHead :: InstHead Name -> RnM (InstHead DocName)-renameInstHead (className, k, types, rest) = do- className' <- rename className- k' <- mapM renameType k- types' <- mapM renameType types- rest' <- case rest of- ClassInst cs -> ClassInst <$> mapM renameType cs+renameInstHead InstHead {..} = do+ cname <- rename ihdClsName+ kinds <- mapM renameType ihdKinds+ types <- mapM renameType ihdTypes+ itype <- case ihdInstType of+ ClassInst { .. } -> ClassInst+ <$> mapM renameType clsiCtx+ <*> renameLHsQTyVars clsiTyVars+ <*> mapM renameSig clsiSigs+ <*> mapM renamePseudoFamilyDecl clsiAssocTys TypeInst ts -> TypeInst <$> traverse renameType ts DataInst dd -> DataInst <$> renameTyClD dd- return (className', k', types', rest')-+ return InstHead+ { ihdClsName = cname+ , ihdKinds = kinds+ , ihdTypes = types+ , ihdInstType = itype+ } renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) renameLDecl (L loc d) = return . L loc =<< renameDecl d@@ -304,21 +342,21 @@ SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do lname' <- renameL lname- tyvars' <- renameLTyVarBndrs tyvars+ tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames }) DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do lname' <- renameL lname- tyvars' <- renameLTyVarBndrs tyvars+ tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn- return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames })+ return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do lcontext' <- renameLContext lcontext lname' <- renameL lname- ltyvars' <- renameLTyVarBndrs ltyvars+ ltyvars' <- renameLHsQTyVars ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM (renameLThing renameFamilyDecl) ats@@ -338,19 +376,32 @@ renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname- , fdTyVars = ltyvars, fdKindSig = tckind }) = do- info' <- renameFamilyInfo info- lname' <- renameL lname- ltyvars' <- renameLTyVarBndrs ltyvars- tckind' <- renameMaybeLKind tckind+ , fdTyVars = ltyvars, fdResultSig = result+ , fdInjectivityAnn = injectivity }) = do+ info' <- renameFamilyInfo info+ lname' <- renameL lname+ ltyvars' <- renameLHsQTyVars ltyvars+ result' <- renameFamilyResultSig result+ injectivity' <- renameMaybeInjectivityAnn injectivity return (FamilyDecl { fdInfo = info', fdLName = lname'- , fdTyVars = ltyvars', fdKindSig = tckind' })+ , fdTyVars = ltyvars', fdResultSig = result'+ , fdInjectivityAnn = injectivity' }) ++renamePseudoFamilyDecl :: PseudoFamilyDecl Name+ -> RnM (PseudoFamilyDecl DocName)+renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl+ <$> renameFamilyInfo pfdInfo+ <*> renameL pfdLName+ <*> mapM renameLType pfdTyVars+ <*> renameFamilyResultSig pfdKindSig++ renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns)- = do { eqns' <- mapM renameLTyFamInstEqn eqns+ = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns ; return $ ClosedTypeFamily eqns' } renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)@@ -364,17 +415,16 @@ , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) renameCon :: ConDecl Name -> RnM (ConDecl DocName)-renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars- , con_cxt = lcontext, con_details = details- , con_res = restype, con_doc = mbldoc }) = do- lnames' <- mapM renameL lnames- ltyvars' <- renameLTyVarBndrs ltyvars- lcontext' <- renameLContext lcontext+renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars+ , con_cxt = lcontext, con_details = details+ , con_doc = mbldoc }) = do+ lname' <- renameL lname+ ltyvars' <- traverse renameLHsQTyVars ltyvars+ lcontext' <- traverse renameLContext lcontext details' <- renameDetails details- restype' <- renameResType restype mbldoc' <- mapM renameLDocHsSyn mbldoc- return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext'- , con_details = details', con_res = restype', con_doc = mbldoc' })+ return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'+ , con_details = details', con_doc = mbldoc' }) where renameDetails (RecCon (L l fields)) = do@@ -386,35 +436,47 @@ b' <- renameLType b return (InfixCon a' b') - renameResType (ResTyH98) = return ResTyH98- renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t-+renameCon decl@(ConDeclGADT { con_names = lnames+ , con_type = lty+ , con_doc = mbldoc }) = do+ lnames' <- mapM renameL lnames+ lty' <- renameLSigType lty+ mbldoc' <- mapM renameLDocHsSyn mbldoc+ return (decl { con_names = lnames'+ , con_type = lty', con_doc = mbldoc' }) renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) renameConDeclFieldField (L l (ConDeclField names t doc)) = do- names' <- mapM renameL names+ names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc return $ L l (ConDeclField names' t' doc') +renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName)+renameLFieldOcc (L l (FieldOcc lbl sel)) = do+ sel' <- rename sel+ return $ L l (FieldOcc lbl sel') renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of- TypeSig lnames ltype _ -> do+ TypeSig lnames ltype -> do lnames' <- mapM renameL lnames- ltype' <- renameLType ltype- return (TypeSig lnames' ltype' PlaceHolder)- PatSynSig lname (flag, qtvs) lreq lprov lty -> do+ ltype' <- renameLSigWcType ltype+ return (TypeSig lnames' ltype')+ ClassOpSig is_default lnames sig_ty -> do+ lnames' <- mapM renameL lnames+ ltype' <- renameLSigType sig_ty+ return (ClassOpSig is_default lnames' ltype')+ PatSynSig lname sig_ty -> do lname' <- renameL lname- qtvs' <- renameLTyVarBndrs qtvs- lreq' <- renameLContext lreq- lprov' <- renameLContext lprov- lty' <- renameLType lty- return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty'+ sig_ty' <- renameLSigType sig_ty+ return $ PatSynSig lname' sig_ty' FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig (FixitySig lnames' fixity)- MinimalSig src s -> MinimalSig src <$> traverse renameL s+ MinimalSig src (L l s) -> do+ s' <- traverse renameL s+ return $ MinimalSig src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" @@ -422,11 +484,11 @@ renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname- ltype' <- renameLType ltype+ ltype' <- renameLSigType ltype return (ForeignImport lname' ltype' co x) renameForD (ForeignExport lname ltype co x) = do lname' <- renameL lname- ltype' <- renameLType ltype+ ltype' <- renameLSigType ltype return (ForeignExport lname' ltype' co x) @@ -445,7 +507,7 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs , cid_datafam_insts = lADTs }) = do- ltype' <- renameLType ltype+ ltype' <- renameLSigType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs return (ClsInstDecl { cid_overlap_mode = omode@@ -461,33 +523,55 @@ , tfid_fvs = placeHolderNames }) } renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName)-renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs }))+renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs })) = do { tc' <- renameL tc- ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)+ ; pats' <- renameImplicit (mapM renameLType) pats ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc'- , tfe_pats = HsWB pats' PlaceHolder PlaceHolder PlaceHolder+ , tfe_pats = pats' , tfe_rhs = rhs' })) } renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs }))- = do { tc' <- renameL tc- ; tvs' <- renameLTyVarBndrs tvs+ = do { tc' <- renameL tc+ ; tvs' <- renameLHsQTyVars tvs ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = tvs' , tfe_rhs = rhs' })) } renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)-renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn })+renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn }) = do { tc' <- renameL tc- ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)+ ; pats' <- renameImplicit (mapM renameLType) pats ; defn' <- renameDataDefn defn ; return (DataFamInstDecl { dfid_tycon = tc'- , dfid_pats- = HsWB pats' PlaceHolder PlaceHolder PlaceHolder+ , dfid_pats = pats' , dfid_defn = defn', dfid_fvs = placeHolderNames }) } +renameImplicit :: (in_thing -> RnM out_thing)+ -> HsImplicitBndrs Name in_thing+ -> RnM (HsImplicitBndrs DocName out_thing)+renameImplicit rn_thing (HsIB { hsib_body = thing })+ = do { thing' <- rn_thing thing+ ; return (HsIB { hsib_body = thing'+ , hsib_vars = PlaceHolder }) }++renameWc :: (in_thing -> RnM out_thing)+ -> HsWildCardBndrs Name in_thing+ -> RnM (HsWildCardBndrs DocName out_thing)+renameWc rn_thing (HsWC { hswc_body = thing })+ = do { thing' <- rn_thing thing+ ; return (HsWC { hswc_body = thing'+ , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) }++renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName)+renameDocInstance (inst, idoc, L l n) = do+ inst' <- renameInstHead inst+ n' <- rename n+ idoc' <- mapM renameDoc idoc+ return (inst', idoc',L l n')+ renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of ExportModule mdl -> return (ExportModule mdl)@@ -498,11 +582,7 @@ decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs- instances' <- forM instances $ \(inst, idoc, L l n) -> do- inst' <- renameInstHead inst- n' <- rename n- idoc' <- mapM renameDoc idoc- return (inst', idoc',L l n')+ instances' <- forM instances renameDocInstance fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity)@@ -521,12 +601,3 @@ n' <- rename n doc' <- renameDocForDecl doc return (n', doc')--type instance PostRn DocName NameSet = PlaceHolder-type instance PostRn DocName Fixity = PlaceHolder-type instance PostRn DocName Bool = PlaceHolder-type instance PostRn DocName [Name] = PlaceHolder--type instance PostTc DocName Kind = PlaceHolder-type instance PostTc DocName Type = PlaceHolder-type instance PostTc DocName Coercion = PlaceHolder
+ src/Haddock/Interface/Specialize.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+++module Haddock.Interface.Specialize+ ( specializeInstHead+ ) where+++import Haddock.Syb+import Haddock.Types++import GHC+import Name+import FastString++import Control.Monad+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State++import Data.Data+import qualified Data.List as List+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+++-- | Instantiate all occurrences of given name with particular type.+specialize :: (Eq name, Typeable name)+ => Data a+ => name -> HsType name -> a -> a+specialize name details =+ everywhere $ mkT step+ where+ step (HsTyVar (L _ name')) | name == name' = details+ step typ = typ+++-- | Instantiate all occurrences of given names with corresponding types.+--+-- It is just a convenience function wrapping 'specialize' that supports more+-- that one specialization.+specialize' :: (Eq name, Typeable name)+ => Data a+ => [(name, HsType name)] -> a -> a+specialize' = flip $ foldr (uncurry specialize)+++-- | Instantiate given binders with corresponding types.+--+-- Again, it is just a convenience function around 'specialize'. Note that+-- length of type list should be the same as the number of binders.+specializeTyVarBndrs :: (Eq name, DataId name)+ => Data a+ => LHsQTyVars name -> [HsType name]+ -> a -> a+specializeTyVarBndrs bndrs typs =+ specialize' $ zip bndrs' typs+ where+ bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs+ bname (UserTyVar (L _ name)) = name+ bname (KindedTyVar (L _ name) _) = name+++specializePseudoFamilyDecl :: (Eq name, DataId name)+ => LHsQTyVars name -> [HsType name]+ -> PseudoFamilyDecl name+ -> PseudoFamilyDecl name+specializePseudoFamilyDecl bndrs typs decl =+ decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) }+ where+ specializeTyVars = specializeTyVarBndrs bndrs typs+++specializeSig :: forall name . (Eq name, DataId name, SetName name)+ => LHsQTyVars name -> [HsType name]+ -> Sig name+ -> Sig name+specializeSig bndrs typs (TypeSig lnames typ) =+ TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}})+ where+ true_type :: HsType name+ true_type = unLoc (hswc_body (hsib_body typ))+ typ' :: HsType name+ typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type+ fv = foldr Set.union Set.empty . map freeVariables $ typs+specializeSig _ _ sig = sig+++-- | Make all details of instance head (signatures, associated types)+-- specialized to that particular instance type.+specializeInstHead :: (Eq name, DataId name, SetName name)+ => InstHead name -> InstHead name+specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =+ ihd { ihdInstType = instType' }+ where+ instType' = clsi+ { clsiSigs = map specializeSig' clsiSigs+ , clsiAssocTys = map specializeFamilyDecl' clsiAssocTys+ }+ specializeSig' = specializeSig clsiTyVars ihdTypes+ specializeFamilyDecl' = specializePseudoFamilyDecl clsiTyVars ihdTypes+specializeInstHead ihd = ihd+++-- | Make given type use tuple and list literals where appropriate.+--+-- After applying 'specialize' function some terms may not use idiomatic list+-- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This+-- can be fixed using 'sugar' function, that will turn such types into @[a]@+-- and @(a, b, c)@.+sugar :: forall name. (NamedThing name, DataId name)+ => HsType name -> HsType name+sugar =+ everywhere $ mkT step+ where+ step :: HsType name -> HsType name+ step = sugarOperators . sugarTuples . sugarLists+++sugarLists :: NamedThing name => HsType name -> HsType name+sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp)+ | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp+ where+ name' = getName name+ strName = occNameString . nameOccName $ name'+sugarLists typ = typ+++sugarTuples :: NamedThing name => HsType name -> HsType name+sugarTuples typ =+ aux [] typ+ where+ aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp+ aux apps (HsParTy (L _ typ')) = aux apps typ'+ aux apps (HsTyVar (L _ name))+ | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps+ where+ name' = getName name+ strName = occNameString . nameOccName $ name'+ suitable = case parseTupleArity strName of+ Just arity -> arity == length apps+ Nothing -> False+ aux _ _ = typ+++sugarOperators :: NamedThing name => HsType name -> HsType name+sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar (L l name))) la)) lb)+ | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb+ | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb+ where+ name' = getName name+sugarOperators typ = typ+++-- | Compute arity of given tuple operator.+--+-- >>> parseTupleArity "(,,)"+-- Just 3+--+-- >>> parseTupleArity "(,,,,)"+-- Just 5+--+-- >>> parseTupleArity "abc"+-- Nothing+--+-- >>> parseTupleArity "()"+-- Nothing+parseTupleArity :: String -> Maybe Int+parseTupleArity ('(':commas) = do+ n <- parseCommas commas+ guard $ n /= 0+ return $ n + 1+ where+ parseCommas (',':rest) = (+ 1) <$> parseCommas rest+ parseCommas ")" = Just 0+ parseCommas _ = Nothing+parseTupleArity _ = Nothing+++-- | Haskell AST type representation.+--+-- This type is used for renaming (more below), essentially the ambiguous (!)+-- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well,+-- it was 'OccName' before, but turned out that 'OccName' sometimes also+-- contains namespace information, differentiating visually same types.+--+-- And 'FastString' is used because it is /visual/ part of 'OccName' - it is+-- not converted to 'String' or alike to avoid new allocations. Additionally,+-- since it is stored mostly in 'Set', fast comparison of 'FastString' is also+-- quite nice.+type NameRep = FastString++getNameRep :: NamedThing name => name -> NameRep+getNameRep = occNameFS . getOccName++nameRepString :: NameRep -> String+nameRepString = unpackFS++stringNameRep :: String -> NameRep+stringNameRep = mkFastString++setInternalNameRep :: SetName name => NameRep -> name -> name+setInternalNameRep = setInternalOccName . mkVarOccFS++setInternalOccName :: SetName name => OccName -> name -> name+setInternalOccName occ name =+ setName nname' name+ where+ nname = getName name+ nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)+++-- | Compute set of free variables of given type.+freeVariables :: forall name. (NamedThing name, DataId name)+ => HsType name -> Set NameRep+freeVariables =+ everythingWithState Set.empty Set.union query+ where+ query term ctx = case cast term :: Maybe (HsType name) of+ Just (HsForAllTy bndrs _) ->+ (Set.empty, Set.union ctx (bndrsNames bndrs))+ Just (HsTyVar (L _ name))+ | getName name `Set.member` ctx -> (Set.empty, ctx)+ | otherwise -> (Set.singleton $ getNameRep name, ctx)+ _ -> (Set.empty, ctx)+ bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)+++-- | Make given type visually unambiguous.+--+-- After applying 'specialize' method, some free type variables may become+-- visually ambiguous - for example, having @a -> b@ and specializing @a@ to+-- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to+-- different type variable than latter one. Applying 'rename' function+-- will fix that type to be visually unambiguous again (making it something+-- like @(a -> c) -> b@).+rename :: SetName name => Set NameRep -> HsType name -> HsType name+rename fv typ = runReader (renameType typ) $ RenameEnv+ { rneFV = fv+ , rneCtx = Map.empty+ }+++-- | Renaming monad.+type Rename name = Reader (RenameEnv name)++-- | Binding generation monad.+type Rebind name = State (RenameEnv name)++data RenameEnv name = RenameEnv+ { rneFV :: Set NameRep+ , rneCtx :: Map Name name+ }+++renameType :: SetName name => HsType name -> Rename name (HsType name)+renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' ->+ HsForAllTy+ <$> pure bndrs'+ <*> renameLType lt+renameType (HsQualTy lctxt lt) =+ HsQualTy+ <$> located renameContext lctxt+ <*> renameLType lt+renameType (HsTyVar name) = HsTyVar <$> located renameName name+renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la+renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr+renameType (HsListTy lt) = HsListTy <$> renameLType lt+renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt+renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt+renameType (HsOpTy la lop lb) =+ HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb+renameType (HsParTy lt) = HsParTy <$> renameLType lt+renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt+renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb+renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk+renameType t@(HsSpliceTy _ _) = pure t+renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc+renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt+renameType t@(HsRecTy _) = pure t+renameType t@(HsCoreTy _) = pure t+renameType (HsExplicitListTy ph ltys) =+ HsExplicitListTy ph <$> renameLTypes ltys+renameType (HsExplicitTupleTy phs ltys) =+ HsExplicitTupleTy phs <$> renameLTypes ltys+renameType t@(HsTyLit _) = pure t+renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)+renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"+++renameLType :: SetName name => LHsType name -> Rename name (LHsType name)+renameLType = located renameType+++renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name]+renameLTypes = mapM renameLType+++renameContext :: SetName name => HsContext name -> Rename name (HsContext name)+renameContext = renameLTypes++{-+renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name)+renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname+-}+++renameName :: SetName name => name -> Rename name name+renameName name = do+ RenameEnv { rneCtx = ctx } <- ask+ pure $ fromMaybe name (Map.lookup (getName name) ctx)+++rebind :: SetName name+ => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a)+ -> Rename name a+rebind lbndrs action = do+ (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask+ local (const env') (action lbndrs')+++rebindLTyVarBndrs :: SetName name+ => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name]+rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs+++rebindTyVarBndr :: SetName name+ => HsTyVarBndr name -> Rebind name (HsTyVarBndr name)+rebindTyVarBndr (UserTyVar (L l name)) =+ UserTyVar . L l <$> rebindName name+rebindTyVarBndr (KindedTyVar name kinds) =+ KindedTyVar <$> located rebindName name <*> pure kinds+++rebindName :: SetName name => name -> Rebind name name+rebindName name = do+ RenameEnv { .. } <- get+ taken <- takenNames+ case Map.lookup (getName name) rneCtx of+ Just name' -> pure name'+ Nothing | getNameRep name `Set.member` taken -> freshName name+ Nothing -> reuseName name+++-- | Generate fresh occurrence name, put it into context and return.+freshName :: SetName name => name -> Rebind name name+freshName name = do+ env@RenameEnv { .. } <- get+ taken <- takenNames+ let name' = setInternalNameRep (findFreshName taken rep) name+ put $ env { rneCtx = Map.insert nname name' rneCtx }+ return name'+ where+ nname = getName name+ rep = getNameRep nname+++reuseName :: SetName name => name -> Rebind name name+reuseName name = do+ env@RenameEnv { .. } <- get+ put $ env { rneCtx = Map.insert (getName name) name rneCtx }+ return name+++takenNames :: NamedThing name => Rebind name (Set NameRep)+takenNames = do+ RenameEnv { .. } <- get+ return $ Set.union rneFV (ctxElems rneCtx)+ where+ ctxElems = Set.fromList . map getNameRep . Map.elems+++findFreshName :: Set NameRep -> NameRep -> NameRep+findFreshName taken =+ fromJust . List.find isFresh . alternativeNames+ where+ isFresh = not . flip Set.member taken+++alternativeNames :: NameRep -> [NameRep]+alternativeNames name+ | [_] <- nameRepString name = letterNames ++ alternativeNames' name+ where+ letterNames = map (stringNameRep . pure) ['a'..'z']+alternativeNames name = alternativeNames' name+++alternativeNames' :: NameRep -> [NameRep]+alternativeNames' name =+ [ stringNameRep $ str ++ show i | i :: Int <- [0..] ]+ where+ str = nameRepString name+++located :: Functor f => (a -> f b) -> Located a -> f (Located b)+located f (L loc e) = L loc <$> f e+++tyVarName :: HsTyVarBndr name -> name+tyVarName (UserTyVar name) = unLoc name+tyVarName (KindedTyVar (L _ name) _) = name
src/Haddock/InterfaceFile.hs view
@@ -14,7 +14,7 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile (- InterfaceFile(..), ifPackageKey,+ InterfaceFile(..), ifUnitId, ifModule, readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where@@ -51,13 +51,19 @@ } -ifPackageKey :: InterfaceFile -> PackageKey-ifPackageKey if_ =+ifModule :: InterfaceFile -> Module+ifModule if_ = case ifInstalledIfaces if_ of [] -> error "empty InterfaceFile"- iface:_ -> modulePackageKey $ instMod iface+ iface:_ -> instMod iface +ifUnitId :: InterfaceFile -> UnitId+ifUnitId if_ =+ case ifInstalledIfaces if_ of+ [] -> error "empty InterfaceFile"+ iface:_ -> moduleUnitId $ instMod iface + binaryInterfaceMagic :: Word32 binaryInterfaceMagic = 0xD0Cface @@ -75,8 +81,8 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16-#if (__GLASGOW_HASKELL__ >= 709) && (__GLASGOW_HASKELL__ < 711)-binaryInterfaceVersion = 27+#if (__GLASGOW_HASKELL__ >= 711) && (__GLASGOW_HASKELL__ < 801)+binaryInterfaceVersion = 28 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]@@ -309,7 +315,7 @@ return (namecache', arr) -type OnDiskName = (PackageKey, ModuleName, OccName)+type OnDiskName = (UnitId, ModuleName, OccName) fromOnDiskName@@ -339,7 +345,7 @@ serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do let modu = nameModule name- put_ bh (modulePackageKey modu, moduleName modu, nameOccName name)+ put_ bh (moduleUnitId modu, moduleName modu, nameOccName name) -------------------------------------------------------------------------------@@ -467,7 +473,6 @@ d <- get bh return $ MetaDoc { _meta = m, _doc = d } -{-* Generated by DrIFT : Look, but Don't Touch. *-} instance (Binary mod, Binary id) => Binary (DocH mod id) where put_ bh DocEmpty = do putByte bh 0@@ -532,6 +537,12 @@ put_ bh (DocHeader aa) = do putByte bh 20 put_ bh aa+ put_ bh (DocMathInline x) = do+ putByte bh 21+ put_ bh x+ put_ bh (DocMathDisplay x) = do+ putByte bh 22+ put_ bh x get bh = do h <- getByte bh@@ -599,6 +610,12 @@ 20 -> do aa <- get bh return (DocHeader aa)+ 21 -> do+ x <- get bh+ return (DocMathInline x)+ 22 -> do+ x <- get bh+ return (DocMathDisplay x) _ -> error "invalid binary data found in the interface file"
src/Haddock/ModuleTree.hs view
@@ -15,7 +15,7 @@ import Haddock.Types ( MDoc ) import GHC ( Name )-import Module ( Module, moduleNameString, moduleName, modulePackageKey, packageKeyString )+import Module ( Module, moduleNameString, moduleName, moduleUnitId, unitIdString ) import DynFlags ( DynFlags ) import Packages ( lookupPackage ) import PackageConfig ( sourcePackageIdString )@@ -28,10 +28,10 @@ mkModuleTree dflags showPkgs mods = foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where- modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_))+ modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_)) | otherwise = Nothing modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString- (lookupPackage dflags (modulePackageKey mod_))+ (lookupPackage dflags (moduleUnitId mod_)) | otherwise = Nothing fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short
src/Haddock/Options.hs view
@@ -21,10 +21,12 @@ optContentsUrl, optIndexUrl, optCssFile,+ optSourceCssFile, sourceUrls, wikiUrls, optDumpInterfaceFile, optLaTeXStyle,+ optMathjax, qualification, verbosity, ghcFlags,@@ -66,6 +68,9 @@ | Flag_WikiEntityURL String | Flag_LaTeX | Flag_LaTeXStyle String+ | Flag_HyperlinkedSource+ | Flag_SourceCss String+ | Flag_Mathjax String | Flag_Help | Flag_Verbosity String | Flag_Version@@ -113,9 +118,14 @@ "output in HTML (XHTML 1.0)", Option [] ["latex"] (NoArg Flag_LaTeX) "use experimental LaTeX rendering", Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE",+ Option [] ["mathjax"] (ReqArg Flag_Mathjax "URL") "URL FOR mathjax", Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", Option [] ["hoogle"] (NoArg Flag_Hoogle) "output for Hoogle; you may want --package-name and --package-version too",+ Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource)+ "generate highlighted and hyperlinked source code (for use with --html)",+ Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE")+ "use custom CSS file instead of default one in hyperlinked source", Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL") "URL for a source code link on the contents\nand index pages", Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"])@@ -239,6 +249,8 @@ optCssFile :: [Flag] -> Maybe FilePath optCssFile flags = optLast [ str | Flag_CSS str <- flags ] +optSourceCssFile :: [Flag] -> Maybe FilePath+optSourceCssFile flags = optLast [ str | Flag_SourceCss str <- flags ] sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String) sourceUrls flags =@@ -261,6 +273,10 @@ optLaTeXStyle :: [Flag] -> Maybe String optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]+++optMathjax :: [Flag] -> Maybe String+optMathjax flags = optLast [ str | Flag_Mathjax str <- flags ] qualification :: [Flag] -> Either String QualOption
+ src/Haddock/Syb.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE Rank2Types #-}+++module Haddock.Syb+ ( everything, everythingWithState, everywhere+ , mkT+ , combine+ ) where+++import Data.Data+import Control.Applicative+++-- | Perform a query on each level of a tree.+--+-- This is stolen directly from SYB package and copied here to not introduce+-- additional dependencies.+everything :: (r -> r -> r) -> (forall a. Data a => a -> r)+ -> (forall a. Data a => a -> r)+everything k f x = foldl k (f x) (gmapQ (everything k f) x)+++-- | Perform a query with state on each level of a tree.+--+-- This is the same as 'everything' but allows for stateful computations. In+-- SYB it is called @everythingWithContext@ but I find this name somewhat+-- nicer.+everythingWithState :: s -> (r -> r -> r)+ -> (forall a. Data a => a -> s -> (r, s))+ -> (forall a. Data a => a -> r)+everythingWithState s k f x =+ let (r, s') = f x s+ in foldl k r (gmapQ (everythingWithState s' k f) x)+++-- | Apply transformation on each level of a tree.+--+-- Just like 'everything', this is stolen from SYB package.+everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a)+everywhere f = f . gmapT (everywhere f)++-- | Create generic transformation.+--+-- Another function stolen from SYB package.+mkT :: (Typeable a, Typeable b) => (b -> b) -> (a -> a)+mkT f = case cast f of+ Just f' -> f'+ Nothing -> id++-- | Combine two queries into one using alternative combinator.+combine :: Alternative f => (forall a. Data a => a -> f r)+ -> (forall a. Data a => a -> f r)+ -> (forall a. Data a => a -> f r)+combine f g x = f x <|> g x
src/Haddock/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- |@@ -27,15 +27,23 @@ import Control.DeepSeq import Data.Typeable import Data.Map (Map)+import Data.Data (Data) import qualified Data.Map as Map import Documentation.Haddock.Types import BasicTypes (Fixity(..))+ import GHC hiding (NoLink)-import DynFlags (ExtensionFlag, Language)+import DynFlags (Language)+import qualified GHC.LanguageExtensions as LangExt+import Coercion+import NameSet import OccName import Outputable+import Control.Applicative (Applicative(..)) import Control.Monad (ap) +import Haddock.Backends.Hyperlinker.Types+ ----------------------------------------------------------------------------- -- * Convenient synonyms -----------------------------------------------------------------------------@@ -49,7 +57,6 @@ type DeclMap = Map Name [LHsDecl Name] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity-type SrcMap = Map PackageKey FilePath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -119,12 +126,20 @@ , ifaceInstances :: ![ClsInst] , ifaceFamInstances :: ![FamInst] + -- | Orphan instances+ , ifaceOrphanInstances :: ![DocInstance Name]+ , ifaceRnOrphanInstances :: ![DocInstance DocName]+ -- | 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) -- | Warnings for things defined in this module. , ifaceWarningMap :: !WarningMap++ -- | Tokenized source code of module (avaliable if Haddock is invoked with+ -- source generation flag).+ , ifaceTokenizedSrc :: !(Maybe [RichToken]) } type WarningMap = Map Name (Doc Name)@@ -253,11 +268,6 @@ noDocForDecl = (Documentation Nothing Nothing, Map.empty) -unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name-unrenameDocForDecl (doc, fnArgsDoc) =- (fmap getName doc, (fmap . fmap) getName fnArgsDoc)-- ----------------------------------------------------------------------------- -- * Cross-referencing -----------------------------------------------------------------------------@@ -266,7 +276,6 @@ -- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module - -- | Extends 'Name' with cross-reference information. data DocName = Documented Name Module@@ -276,36 +285,131 @@ | Undocumented Name -- ^ This thing is not part of the (existing or resulting) -- documentation, as far as Haddock knows.- deriving Eq+ deriving (Eq, Data) +type instance PostRn DocName NameSet = PlaceHolder+type instance PostRn DocName Fixity = PlaceHolder+type instance PostRn DocName Bool = PlaceHolder+type instance PostRn DocName [Name] = PlaceHolder +type instance PostTc DocName Kind = PlaceHolder+type instance PostTc DocName Type = PlaceHolder+type instance PostTc DocName Coercion = PlaceHolder+ instance NamedThing DocName where getName (Documented name _) = name getName (Undocumented name) = name +-- | Useful for debugging+instance Outputable DocName where+ ppr = ppr . getName +instance OutputableBndr DocName where+ pprBndr _ = ppr . getName+ pprPrefixOcc = pprPrefixOcc . getName+ pprInfixOcc = pprInfixOcc . getName++class NamedThing name => SetName name where++ setName :: Name -> name -> name+++instance SetName Name where++ setName name' _ = name'+++instance SetName DocName where++ setName name' (Documented _ mdl) = Documented name' mdl+ setName name' (Undocumented _) = Undocumented name'+++ ----------------------------------------------------------------------------- -- * Instances ----------------------------------------------------------------------------- -- | The three types of instances data InstType name- = ClassInst [HsType name] -- ^ Context+ = ClassInst+ { clsiCtx :: [HsType name]+ , clsiTyVars :: LHsQTyVars name+ , clsiSigs :: [Sig name]+ , clsiAssocTys :: [PseudoFamilyDecl name]+ } | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors instance OutputableBndr a => Outputable (InstType a) where- ppr (ClassInst a) = text "ClassInst" <+> ppr a+ ppr (ClassInst { .. }) = text "ClassInst"+ <+> ppr clsiCtx+ <+> ppr clsiTyVars+ <+> ppr clsiSigs ppr (TypeInst a) = text "TypeInst" <+> ppr a ppr (DataInst a) = text "DataInst" <+> ppr a ++-- | Almost the same as 'FamilyDecl' except for type binders.+--+-- In order to perform type specialization for class instances, we need to+-- substitute class variables to appropriate type. However, type variables in+-- associated type are specified using 'LHsTyVarBndrs' instead of 'HsType'.+-- This makes type substitution impossible and to overcome this issue,+-- 'PseudoFamilyDecl' type is introduced.+data PseudoFamilyDecl name = PseudoFamilyDecl+ { pfdInfo :: FamilyInfo name+ , pfdLName :: Located name+ , pfdTyVars :: [LHsType name]+ , pfdKindSig :: LFamilyResultSig name+ }+++mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name+mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl+ { pfdInfo = fdInfo+ , pfdLName = fdLName+ , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_explicit fdTyVars ]+ , pfdKindSig = fdResultSig+ }+ where+ mkType (KindedTyVar (L loc name) lkind) =+ HsKindSig tvar lkind+ where+ tvar = L loc (HsTyVar (L loc name))+ mkType (UserTyVar name) = HsTyVar name++ -- | An instance head that may have documentation and a source location. type DocInstance name = (InstHead name, Maybe (MDoc name), Located name) -- | The head of an instance. Consists of a class name, a list of kind -- parameters, a list of type parameters and an instance type-type InstHead name = (name, [HsType name], [HsType name], InstType name)+data InstHead name = InstHead+ { ihdClsName :: name+ , ihdKinds :: [HsType name]+ , ihdTypes :: [HsType name]+ , ihdInstType :: InstType name+ } ++-- | An instance origin information.+--+-- This is used primarily in HTML backend to generate unique instance+-- identifiers (for expandable sections).+data InstOrigin name+ = OriginClass name+ | OriginData name+ | OriginFamily name+++instance NamedThing name => NamedThing (InstOrigin name) where++ getName (OriginClass name) = getName name+ getName (OriginData name) = getName name+ getName (OriginFamily name) = getName name++ ----------------------------------------------------------------------------- -- * Documentation comments -----------------------------------------------------------------------------@@ -336,6 +440,8 @@ DocCodeBlock a -> a `deepseq` () DocHyperlink a -> a `deepseq` () DocPic a -> a `deepseq` ()+ DocMathInline a -> a `deepseq` ()+ DocMathDisplay a -> a `deepseq` () DocAName a -> a `deepseq` () DocProperty a -> a `deepseq` () DocExamples a -> a `deepseq` ()@@ -383,6 +489,8 @@ , markupHyperlink :: Hyperlink -> a , markupAName :: String -> a , markupPic :: Picture -> a+ , markupMathInline :: String -> a+ , markupMathDisplay :: String -> a , markupProperty :: String -> a , markupExample :: [Example] -> a , markupHeader :: Header a -> a@@ -398,7 +506,7 @@ , hmi_portability :: Maybe String , hmi_safety :: Maybe String , hmi_language :: Maybe Language- , hmi_extensions :: [ExtensionFlag]+ , hmi_extensions :: [LangExt.Extension] } @@ -421,7 +529,6 @@ ----------------------------------------------------------------------------- -{-! for DocOption derive: Binary !-} -- | Source-level options for controlling the documentation. data DocOption = OptHide -- ^ This module should not appear in the docs.@@ -490,11 +597,11 @@ fmap f (Writer (a, msgs)) = Writer (f a, msgs) instance Applicative ErrMsgM where- pure = return- (<*>) = ap+ pure a = Writer (a, [])+ (<*>) = ap instance Monad ErrMsgM where- return a = Writer (a, [])+ return = pure m >>= k = Writer $ let (a, w) = runWriter m (b, w') = runWriter (k a)@@ -543,10 +650,27 @@ fmap f (WriterGhc x) = WriterGhc (fmap (first f) x) instance Applicative ErrMsgGhc where- pure = return+ pure a = WriterGhc (return (a, [])) (<*>) = ap instance Monad ErrMsgGhc where- return a = WriterGhc (return (a, []))+ return = pure m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> fmap (second (msgs1 ++)) (runWriterGhc (k a))+++-----------------------------------------------------------------------------+-- * Pass sensitive types+-----------------------------------------------------------------------------++type instance PostRn DocName NameSet = PlaceHolder+type instance PostRn DocName Fixity = PlaceHolder+type instance PostRn DocName Bool = PlaceHolder+type instance PostRn DocName Name = DocName+type instance PostRn DocName (Located Name) = Located DocName+type instance PostRn DocName [Name] = PlaceHolder+type instance PostRn DocName DocName = DocName++type instance PostTc DocName Kind = PlaceHolder+type instance PostTc DocName Type = PlaceHolder+type instance PostTc DocName Coercion = PlaceHolder
src/Haddock/Utils.hs view
@@ -16,6 +16,7 @@ -- * Misc utilities restrictTo, emptyHsQTvs, toDescription, toInstalledDescription,+ mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes, -- * Filename utilities moduleHtmlFile, moduleHtmlFile',@@ -63,6 +64,8 @@ import GHC import Name+import NameSet ( emptyNameSet )+import HsTypes (selectorFieldOcc) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )@@ -123,6 +126,34 @@ mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } +mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name+-- Dubious, because the implicit binders are empty even+-- though the type might have free varaiables+mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty)++addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name+-- Add the class context to a class-op signature+addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype))+ = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype))))+ -- The mkEmptySigWcType is suspicious+ where+ go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty }))+ = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty })+ go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))+ = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty })+ go (L loc ty)+ = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })++ extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)+ add_ctxt (L loc preds) = L loc (extra_pred : preds)++addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine++lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name]+lHsQTyVarsToTypes tvs+ = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv)))+ | tv <- hsQTvExplicit tvs ]+ -------------------------------------------------------------------------------- -- * Making abstract declarations --------------------------------------------------------------------------------@@ -150,19 +181,37 @@ restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where- keep d | any (\n -> n `elem` names) (map unLoc $ con_names d) =- case con_details d of+ keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =+ case getConDetails h98d of PrefixCon _ -> Just d RecCon fields | all field_avail (unL fields) -> Just d- | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) })+ | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL fields))) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but -- it's the best we can do. InfixCon _ _ -> Just d where- field_avail (L _ (ConDeclField ns _ _)) = all (\n -> unLoc n `elem` names) ns+ h98d = h98ConDecl d+ h98ConDecl c@ConDeclH98{} = c+ h98ConDecl c@ConDeclGADT{} = c'+ where+ (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c)+ c' :: ConDecl Name+ c' = ConDeclH98+ { con_name = head (con_names c)+ , con_qvars = Just $ HsQTvs { hsq_implicit = mempty+ , hsq_explicit = tvs+ , hsq_dependent = emptyNameSet }+ , con_cxt = Just cxt+ , con_details = details+ , con_doc = con_doc c+ }++ field_avail :: LConDeclField Name -> Bool+ field_avail (L _ (ConDeclField fs _ _))+ = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ = Nothing@@ -174,11 +223,13 @@ restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] -emptyHsQTvs :: LHsTyVarBndrs Name+emptyHsQTvs :: LHsQTyVars Name -- This function is here, rather than in HsTypes, because it *renamed*, but -- does not necessarily have all the rigt kind variables. It is used -- in Haddock just for printing, so it doesn't matter-emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] }+emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs"+ , hsq_explicit = []+ , hsq_dependent = error "haddock:emptyHsQTvs" } --------------------------------------------------------------------------------@@ -430,6 +481,8 @@ markup m (DocHyperlink l) = markupHyperlink m l markup m (DocAName ref) = markupAName m ref markup m (DocPic img) = markupPic m img+markup m (DocMathInline mathjax) = markupMathInline m mathjax+markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax markup m (DocProperty p) = markupProperty m p markup m (DocExamples e) = markupExample m e markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t))@@ -460,6 +513,8 @@ markupHyperlink = DocHyperlink, markupAName = DocAName, markupPic = DocPic,+ markupMathInline = DocMathInline,+ markupMathDisplay = DocMathDisplay, markupProperty = DocProperty, markupExample = DocExamples, markupHeader = DocHeader
src/Haddock/Version.hs view
@@ -9,7 +9,7 @@ -- Stability : experimental -- Portability : portable ------------------------------------------------------------------------------module Haddock.Version ( +module Haddock.Version ( projectName, projectVersion, projectUrl ) where
+ test/Haddock/Backends/Hyperlinker/ParserSpec.hs view
@@ -0,0 +1,98 @@+module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where+++import Test.Hspec+import Test.QuickCheck++import Haddock.Backends.Hyperlinker.Parser+import Haddock.Backends.Hyperlinker.Types+++main :: IO ()+main = hspec spec+++spec :: Spec+spec = do+ describe "parse" parseSpec+++parseSpec :: Spec+parseSpec = do++ it "is total" $+ property $ \src -> length (parse src) `shouldSatisfy` (>= 0)++ it "retains file layout" $+ property $ \src -> concatMap tkValue (parse src) == src++ context "when parsing single-line comments" $ do++ it "should ignore content until the end of line" $+ "-- some very simple comment\nidentifier"+ `shouldParseTo`+ [TkComment, TkSpace, TkIdentifier]++ it "should allow endline escaping" $+ "-- first line\\\nsecond line\\\nand another one"+ `shouldParseTo`+ [TkComment]++ context "when parsing multi-line comments" $ do++ it "should support nested comments" $+ "{- comment {- nested -} still comment -} {- next comment -}"+ `shouldParseTo`+ [TkComment, TkSpace, TkComment]++ it "should distinguish compiler pragma" $+ "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}"+ `shouldParseTo`+ [TkComment, TkPragma, TkComment]++ it "should recognize preprocessor directives" $ do+ "\n#define foo bar" `shouldParseTo` [TkSpace, TkCpp]+ "x # y" `shouldParseTo`+ [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier]++ it "should distinguish basic language constructs" $ do+ "(* 2) <$> (\"abc\", foo)" `shouldParseTo`+ [ TkSpecial, TkOperator, TkSpace, TkNumber, TkSpecial+ , TkSpace, TkOperator, TkSpace+ , TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial+ ]+ "let foo' = foo in foo' + foo'" `shouldParseTo`+ [ TkKeyword, TkSpace, TkIdentifier+ , TkSpace, TkGlyph, TkSpace+ , TkIdentifier, TkSpace, TkKeyword, TkSpace+ , TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier+ ]+ "square x = y^2 where y = x" `shouldParseTo`+ [ TkIdentifier, TkSpace, TkIdentifier+ , TkSpace, TkGlyph, TkSpace+ , TkIdentifier, TkOperator, TkNumber+ , TkSpace, TkKeyword, TkSpace+ , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier+ ]++ it "should parse do-notation syntax" $ do+ "do { foo <- getLine; putStrLn foo }" `shouldParseTo`+ [ TkKeyword, TkSpace, TkSpecial, TkSpace+ , TkIdentifier, TkSpace, TkGlyph, TkSpace+ , TkIdentifier, TkSpecial, TkSpace+ , TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial+ ]++ unlines+ [ "do"+ , " foo <- getLine"+ , " putStrLn foo"+ ] `shouldParseTo`+ [ TkKeyword, TkSpace, TkIdentifier+ , TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace+ , TkIdentifier, TkSpace, TkIdentifier, TkSpace+ ]+++shouldParseTo :: String -> [TokenType] -> Expectation+str `shouldParseTo` tokens = map tkType (parse str) `shouldBe` tokens
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}