diff options
Diffstat (limited to 'haddock-api/src')
20 files changed, 314 insertions, 116 deletions
diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs index e5d84796..1aa666ce 100644 --- a/haddock-api/src/Documentation/Haddock.hs +++ b/haddock-api/src/Documentation/Haddock.hs @@ -8,7 +8,7 @@ -- Stability : experimental -- Portability : portable -- --- The Haddock API: A rudimentory, highly experimental API exposing some of +-- The Haddock API: A rudimentary, highly experimental API exposing some of -- the internals of Haddock. Don't expect it to be stable. ----------------------------------------------------------------------------- module Documentation.Haddock ( diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 942798eb..989ca03f 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -197,17 +198,23 @@ haddockWithGhc ghc args = handleTopExceptions $ do forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do name_cache <- freshNameCache - mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), path)] noChecks - forM_ mIfaceFile $ \(_,_, ifaceFile) -> do + mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), Visible, path)] noChecks + forM_ mIfaceFile $ \(_,_,_, ifaceFile) -> do putMsg logger $ renderJson (jsonInterfaceFile ifaceFile) if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files + let packageInfo = PackageInfo { piPackageName = + fromMaybe (PackageName mempty) (optPackageName flags) + , piPackageVersion = + fromMaybe (makeVersion []) (optPackageVersion flags) + } -- Dump an "interface file" (.haddock file), if requested. forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do writeInterfaceFile path InterfaceFile { ifInstalledIfaces = map toInstalledIface ifaces + , ifPackageInfo = packageInfo , ifLinkEnv = homeLinks } @@ -259,7 +266,7 @@ withGhc flags action = do readPackagesAndProcessModules :: [Flag] -> [String] - -> Ghc ([(DocPaths, FilePath, InterfaceFile)], [Interface], LinkEnv) + -> Ghc ([(DocPaths, Visibility, FilePath, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do -- Get packages supplied with --read-interface. let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags @@ -267,28 +274,28 @@ readPackagesAndProcessModules flags files = do packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks -- Create the interfaces -- this is the core part of Haddock. - let ifaceFiles = map (\(_, _, ifaceFile) -> ifaceFile) packages + let ifaceFiles = map (\(_, _, _, ifaceFile) -> ifaceFile) packages (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles return (packages, ifaces, homeLinks) renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption - -> [(DocPaths, FilePath, InterfaceFile)] -> [Interface] -> IO () + -> [(DocPaths, Visibility, FilePath, InterfaceFile)] -> [Interface] -> IO () renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do - updateHTMLXRefs (map (\(docPath, _ifaceFilePath, ifaceFile) -> + updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) -> ( case baseUrl flags of Nothing -> fst docPath Just url -> url </> packageName (ifUnitId ifaceFile) , ifaceFile)) pkgs) let installedIfaces = - concatMap - (\(_, ifaceFilePath, ifaceFile) - -> (ifaceFilePath,) <$> ifInstalledIfaces ifaceFile) + map + (\(_, showModules, ifaceFilePath, ifaceFile) + -> (ifaceFilePath, mkPackageInterfaces showModules ifaceFile)) pkgs extSrcMap = Map.fromList $ do - ((_, Just path), _, ifile) <- pkgs + ((_, Just path), _, _, ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap @@ -302,10 +309,16 @@ renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = d -- | Render the interfaces with whatever backend is specified in the flags. render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface] - -> [(FilePath, InstalledInterface)] -> Map Module FilePath -> IO () -render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do + -> [(FilePath, PackageInterfaces)] -> Map Module FilePath -> IO () +render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = do let + packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty) + $ optPackageName flags + , piPackageVersion = fromMaybe (makeVersion []) + $ optPackageVersion flags + } + title = fromMaybe "" (optTitle flags) unicode = Flag_UseUnicode `elem` flags pretty = Flag_PrettyHtml `elem` flags @@ -324,9 +337,32 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] - -- /All/ visible interfaces including external package modules. - allIfaces = map toInstalledIface ifaces ++ map snd installedIfaces - allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] + -- /All/ interfaces including external package modules, grouped by + -- interface file (package). + allPackages :: [PackageInterfaces] + allPackages = [PackageInterfaces + { piPackageInfo = packageInfo + , piVisibility = Visible + , piInstalledInterfaces = map toInstalledIface ifaces + }] + ++ map snd packages + + -- /All/ visible interfaces including external package modules, grouped by + -- interface file (package). + allVisiblePackages :: [PackageInterfaces] + allVisiblePackages = [ pinfo { piInstalledInterfaces = + filter (\i -> OptHide `notElem` instOptions i) + piInstalledInterfaces + } + | pinfo@PackageInterfaces + { piVisibility = Visible + , piInstalledInterfaces + } <- allPackages + ] + + -- /All/ installed interfaces. + allInstalledIfaces :: [InstalledInterface] + allInstalledIfaces = concatMap (piInstalledInterfaces . snd) packages pkgMod = fmap ifaceMod (listToMaybe ifaces) pkgKey = fmap moduleUnit pkgMod @@ -370,7 +406,7 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') installedMap :: Map Module InstalledInterface - installedMap = Map.fromList [ (unwire (instMod iface), iface) | (_, iface) <- installedIfaces ] + installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- allInstalledIfaces ] -- The user gives use base-4.9.0.0, but the InstalledInterface -- records the *wired in* identity base. So untranslate it @@ -406,7 +442,8 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc _ <- {-# SCC ppHtmlIndex #-} ppHtmlIndex odir title pkgStr themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls - allVisibleIfaces pretty + withQuickjump + (concatMap piInstalledInterfaces allVisiblePackages) pretty return () unless withBaseURL $ @@ -417,7 +454,8 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc _ <- {-# SCC ppHtmlContents #-} ppHtmlContents unit_state odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls - allVisibleIfaces True prologue pretty + withQuickjump + allVisiblePackages True prologue pretty sincePkg (makeContentsQual qual) return () copyHtmlBits odir libDir themes withQuickjump @@ -426,7 +464,10 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc ppJsonIndex odir sourceUrls' opt_wiki_urls unicode Nothing qual ifaces - (nub $ map fst installedIfaces) + ( nub + . map fst + . filter ((== Visible) . piVisibility . snd) + $ packages) when (Flag_Html `elem` flags) $ do withTiming logger "ppHtml" (const ()) $ do @@ -434,8 +475,8 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir prologue themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url - opt_contents_url opt_index_url unicode sincePkg qual - pretty withQuickjump + opt_contents_url opt_index_url unicode sincePkg packageInfo + qual pretty withQuickjump return () unless withBaseURL $ do copyHtmlBits odir libDir themes withQuickjump @@ -484,21 +525,21 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc readInterfaceFiles :: NameCache - -> [(DocPaths, FilePath)] + -> [(DocPaths, Visibility, FilePath)] -> Bool - -> IO [(DocPaths, FilePath, InterfaceFile)] -readInterfaceFiles name_cache pairs bypass_version_check = do + -> IO [(DocPaths, Visibility, FilePath, InterfaceFile)] +readInterfaceFiles name_cache_accessor pairs bypass_version_check = do catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs where -- try to read an interface, warn if we can't - tryReadIface (paths, file) = - readInterfaceFile name_cache file bypass_version_check >>= \case + tryReadIface (paths, vis, file) = + readInterfaceFile name_cache_accessor file bypass_version_check >>= \case Left err -> do putStrLn ("Warning: Cannot read " ++ file ++ ":") putStrLn (" " ++ err) putStrLn "Skipping this interface." return Nothing - Right f -> return (Just (paths, file, f)) + Right f -> return (Just (paths, vis, file, f)) ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 221580cc..582c535d 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -353,7 +353,7 @@ markupTag dflags = Markup { markupMathInline = const $ str "<math>", markupMathDisplay = const $ str "<math>", markupUnorderedList = box (TagL 'u'), - markupOrderedList = box (TagL 'o'), + markupOrderedList = box (TagL 'o') . map snd, markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), markupCodeBlock = box TagPre, markupHyperlink = \(Hyperlink url mLabel) -> box (TagInline "a") (fromMaybe (str url) mLabel), diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index d77990d1..7fa5a443 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,6 +1,5 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} @@ -142,8 +141,8 @@ richToken srcs details Token{..} contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details - -- pick an arbitary non-evidence identifier to hyperlink with - identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers $ details + -- pick an arbitrary non-evidence identifier to hyperlink with + identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers details notEvidence = not . any isEvidenceContext . identInfo -- If we have name information, we can make links diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 349c6e8e..faa23d6a 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1265,7 +1265,7 @@ latexMarkup = Markup , markupPic = \p _ -> inlineElem (markupPic p) , markupMathInline = \p _ -> inlineElem (markupMathInline p) , markupMathDisplay = \p _ -> blockElem (markupMathDisplay p) - , markupOrderedList = \p v -> blockElem (enumeratedList (map (\p' -> p' v empty) p)) + , markupOrderedList = \p v -> blockElem (enumeratedList (map (\(_, p') -> p' v empty) p)) , markupDefList = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l)) , markupCodeBlock = \p _ -> blockElem (quote (verb (p Verb empty))) , markupHyperlink = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l)) @@ -1301,7 +1301,7 @@ latexMarkup = Markup Just label -> text "\\href" <> braces (text url) <> braces label Nothing -> text "\\url" <> braces (text url) - -- Is there a better way of doing this? Just a space is an aribtrary choice. + -- Is there a better way of doing this? Just a space is an arbitrary choice. markupPic (Picture uri title) = parens (imageText title) where imageText Nothing = beg @@ -1333,7 +1333,7 @@ rdrDocToLaTeX doc = markup latexMarkup doc Plain empty data StringContext = Plain -- ^ all special characters have to be escape - | Mono -- ^ on top of special characters, escape space chraacters + | Mono -- ^ on top of special characters, escape space characters | Verb -- ^ don't escape anything @@ -1394,7 +1394,7 @@ bold ltx = text "\\textbf" <> braces ltx -- TODO: @verbatim@ is too much since -- --- * Haddock supports markup _inside_ of codeblocks. Right now, the LaTeX +-- * Haddock supports markup _inside_ of code blocks. Right now, the LaTeX -- representing that markup gets printed verbatim -- * Verbatim environments are not supported everywhere (example: not nested -- inside a @tabulary@ environment) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index b7674b24..4cc6aa77 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -28,7 +28,9 @@ import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Themes import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils +import Haddock.InterfaceFile (PackageInfo (..), PackageInterfaces (..), ppPackageInfo) import Haddock.ModuleTree +import Haddock.Options (Visibility (..)) import Haddock.Types import Haddock.Version import Haddock.Utils @@ -78,6 +80,7 @@ ppHtml :: UnitState -> Maybe String -- ^ The index URL (--use-index) -> Bool -- ^ Whether to use unicode in output (--use-unicode) -> Maybe String -- ^ Package name + -> PackageInfo -- ^ Package info -> QualOption -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) -> Bool -- ^ Also write Quickjump index @@ -86,7 +89,7 @@ ppHtml :: UnitState ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url maybe_contents_url maybe_index_url unicode - pkg qual debug withQuickjump = do + pkg packageInfo qual debug withQuickjump = do let visible_ifaces = filter visible ifaces visible i = OptHide `notElem` ifaceOptions i @@ -94,13 +97,20 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue when (isNothing maybe_contents_url) $ ppHtmlContents state odir doctitle maybe_package themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url - (map toInstalledIface visible_ifaces ++ reexported_ifaces) + withQuickjump + [PackageInterfaces + { piPackageInfo = packageInfo + , piVisibility = Visible + , piInstalledInterfaces = map toInstalledIface visible_ifaces + ++ reexported_ifaces + }] False -- we don't want to display the packages in a single-package contents prologue debug pkg (makeContentsQual qual) when (isNothing maybe_index_url) $ do ppHtmlIndex odir doctitle maybe_package themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url + withQuickjump (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug when withQuickjump $ @@ -109,7 +119,8 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue mapM_ (ppHtmlModule odir doctitle themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url - maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces + maybe_contents_url maybe_index_url withQuickjump + unicode pkg qual debug) visible_ifaces copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO () @@ -155,6 +166,15 @@ headHtml docTitle themes mathjax_url base_url = , "}" , "});" ] +quickJumpButtonLi :: Bool -- ^ With Quick Jump? + -> Maybe Html +-- The TypeScript should replace this <li> element, given its id. However, in +-- case it does not, the element is given content here too. +quickJumpButtonLi True = Just $ li ! [identifier "quick-jump-button"] + << anchor ! [href "#"] << "Quick Jump" + +quickJumpButtonLi False = Nothing + srcButton :: SourceURLs -> Maybe Interface -> Maybe Html srcButton (Just src_base_url, _, _, _) Nothing = Just (anchor ! [href src_base_url] << "Source") @@ -193,20 +213,18 @@ indexButton maybe_index_url bodyHtml :: String -> Maybe Interface -> SourceURLs -> WikiURLs -> Maybe String -> Maybe String + -> Bool -- ^ With Quick Jump? -> Html -> Html bodyHtml doctitle iface maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url + withQuickjump pageContent = body << [ divPackageHeader << [ nonEmptySectionName << doctitle, - unordList (catMaybes [ - srcButton maybe_source_url iface, - wikiButton maybe_wiki_url (ifaceMod <$> iface), - contentsButton maybe_contents_url, - indexButton maybe_index_url]) - ! [theclass "links", identifier "page-menu"] + ulist ! [theclass "links", identifier "page-menu"] + << catMaybes (quickJumpButtonLi withQuickjump : otherButtonLis) ], divContent << pageContent, divFooter << paragraph << ( @@ -215,6 +233,13 @@ bodyHtml doctitle iface (" version " ++ projectVersion) ) ] + where + otherButtonLis = (fmap . fmap) (li <<) + [ srcButton maybe_source_url iface + , wikiButton maybe_wiki_url (ifaceMod <$> iface) + , contentsButton maybe_contents_url + , indexButton maybe_index_url + ] moduleInfo :: Interface -> Html moduleInfo iface = @@ -277,30 +302,44 @@ ppHtmlContents -> Maybe String -> SourceURLs -> WikiURLs - -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName) + -> Bool -- ^ With Quick Jump? + -> [PackageInterfaces] -> Bool -> Maybe (MDoc GHC.RdrName) -> Bool -> Maybe Package -- ^ Current package -> Qualification -- ^ How to qualify names -> IO () ppHtmlContents state odir doctitle _maybe_package themes mathjax_url maybe_index_url - maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do - let tree = mkModuleTree state showPkgs - [(instMod iface, toInstalledDescription iface) - | iface <- ifaces - , not (instIsSig iface)] - sig_tree = mkModuleTree state showPkgs - [(instMod iface, toInstalledDescription iface) - | iface <- ifaces - , instIsSig iface] + maybe_source_url maybe_wiki_url withQuickjump + packages showPkgs prologue debug pkg qual = do + let trees = + [ ( piPackageInfo pinfo + , mkModuleTree state showPkgs + [(instMod iface, toInstalledDescription iface) + | iface <- piInstalledInterfaces pinfo + , not (instIsSig iface) + ] + ) + | pinfo <- packages + ] + sig_trees = + [ ( piPackageInfo pinfo + , mkModuleTree state showPkgs + [(instMod iface, toInstalledDescription iface) + | iface <- piInstalledInterfaces pinfo + , instIsSig iface + ] + ) + | pinfo <- packages + ] html = headHtml doctitle themes mathjax_url Nothing +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url - Nothing maybe_index_url << [ + Nothing maybe_index_url withQuickjump << [ ppPrologue pkg qual doctitle prologue, - ppSignatureTree pkg qual sig_tree, - ppModuleTree pkg qual tree + ppSignatureTrees pkg qual sig_trees, + ppModuleTrees pkg qual trees ] createDirectoryIfMissing True odir writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html) @@ -315,17 +354,37 @@ ppPrologue _ _ _ Nothing = noHtml ppPrologue pkg qual title (Just doc) = divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc)) - -ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html -ppSignatureTree _ _ [] = mempty -ppSignatureTree pkg qual ts = - divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts) - - -ppModuleTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html -ppModuleTree _ _ [] = mempty -ppModuleTree pkg qual ts = - divModuleList << (sectionName << "Modules" +++ mkNodeList pkg qual [] "n" ts) +ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html +ppSignatureTrees _ _ tss | all (null . snd) tss = mempty +ppSignatureTrees pkg qual [(info, ts)] = + divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts) +ppSignatureTrees pkg qual tss = + divModuleList << + (sectionName << "Signatures" + +++ concatHtml [ ppSignatureTree pkg qual("n."++show i++".") info ts + | (i, (info, ts)) <- zip [(1::Int)..] tss + ]) + +ppSignatureTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html +ppSignatureTree _ _ _ _ [] = mempty +ppSignatureTree pkg qual p info ts = + divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts) + +ppModuleTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html +ppModuleTrees _ _ tss | all (null . snd) tss = mempty +ppModuleTrees pkg qual [(info, ts)] = + divModuleList << (sectionName << "Modules" +++ ppModuleTree pkg qual "n" info ts) +ppModuleTrees pkg qual tss = + divPackageList << + (sectionName << "Packages" + +++ concatHtml [ppModuleTree pkg qual ("n."++show i++".") info ts + | (i, (info, ts)) <- zip [(1::Int)..] tss + ]) + +ppModuleTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html +ppModuleTree _ _ _ _ [] = mempty +ppModuleTree pkg qual p info ts = + divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts) mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html @@ -418,11 +477,16 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins (errors, installedIndexes) <- partitionEithers <$> traverse - (\ifaceFile -> + (\ifaceFile -> do let indexFile = takeDirectory ifaceFile - FilePath.</> "doc-index.json" in - bimap (indexFile,) (map (fixLink ifaceFile)) - <$> eitherDecodeFile @[JsonIndexEntry] indexFile) + FilePath.</> "doc-index.json" + a <- doesFileExist indexFile + if a then + bimap (indexFile,) (map (fixLink ifaceFile)) + <$> eitherDecodeFile @[JsonIndexEntry] indexFile + else + return (Right []) + ) installedIfacesPaths traverse_ (\(indexFile, err) -> putStrLn $ "haddock: Coudn't parse " ++ indexFile ++ ": " ++ err) errors @@ -486,11 +550,12 @@ ppHtmlIndex :: FilePath -> Maybe String -> SourceURLs -> WikiURLs + -> Bool -- ^ With Quick Jump? -> [InstalledInterface] -> Bool -> IO () ppHtmlIndex odir doctitle _maybe_package themes - maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do + maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url withQuickjump ifaces debug = do let html = indexPage split_indices Nothing (if split_indices then [] else index) @@ -509,7 +574,7 @@ ppHtmlIndex odir doctitle _maybe_package themes headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url - maybe_contents_url Nothing << [ + maybe_contents_url Nothing withQuickjump << [ if showLetters then indexInitialLetterLinks else noHtml, if null items then noHtml else divIndex << [sectionName << indexName ch, buildIndex items] @@ -607,11 +672,14 @@ ppHtmlIndex odir doctitle _maybe_package themes ppHtmlModule :: FilePath -> String -> Themes -> Maybe String -> SourceURLs -> WikiURLs -> BaseURL - -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption + -> Maybe String -> Maybe String + -> Bool -- ^ With Quick Jump? + -> Bool -> Maybe Package -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url - maybe_contents_url maybe_index_url unicode pkg qual debug iface = do + maybe_contents_url maybe_index_url withQuickjump + unicode pkg qual debug iface = do let mdl = ifaceMod iface aliases = ifaceModuleAliases iface @@ -631,7 +699,7 @@ ppHtmlModule odir doctitle themes headHtml mdl_str_annot themes maybe_mathjax_url maybe_base_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url << [ + maybe_contents_url maybe_index_url withQuickjump << [ divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)), ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual ] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index a54bb0aa..3dea1012 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -727,7 +727,7 @@ ppInstanceSigs links splice unicode qual sigs = do L _ rtyp = dropWildCards typ -- Instance methods signatures are synified and thus don't have a useful -- SrcSpan value. Use the methods name location instead. - return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head $ lnames) names rtyp + return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head lnames) names rtyp lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index b8f5ac0f..91a5b120 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -46,7 +46,7 @@ parHtmlMarkup qual insertAnchors ppId = Markup { markupIdentifierUnchecked = thecode . ppUncheckedLink qual, markupModule = \(ModLink m lbl) -> let (mdl,ref) = break (=='#') m - -- Accomodate for old style + -- Accommodate for old style -- foo\#bar anchors mdl' = case reverse mdl of '\\':_ -> init mdl @@ -57,7 +57,7 @@ parHtmlMarkup qual insertAnchors ppId = Markup { markupBold = strong, markupMonospaced = thecode, markupUnorderedList = unordList, - markupOrderedList = ordList, + markupOrderedList = makeOrdList, markupDefList = defList, markupCodeBlock = pre, markupHyperlink = \(Hyperlink url mLabel) @@ -112,9 +112,12 @@ parHtmlMarkup qual insertAnchors ppId = Markup { htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"] htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] + makeOrdList :: HTML a => [(Int, a)] -> Html + makeOrdList items = olist << map (\(index, a) -> li ! [intAttr "value" index] << a) items + -- | We use this intermediate type to transform the input 'Doc' tree -- in an arbitrary way before rendering, such as grouping some --- elements. This is effectivelly a hack to prevent the 'Doc' type +-- elements. This is effectively a hack to prevent the 'Doc' type -- from changing if it is possible to recover the layout information -- we won't need after the fact. data Hack a id = @@ -277,5 +280,5 @@ cleanup = overDoc (markup fmtUnParagraphLists) fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a) fmtUnParagraphLists = idMarkup { markupUnorderedList = DocUnorderedList . map unParagraph, - markupOrderedList = DocOrderedList . map unParagraph + markupOrderedList = DocOrderedList . map (\(index, a) -> (index, unParagraph a)) } diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 8f04a21f..575249ad 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -15,7 +15,7 @@ module Haddock.Backends.Xhtml.Layout ( divPackageHeader, divContent, divModuleHeader, divFooter, divTableOfContents, divDescription, divSynopsis, divInterface, - divIndex, divAlphabet, divModuleList, divContentsList, + divIndex, divAlphabet, divPackageList, divModuleList, divContentsList, sectionName, nonEmptySectionName, @@ -81,7 +81,7 @@ nonEmptySectionName c divPackageHeader, divContent, divModuleHeader, divFooter, divTableOfContents, divDescription, divSynopsis, divInterface, - divIndex, divAlphabet, divModuleList, divContentsList + divIndex, divAlphabet, divPackageList, divModuleList, divContentsList :: Html -> Html divPackageHeader = sectionDiv "package-header" @@ -96,6 +96,7 @@ divInterface = sectionDiv "interface" divIndex = sectionDiv "index" divAlphabet = sectionDiv "alphabet" divModuleList = sectionDiv "module-list" +divPackageList = sectionDiv "module-list" -------------------------------------------------------------------------------- @@ -219,7 +220,7 @@ subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable where wrap = ((h1 << "Orphan instances") +++) instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc pkg qual lnks splice - id_ = makeAnchorId $ "orphans" + id_ = makeAnchorId "orphans" subInstHead :: String -- ^ Instance unique id (for anchor generation) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs index 621bdd41..540885ac 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs @@ -14,7 +14,7 @@ quickjumpVersion = 1 -- | Writes a json encoded file containing additional -- information about the generated documentation. This --- is useful for external tools (e.g. hackage). +-- is useful for external tools (e.g., Hackage). writeHaddockMeta :: FilePath -> Bool -> IO () writeHaddockMeta odir withQuickjump = do let diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 7c1dc73b..6c1719dc 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE BangPatterns, FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} @@ -136,7 +136,7 @@ hsSigTypeI = sig_body . unLoc mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn -- Dubious, because the implicit binders are empty even --- though the type might have free varaiables +-- though the type might have free variables mkEmptySigType lty@(L loc ty) = L loc $ case ty of HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs } , hst_body = body } @@ -472,7 +472,7 @@ instance Parent (ConDecl GhcRn) where instance Parent (TyClDecl GhcRn) where children d | isDataDecl d = map unLoc $ concatMap (getConNames . unLoc) - $ (dd_cons . tcdDataDefn) $ d + $ (dd_cons . tcdDataDefn) d | isClassDecl d = map (unLoc . fdLName . unLoc) (tcdATs d) ++ [ unLoc n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ] @@ -554,7 +554,7 @@ stringBufferFromByteString bs = -- -- /O(1)/ takeStringBuffer :: Int -> StringBuffer -> ByteString -takeStringBuffer !n !(S.StringBuffer fp _ cur) = BS.PS fp cur n +takeStringBuffer !n (S.StringBuffer fp _ cur) = BS.PS fp cur n -- | Return the prefix of the first 'StringBuffer' that /isn't/ in the second -- 'StringBuffer'. **The behavior is undefined if the 'StringBuffers' use diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index dc8afa31..4527360f 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE MagicHash, BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index dbd4a9b2..b832128f 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -9,7 +9,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wwarn #-} @@ -83,7 +82,7 @@ import GHC.Types.Unique.Map newtype IfEnv m = IfEnv { - -- | Lookup names in the enviroment. + -- | Lookup names in the environment. ife_lookup_name :: Name -> m (Maybe TyThing) } @@ -265,7 +264,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do mod_warning <- liftErrMsg (moduleWarning dflags tcg_rdr_env tcg_warns) let - -- Warnings in this module and transitive warnings from dependend modules + -- Warnings in this module and transitive warnings from dependent modules warnings :: Map Name (Doc Name) warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces)) @@ -334,7 +333,7 @@ mkAliasMap state impDecls = M.fromList $ mapMaybe (\(SrcLoc.L _ impDecl) -> do SrcLoc.L _ alias <- ideclAs impDecl - return $ + return (lookupModuleDyn state -- TODO: This is supremely dodgy, because in general the -- UnitId isn't going to look anything like the package diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index 92fb2e75..8b27a982 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -130,8 +130,10 @@ jsonDoc (DocUnorderedList xs) = jsonObject jsonDoc (DocOrderedList xs) = jsonObject [ ("tag", jsonString "DocOrderedList") - , ("documents", jsonArray (fmap jsonDoc xs)) + , ("items", jsonArray (fmap jsonItem xs)) ] + where + jsonItem (index, a) = jsonObject [("document", jsonDoc a), ("seq", jsonInt index)] jsonDoc (DocDefList xys) = jsonObject [ ("tag", jsonString "DocDefList") diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index f3b57792..4e1964af 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -90,6 +90,10 @@ processModuleHeader dflags pkgName gre safety mayStr = do where failure = (emptyHaddockModInfo, Nothing) +traverseSnd :: (Traversable t, Applicative f) => (a -> f b) -> t (x, a) -> f (t (x, b)) +traverseSnd f = traverse (\(x, a) -> + (\b -> (x, b)) <$> f a) + -- | Takes a 'GlobalRdrEnv' which (hopefully) contains all the -- definitions and a parsed comment and we attempt to make sense of -- where the identifiers in the comment point to. We're in effect @@ -152,7 +156,7 @@ rename dflags gre = rn DocBold doc -> DocBold <$> rn doc DocMonospaced doc -> DocMonospaced <$> rn doc DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs - DocOrderedList docs -> DocOrderedList <$> traverse rn docs + DocOrderedList docs -> DocOrderedList <$> traverseSnd rn docs DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list DocCodeBlock doc -> DocCodeBlock <$> rn doc DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x) @@ -173,7 +177,7 @@ rename dflags gre = rn -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently -- we simply monospace the identifier in most cases except when the -- identifier is qualified: if the identifier is qualified then we can --- still try to guess and generate anchors accross modules but the +-- still try to guess and generate anchors across modules but the -- users shouldn't rely on this doing the right thing. See tickets -- #253 and #375 on the confusion this causes depending on which -- default we pick in 'rename'. diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index db5181c6..f9861708 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -15,9 +16,11 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile ( - InterfaceFile(..), ifUnitId, ifModule, - readInterfaceFile, freshNameCache, - writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility + InterfaceFile(..), PackageInfo(..), ifUnitId, ifModule, + PackageInterfaces(..), mkPackageInterfaces, ppPackageInfo, + readInterfaceFile, writeInterfaceFile, + freshNameCache, + binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where @@ -26,9 +29,12 @@ import Haddock.Types import Data.IORef import qualified Data.Map as Map import Data.Map (Map) +import Data.Version import Data.Word +import Text.ParserCombinators.ReadP (readP_to_S) import GHC.Iface.Binary (getWithUserData, putSymbolTable) +import GHC.Unit.State import GHC.Utils.Binary import GHC.Data.FastMutInt import GHC.Data.FastString @@ -37,11 +43,43 @@ import GHC.Types.Name.Cache import GHC.Types.Unique.FM import GHC.Types.Unique +import Haddock.Options (Visibility (..)) + data InterfaceFile = InterfaceFile { ifLinkEnv :: LinkEnv, + -- | Package meta data. Currently it only consist of a package name, which + -- is not read from the interface file, but inferred from its name. + -- + -- issue # + ifPackageInfo :: PackageInfo, ifInstalledIfaces :: [InstalledInterface] } +data PackageInfo = PackageInfo { + piPackageName :: PackageName, + piPackageVersion :: Data.Version.Version +} + +ppPackageInfo :: PackageInfo -> String +ppPackageInfo (PackageInfo name version) | version == makeVersion [] + = unpackFS (unPackageName name) +ppPackageInfo (PackageInfo name version) = unpackFS (unPackageName name) ++ "-" ++ showVersion version + +data PackageInterfaces = PackageInterfaces { + piPackageInfo :: PackageInfo, + piVisibility :: Visibility, + piInstalledInterfaces :: [InstalledInterface] +} + +mkPackageInterfaces :: Visibility -> InterfaceFile -> PackageInterfaces +mkPackageInterfaces piVisibility + InterfaceFile { ifPackageInfo + , ifInstalledIfaces + } = + PackageInterfaces { piPackageInfo = ifPackageInfo + , piVisibility + , piInstalledInterfaces = ifInstalledIfaces + } ifModule :: InterfaceFile -> Module ifModule if_ = @@ -86,7 +124,7 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if MIN_VERSION_ghc(9,4,0) && !MIN_VERSION_ghc(9,5,0) -binaryInterfaceVersion = 40 +binaryInterfaceVersion = 41 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -129,7 +167,7 @@ writeInterfaceFile filename iface = do let bh = setUserData bh0 $ newWriteState (putName bin_symtab) (putName bin_symtab) (putFastString bin_dict) - put_ bh iface + putInterfaceFile_ bh iface -- write the symtab pointer at the front of the file symtab_p <- tellBin bh @@ -240,16 +278,48 @@ instance (Ord k, Binary k, Binary v) => Binary (Map k v) where put_ bh m = put_ bh (Map.toList m) get bh = fmap (Map.fromList) (get bh) +instance Binary PackageInfo where + put_ bh PackageInfo { piPackageName, piPackageVersion } = do + put_ bh (unPackageName piPackageName) + put_ bh (showVersion piPackageVersion) + get bh = do + name <- PackageName <$> get bh + versionString <- get bh + let version = case readP_to_S parseVersion versionString of + [] -> makeVersion [] + vs -> fst (last vs) + return $ PackageInfo name version instance Binary InterfaceFile where - put_ bh (InterfaceFile env ifaces) = do + put_ bh (InterfaceFile env info ifaces) = do put_ bh env + put_ bh info put_ bh ifaces get bh = do env <- get bh + info <- get bh ifaces <- get bh - return (InterfaceFile env ifaces) + return (InterfaceFile env info ifaces) + + +putInterfaceFile_ :: BinHandle -> InterfaceFile -> IO () +putInterfaceFile_ bh (InterfaceFile env info ifaces) = do + put_ bh env + put_ bh info + put_ bh ifaces + +getInterfaceFile :: BinHandle -> Word16 -> IO InterfaceFile +getInterfaceFile bh v | v <= 38 = do + env <- get bh + let info = PackageInfo (PackageName mempty) (makeVersion []) + ifaces <- get bh + return (InterfaceFile env info ifaces) +getInterfaceFile bh _ = do + env <- get bh + info <- get bh + ifaces <- get bh + return (InterfaceFile env info ifaces) instance Binary InstalledInterface where diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index aa10b5b3..78bfe1a1 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -15,6 +15,7 @@ module Haddock.Options ( parseHaddockOpts, Flag(..), + Visibility(..), getUsage, optTitle, outputDir, @@ -361,18 +362,31 @@ ghcFlags flags = [ option | Flag_OptGhc option <- flags ] reexportFlags :: [Flag] -> [String] reexportFlags flags = [ option | Flag_Reexport option <- flags ] +data Visibility = Visible | Hidden + deriving (Eq, Show) -readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)] +readIfaceArgs :: [Flag] -> [(DocPaths, Visibility, FilePath)] readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ] where - parseIfaceOption :: String -> (DocPaths, FilePath) + parseIfaceOption :: String -> (DocPaths, Visibility, FilePath) parseIfaceOption str = case break (==',') str of (fpath, ',':rest) -> case break (==',') rest of - (src, ',':file) -> ((fpath, Just src), file) - (file, _) -> ((fpath, Nothing), file) - (file, _) -> (("", Nothing), file) + (src, ',':rest') -> + let src' = case src of + "" -> Nothing + _ -> Just src + in + case break (==',') rest' of + (visibility, ',':file) | visibility == "hidden" -> + ((fpath, src'), Hidden, file) + | otherwise -> + ((fpath, src'), Visible, file) + (file, _) -> + ((fpath, src'), Visible, file) + (file, _) -> ((fpath, Nothing), Visible, file) + (file, _) -> (("", Nothing), Visible, file) -- | Like 'listToMaybe' but returns the last element instead of the first. diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index 53cf98ad..850fdf7f 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} -- | -- Module : Haddock.Parser -- Copyright : (c) Mateusz Kowalczyk 2013, diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 7d00c5ec..6c98c830 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -151,7 +151,7 @@ data Interface = Interface -- | Warnings for things defined in this module. , ifaceWarningMap :: !WarningMap - -- | Tokenized source code of module (avaliable if Haddock is invoked with + -- | Tokenized source code of module (available if Haddock is invoked with -- source generation flag). , ifaceHieFile :: !(Maybe FilePath) , ifaceDynFlags :: !DynFlags diff --git a/haddock-api/src/Haddock/Utils/Json.hs b/haddock-api/src/Haddock/Utils/Json.hs index d5d5ae02..0a796b4a 100644 --- a/haddock-api/src/Haddock/Utils/Json.hs +++ b/haddock-api/src/Haddock/Utils/Json.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -401,7 +400,7 @@ parseIntegralFromDouble d = let r = toRational d x = truncate r in if toRational x == r - then pure $ x + then pure x else fail $ "unexpected floating number " <> show d parseIntegral :: Integral a => String -> Value -> Parser a |