haddock 2.25.1 → 2.26.0
raw patch · 52 files changed
+1737/−2481 lines, 52 filesdep ~ghcdep ~haddock-api
Dependency ranges changed: ghc, haddock-api
Files
- CHANGES.md +0/−27
- README.md +3/−2
- doc/common-errors.rst +19/−0
- doc/index.rst +2/−0
- doc/intro.rst +5/−4
- doc/invoking.rst +0/−7
- doc/multi-components.rst +48/−0
- haddock-api/src/Haddock.hs +52/−86
- haddock-api/src/Haddock/Backends/Hoogle.hs +85/−65
- haddock-api/src/Haddock/Backends/Hyperlinker.hs +4/−3
- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +13/−12
- haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +1/−1
- haddock-api/src/Haddock/Backends/LaTeX.hs +93/−61
- haddock-api/src/Haddock/Backends/Xhtml.hs +36/−101
- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +135/−109
- haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +1/−1
- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +6/−6
- haddock-api/src/Haddock/Backends/Xhtml/Names.hs +3/−2
- haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +3/−4
- haddock-api/src/Haddock/Backends/Xhtml/Types.hs +0/−11
- haddock-api/src/Haddock/Convert.hs +157/−135
- haddock-api/src/Haddock/GhcUtils.hs +144/−144
- haddock-api/src/Haddock/Interface.hs +41/−32
- haddock-api/src/Haddock/Interface/AttachInstances.hs +5/−7
- haddock-api/src/Haddock/Interface/Create.hs +128/−106
- haddock-api/src/Haddock/Interface/Json.hs +1/−1
- haddock-api/src/Haddock/Interface/LexParseRn.hs +15/−11
- haddock-api/src/Haddock/Interface/Rename.hs +110/−100
- haddock-api/src/Haddock/Interface/Specialize.hs +85/−41
- haddock-api/src/Haddock/InterfaceFile.hs +4/−6
- haddock-api/src/Haddock/Options.hs +6/−14
- haddock-api/src/Haddock/Parser.hs +3/−2
- haddock-api/src/Haddock/Syb.hs +16/−1
- haddock-api/src/Haddock/Types.hs +89/−40
- haddock-api/src/Haddock/Utils.hs +3/−0
- haddock-api/src/Haddock/Utils/Json.hs +22/−356
- haddock-api/src/Haddock/Utils/Json/Parser.hs +0/−102
- haddock-api/src/Haddock/Utils/Json/Types.hs +0/−42
- haddock.cabal +5/−7
- hoogle-test/ref/Bug806/test.txt +1/−1
- hoogle-test/ref/assoc-types/test.txt +2/−2
- html-test/ref/Bug1004.html +156/−14
- html-test/ref/Bug1035.html +1/−1
- html-test/ref/Bug1206.html +0/−488
- html-test/ref/Bug310.html +12/−12
- html-test/ref/IgnoreExports.html +0/−38
- html-test/ref/TypeFamilies.html +78/−78
- html-test/src/Bug1206.hs +0/−44
- hypsrc-test/ref/src/Classes.html +138/−138
- hypsrc-test/ref/src/Quasiquoter.html +1/−8
- hypsrc-test/ref/src/Records.html +3/−6
- latex-test/ref/ConstructorArgs/ConstructorArgs.tex +2/−2
CHANGES.md view
@@ -1,30 +1,3 @@-## Changes in 2.25.1-- * Better support for multiple packages (#1277)--## Changes in 2.25.0-- * Fix crash in `haddock-library` on unicode space (#1144)-- * Disallow qualified uses of reserved identifiers (#1145)-- * Disallow links in section headers (#1147)-- * Prune docstrings that are never rendered (#1161)-- * Don't warn about missing links in miminal sigs (#1161)-- * Add support for custom section anchors (#1179)-- * Adapt Haddock to LinearTypes language extension-- * Adapt Haddock to QualifiedDo language extensions-- * Allow scrolling in QuickJump search results (#1235)-- * Parallel Haddock. Pass -jn (where n is the number of threads)- to typecheck modules in parallel (#1323)- ## Changes in 2.24.0 * Reify oversaturated data family instances correctly (#1103)
README.md view
@@ -1,4 +1,4 @@-# Haddock ![CI][CI] [![Hackage][Hackage badge]][Hackage page]+# Haddock [![CI][CI badge]][CI page] [![Hackage][Hackage badge]][Hackage page] Haddock is the standard tool for generating documentation from Haskell code. Full documentation about Haddock itself can be found in the `doc/` subdirectory,@@ -25,7 +25,8 @@ project. -[CI]: https://github.com/haskell/haddock/workflows/CI/badge.svg?branch=ghc-9.0+[CI page]: https://github.com/haskell/haddock/actions/workflows/ci.yml+[CI badge]: https://github.com/haskell/haddock/actions/workflows/ci.yml/badge.svg [Hackage page]: https://hackage.haskell.org/package/haddock [Hackage badge]: https://img.shields.io/hackage/v/haddock.svg [ReST]: http://www.sphinx-doc.org/en/stable/rest.html
+ doc/common-errors.rst view
@@ -0,0 +1,19 @@+Common Errors+=============++``parse error on input ‘-- | xxx’``+-----------------------------------++This is probably caused by the ``-- | xxx`` comment not following a declaration. I.e. use ``-- xxx`` instead. See :ref:`top-level-declaration`.++``parse error on input ‘-- $ xxx’``+----------------------------------++You've probably commented out code like::++ f x+ $ xxx+ +``-- $`` is a special syntax for named chunks, see :ref:`named-chunks`. You can fix this by escaping the ``$``::++ -- \$ xxx
doc/index.rst view
@@ -12,6 +12,8 @@ intro invoking markup+ common-errors+ multi-components Indices and tables
doc/intro.rst view
@@ -25,7 +25,7 @@ The easier it is to write documentation, the more likely the programmer is to do it. Haddock therefore uses lightweight markup in its annotations, taking several ideas from- `IDoc <http://freshmeat.sourceforge.net/projects/idoc/>`__. In fact,+ `IDoc <http://www.cse.unsw.edu.au/~chak/haskell/idoc/>`__. In fact, Haddock can understand IDoc-annotated source code. - The documentation should not expose any of the structure of the@@ -125,6 +125,7 @@ - Luke Plant - Malcolm Wallace - Manuel Chakravarty+- Marcin Szamotulski - Mark Lentczner - Mark Shields - Mateusz Kowalczyk@@ -149,11 +150,11 @@ Several documentation systems provided the inspiration for Haddock, most notably: -- `IDoc <http://freshmeat.sourceforge.net/projects/idoc/>`__+- `IDoc <http://www.cse.unsw.edu.au/~chak/haskell/idoc/>`__ -- `HDoc <https://web.archive.org/web/20010603070527/http://www.fmi.uni-passau.de/~groessli/hdoc/>`__+- `HDoc <http://www.fmi.uni-passau.de/~groessli/hdoc/>`__ -- `Doxygen <https://www.doxygen.nl/index.html>`__+- `Doxygen <http://www.stack.nl/~dimitri/doxygen/>`__ and probably several others I've forgotten.
doc/invoking.rst view
@@ -223,13 +223,6 @@ Reserved for future use (output documentation in DocBook XML format). -.. option:: --base-url=<url>-- Base url for static assets (eg. css, javascript, json files etc.).- When present, static assets are not copied. This option is useful- when creating documentation for multiple packages, it allows to have- a single copy of static assets served from the given url.- .. option:: --source-base=<url> --source-module=<url> --source-entity=<url>
+ doc/multi-components.rst view
@@ -0,0 +1,48 @@+Haddocks of multiple components+===============================++Haddock supports building documentation of multiple components. First, one+needs to build haddocks of all components which can be done with:++.. code-block:: none++ cabal haddock --haddock-html \+ --haddock-quickjump \+ --haddock-option="--use-index=../doc-index.html" \+ --haddock-option="--use-contents=../index.html" \+ --haddock-option="--base-url=.." \+ all++The new ``--base-url`` option will allow to access the static files from the+main directory (in this example its the relative ``./..`` directory). It will+also prevent ``haddock`` from copying its static files to each of the+documentation folders, we're only need a single copy of them where the+``--base-url`` option points to.++The second step requires to copy all the haddocks to a common directory, let's+say ``./docs``, this will depend on your project and it might look like:++.. code-block:: none++ cp -r dist-newstyle/build/x86_64-linux/ghc-9.0.1/package-a-0.1.0.0/doc/html/package-a/ docs+ cp -r dist-newstyle/build/x86_64-linux/ghc-9.0.1/package-b-0.1.0.0/doc/html/package-b/ docs++Note that you can also include documentation of other packages in this way,+e.g. ``base``, but you need to know where it is hidden on your hard-drive.++To build html and js (``quickjump``) indexes one can now invoke ``haddock`` with:++.. code-block:: none++ haddock \+ -o docs \+ --quickjump --gen-index --gen-contents \+ --read-interface=package-a,docs/package-a/package-a.haddock \+ --read-interface=package-b,docs/package-b/package-b.haddock++Note: the ``PATH`` in ``--read-interface=PATH,...`` must be a relative url of+a package it points to (relative to the ``docs`` directory).++There's an example project which shows how to do that posted `here+<https://github.com/coot/haddock-example>`_, which haddocks are served on+`github-pages <https://coot.github.io/haddock-example>`_.
haddock-api/src/Haddock.hs view
@@ -1,10 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS_GHC -Wwarn #-}+{-# OPTIONS_GHC -Wwarn #-}+{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-}+{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock@@ -50,7 +46,7 @@ import Data.Bifunctor (second) import Data.Foldable (forM_, foldl') import Data.Traversable (for)-import Data.List (find, isPrefixOf, nub)+import Data.List (isPrefixOf) import Control.Exception import Data.Maybe import Data.IORef@@ -73,12 +69,11 @@ import GHC hiding (verbosity) import GHC.Settings.Config import GHC.Driver.Session hiding (projectVersion, verbosity)-import GHC.Utils.Outputable (defaultUserStyle, withPprStyle)+import GHC.Driver.Env import GHC.Utils.Error import GHC.Unit import GHC.Utils.Panic (handleGhcException) import GHC.Data.FastString-import qualified Debug.Trace as Debug -------------------------------------------------------------------------------- -- * Exception handling@@ -189,11 +184,13 @@ ghc flags' $ withDir $ do dflags <- getDynFlags+ logger <- getLogger+ unit_state <- hsc_units <$> getSession forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks- forM_ mIfaceFile $ \(_, _, ifaceFile) -> do- logOutput dflags $ withPprStyle defaultUserStyle (renderJson (jsonInterfaceFile ifaceFile))+ forM_ mIfaceFile $ \(_, ifaceFile) -> do+ putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile) if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files@@ -206,7 +203,7 @@ } -- Render the interfaces.- liftIO $ renderStep dflags flags sinceQual qual packages ifaces+ liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages ifaces else do when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $@@ -216,7 +213,7 @@ packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index).- liftIO $ renderStep dflags flags sinceQual qual packages []+ liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages [] -- | Run the GHC action using a temporary output directory withTempOutputDir :: Ghc a -> Ghc a@@ -252,65 +249,48 @@ readPackagesAndProcessModules :: [Flag] -> [String]- -> Ghc ([(DocPaths, FilePath, InterfaceFile)], [Interface], LinkEnv)+ -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do -- Get packages supplied with --read-interface. let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks -- Create the interfaces -- this is the core part of Haddock.- let ifaceFiles = map (\(_, _, ifaceFile) -> ifaceFile) packages+ let ifaceFiles = map snd packages (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles return (packages, ifaces, homeLinks) -renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption- -> [(DocPaths, FilePath, InterfaceFile)] -> [Interface] -> IO ()-renderStep dflags flags sinceQual nameQual pkgs interfaces = do- updateHTMLXRefs (map (\(docPath, _ifaceFilePath, ifaceFile) ->- ( case baseUrl flags of- Nothing -> fst docPath- Just url -> Debug.traceShowId $- url </> packageName (unitState dflags) (ifUnitId ifaceFile)- , ifaceFile)) pkgs)+renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption+ -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()+renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do+ updateHTMLXRefs pkgs let- installedIfaces =- concatMap- (\(_, ifaceFilePath, ifaceFile)- -> (ifaceFilePath,) <$> ifInstalledIfaces ifaceFile)- pkgs+ ifaceFiles = map snd pkgs+ installedIfaces = concatMap ifInstalledIfaces ifaceFiles extSrcMap = Map.fromList $ do- ((_, Just path), _, ifile) <- pkgs+ ((_, Just path), ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path)- render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap- where- -- get package name from unit-id- packageName :: UnitState -> Unit -> String- packageName state unit =- case lookupUnit state unit of- Nothing -> show unit- Just pkg -> unitPackageNameString pkg+ render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags.-render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface]- -> [(FilePath, InstalledInterface)] -> Map Module FilePath -> IO ()-render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do+render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]+ -> [InstalledInterface] -> Map Module FilePath -> IO ()+render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) unicode = Flag_UseUnicode `elem` flags pretty = Flag_PrettyHtml `elem` flags opt_wiki_urls = wikiUrls flags- opt_base_url = baseUrl flags opt_contents_url = optContentsUrl flags opt_index_url = optIndexUrl flags odir = outputDir flags opt_latex_style = optLaTeXStyle flags opt_source_css = optSourceCssFile flags opt_mathjax = optMathjax flags- pkgs = unitState dflags dflags' | unicode = gopt_set dflags Opt_PrintUnicodeSyntax | otherwise = dflags@@ -318,13 +298,13 @@ visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] -- /All/ visible interfaces including external package modules.- allIfaces = map toInstalledIface ifaces ++ map snd installedIfaces+ allIfaces = map toInstalledIface ifaces ++ installedIfaces allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = fmap ifaceMod (listToMaybe ifaces) pkgKey = fmap moduleUnit pkgMod pkgStr = fmap unitString pkgKey- pkgNameVer = modulePackageInfo dflags flags pkgMod+ pkgNameVer = modulePackageInfo unit_state flags pkgMod pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer) sincePkg = case sinceQual of External -> pkgName@@ -363,13 +343,13 @@ 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 <- installedIfaces ] -- The user gives use base-4.9.0.0, but the InstalledInterface -- records the *wired in* identity base. So untranslate it -- so that we can service the request. unwire :: Module -> Module- unwire m = m { moduleUnit = unwireUnit (unitState dflags) (moduleUnit m) }+ unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) } reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do let warn = hPutStrLn stderr . ("Warning: " ++)@@ -386,53 +366,38 @@ themes <- getThemes libDir flags >>= either bye return let withQuickjump = Flag_QuickJumpIndex `elem` flags- withBaseURL = isJust- . find (\flag -> case flag of- Flag_BaseURL base_url ->- base_url /= "." && base_url /= "./"- _ -> False- )- $ flags when (Flag_GenIndex `elem` flags) $ do- withTiming dflags' "ppHtmlIndex" (const ()) $ do+ withTiming logger dflags' "ppHtmlIndex" (const ()) $ do _ <- {-# SCC ppHtmlIndex #-} ppHtmlIndex odir title pkgStr themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls allVisibleIfaces pretty return () - unless withBaseURL $- copyHtmlBits odir libDir themes withQuickjump+ copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do- withTiming dflags' "ppHtmlContents" (const ()) $ do+ withTiming logger dflags' "ppHtmlContents" (const ()) $ do _ <- {-# SCC ppHtmlContents #-}- ppHtmlContents pkgs odir title pkgStr+ ppHtmlContents unit_state odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty sincePkg (makeContentsQual qual) return () copyHtmlBits odir libDir themes withQuickjump - when withQuickjump $ void $- ppJsonIndex odir sourceUrls' opt_wiki_urls- unicode Nothing qual- ifaces- (nub $ map fst installedIfaces)- when (Flag_Html `elem` flags) $ do- withTiming dflags' "ppHtml" (const ()) $ do+ withTiming logger dflags' "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-}- ppHtml pkgs title pkgStr visibleIfaces reexportedIfaces odir+ ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir prologue- themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url+ themes opt_mathjax sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode sincePkg qual pretty withQuickjump return ()- unless withBaseURL $ do- copyHtmlBits odir libDir themes withQuickjump- writeHaddockMeta odir withQuickjump+ copyHtmlBits odir libDir themes withQuickjump+ writeHaddockMeta odir withQuickjump -- TODO: we throw away Meta for both Hoogle and LaTeX right now, -- might want to fix that if/when these two get some work on them@@ -445,7 +410,7 @@ pkgVer = fromMaybe (makeVersion []) mpkgVer- in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)+ in ppHoogle dflags' unit_state pkgNameStr pkgVer title (fmap _doc prologue) visibleIfaces odir _ -> putStrLn . unlines $ [ "haddock: Unable to find a package providing module "@@ -458,14 +423,14 @@ ] when (Flag_LaTeX `elem` flags) $ do- withTiming dflags' "ppLatex" (const ()) $ do+ withTiming logger dflags' "ppLatex" (const ()) $ do _ <- {-# SCC ppLatex #-} ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir return () when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do- withTiming dflags' "ppHyperlinkedSource" (const ()) $ do+ withTiming logger dflags' "ppHyperlinkedSource" (const ()) $ do _ <- {-# SCC ppHyperlinkedSource #-} ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces return ()@@ -480,7 +445,7 @@ => NameCacheAccessor m -> [(DocPaths, FilePath)] -> Bool- -> m [(DocPaths, FilePath, InterfaceFile)]+ -> m [(DocPaths, InterfaceFile)] readInterfaceFiles name_cache_accessor pairs bypass_version_check = do catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs where@@ -492,7 +457,7 @@ putStrLn (" " ++ err) putStrLn "Skipping this interface." return Nothing- Right f -> return (Just (paths, file, f))+ Right f -> return $ Just (paths, f) -------------------------------------------------------------------------------@@ -504,7 +469,8 @@ -- compilation and linking. Then run the given 'Ghc' action. withGhc' :: String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do- dynflags' <- parseGhcFlags =<< getSessionDynFlags+ logger <- getLogger+ dynflags' <- parseGhcFlags logger =<< getSessionDynFlags -- We disable pattern match warnings because than can be very -- expensive to check@@ -528,20 +494,20 @@ go arg func True = arg : func True - parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags- parseGhcFlags dynflags = do+ parseGhcFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags+ parseGhcFlags logger dynflags = do -- TODO: handle warnings? let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock] | otherwise = [Opt_Haddock] dynflags' = (foldl' gopt_set dynflags extra_opts)- { hscTarget = HscNothing- , ghcMode = CompManager- , ghcLink = NoLink+ { backend = NoBackend+ , ghcMode = CompManager+ , ghcLink = NoLink } flags' = filterRtsFlags flags - (dynflags'', rest, _) <- parseDynamicFlags dynflags' (map noLoc flags')+ (dynflags'', rest, _) <- parseDynamicFlags logger dynflags' (map noLoc flags') if not (null rest) then throwE ("Couldn't parse GHC options: " ++ unwords flags') else return dynflags''@@ -712,12 +678,12 @@ isSourceCssFlag _ = False -updateHTMLXRefs :: [(FilePath, InterfaceFile)] -> IO ()+updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO () updateHTMLXRefs packages = do writeIORef html_xrefs_ref (Map.fromList mapping) writeIORef html_xrefs_ref' (Map.fromList mapping') where- mapping = [ (instMod iface, html) | (html, ifaces) <- packages+ mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages , iface <- ifInstalledIfaces ifaces ] mapping' = [ (moduleName m, html) | (m, html) <- mapping ]
haddock-api/src/Haddock/Backends/Hoogle.hs view
@@ -18,8 +18,9 @@ ppHoogle ) where -import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), SourceText(..)- , PromotionFlag(..), TopLevelFlag(..) )+import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..),+ PromotionFlag(..), TopLevelFlag(..) )+import GHC.Types.SourceText import GHC.Core.InstEnv (ClsInst(..)) import Documentation.Haddock.Markup import Haddock.GhcUtils@@ -27,8 +28,11 @@ import Haddock.Utils hiding (out) import GHC+import GHC.Driver.Ppr import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Parser.Annotation (IsUnicodeSyntax(..))+import GHC.Unit.State import Data.Char import Data.List (intercalate, isPrefixOf)@@ -37,15 +41,14 @@ import System.Directory import System.FilePath- prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock" ,"-- See Hoogle, http://www.haskell.org/hoogle/" ,""] -ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()-ppHoogle dflags package version synopsis prologue ifaces odir = do+ppHoogle :: DynFlags -> UnitState -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()+ppHoogle dflags unit_state package version synopsis prologue ifaces odir = do let -- Since Hoogle is line based, we want to avoid breaking long lines. dflags' = dflags{ pprCols = maxBound } filename = package ++ ".txt"@@ -54,44 +57,47 @@ ["@package " ++ package] ++ ["@version " ++ showVersion version | not (null (versionBranch version)) ] ++- concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i]+ concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i] createDirectoryIfMissing True odir writeUtf8File (odir </> filename) (unlines contents) -ppModule :: DynFlags -> Interface -> [String]-ppModule dflags iface =+ppModule :: DynFlags -> UnitState -> Interface -> [String]+ppModule dflags unit_state iface = "" : ppDocumentation dflags (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ concatMap (ppExport dflags) (ifaceExportItems iface) ++- concatMap (ppInstance dflags) (ifaceInstances iface)+ concatMap (ppInstance dflags unit_state) (ifaceInstances iface) --------------------------------------------------------------------- -- Utility functions -dropHsDocTy :: HsType a -> HsType a-dropHsDocTy = f+dropHsDocTy :: HsSigType GhcRn -> HsSigType GhcRn+dropHsDocTy = drop_sig_ty where- g (L src x) = L src (f x)- f (HsForAllTy x a e) = HsForAllTy x a (g e)- f (HsQualTy x a e) = HsQualTy x a (g e)- f (HsBangTy x a b) = HsBangTy x a (g b)- f (HsAppTy x a b) = HsAppTy x (g a) (g b)- f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b)- f (HsFunTy x w a b) = HsFunTy x w (g a) (g b)- f (HsListTy x a) = HsListTy x (g a)- f (HsTupleTy x a b) = HsTupleTy x a (map g b)- f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)- f (HsParTy x a) = HsParTy x (g a)- f (HsKindSig x a b) = HsKindSig x (g a) b- f (HsDocTy _ a _) = f $ unLoc a- f x = x+ drop_sig_ty (HsSig x a b) = HsSig x a (drop_lty b)+ drop_sig_ty x@XHsSigType{} = x -outHsType :: (OutputableBndrId p)- => DynFlags -> HsType (GhcPass p) -> String-outHsType dflags = out dflags . reparenType . dropHsDocTy+ drop_lty (L src x) = L src (drop_ty x) + drop_ty (HsForAllTy x a e) = HsForAllTy x a (drop_lty e)+ drop_ty (HsQualTy x a e) = HsQualTy x a (drop_lty e)+ drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b)+ drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b)+ drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b)+ drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b)+ drop_ty (HsListTy x a) = HsListTy x (drop_lty a)+ drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b)+ drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) b (drop_lty c)+ drop_ty (HsParTy x a) = HsParTy x (drop_lty a)+ drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b+ drop_ty (HsDocTy _ a _) = drop_ty $ unL a+ drop_ty x = x +outHsSigType :: DynFlags -> HsSigType GhcRn -> String+outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy++ dropComment :: String -> String dropComment (' ':'-':'-':' ':_) = [] dropComment (x:xs) = x : dropComment xs@@ -106,14 +112,14 @@ f [] = [] out :: Outputable a => DynFlags -> a -> String-out dflags = outWith $ showSDocUnqual dflags+out dflags = outWith $ showSDoc dflags operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x commaSeparate :: Outputable a => DynFlags -> [a] -> String-commaSeparate dflags = showSDocUnqual dflags . interpp'SP+commaSeparate dflags = showSDoc dflags . interpp'SP --------------------------------------------------------------------- -- How to print each export@@ -133,8 +139,8 @@ f (TyClD _ d@SynDecl{}) = ppSynonym dflags d f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs f (TyClD _ (FamDecl _ d)) = ppFam dflags d- f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]- f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]+ f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ]+ f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ] f (SigD _ sig) = ppSig dflags sig f _ = [] @@ -143,19 +149,19 @@ ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] ppSigWithDoc dflags sig subdocs = case sig of- TypeSig _ names t -> concatMap (mkDocSig "" (hsSigWcType t)) names- PatSynSig _ names t -> concatMap (mkDocSig "pattern " (hsSigType t)) names+ TypeSig _ names t -> concatMap (mkDocSig "" (dropWildCards t)) names+ PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names _ -> [] where- mkDocSig leader typ n = mkSubdoc dflags n subdocs- [leader ++ pp_sig dflags [n] typ]+ mkDocSig leader typ n = mkSubdocN dflags n subdocs+ [leader ++ pp_sig dflags [n] typ] ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsType GhcRn -> String+pp_sig :: DynFlags -> [LocatedN Name] -> LHsSigType GhcRn -> String pp_sig dflags names (L _ typ) =- operator prettyNames ++ " :: " ++ outHsType dflags typ+ operator prettyNames ++ " :: " ++ outHsSigType dflags typ where prettyNames = intercalate ", " $ map (out dflags) names @@ -173,14 +179,14 @@ ppTyFams | null $ tcdATs decl = ""- | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat+ | otherwise = (" " ++) . showSDoc dflags . whereWrapper $ concat [ map pprTyFam (tcdATs decl) , map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl) ] pprTyFam :: LFamilyDecl GhcRn -> SDoc pprTyFam (L _ at) = vcat' $ map text $- mkSubdoc dflags (fdLName at) subdocs (ppFam dflags at)+ mkSubdocN dflags (fdLName at) subdocs (ppFam dflags at) whereWrapper elems = vcat' [ text "where" <+> lbrace@@ -198,9 +204,9 @@ ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } _ -> decl -ppInstance :: DynFlags -> ClsInst -> [String]-ppInstance dflags x =- [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls]+ppInstance :: DynFlags -> UnitState -> ClsInst -> [String]+ppInstance dflags unit_state x =+ [dropComment $ outWith (showSDocForUser dflags unit_state alwaysQualify) cls] where -- As per #168, we don't want safety information about the class -- in Hoogle output. The easiest way to achieve this is to set the@@ -215,7 +221,7 @@ ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs- = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} :+ = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=[] }} : concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn) where @@ -228,50 +234,61 @@ ppData _ _ _ = panic "ppData" -- | for constructors, and named-fields...-lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String]+lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> LocatedN Name -> [String] lookupCon dflags subdocs (L _ name) = case lookup name subdocs of Just (d, _) -> ppDocumentation dflags d _ -> [] ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String]-ppCtor dflags dat subdocs con@ConDeclH98 {}+ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } -- AZ:TODO get rid of the concatMap- = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con)+ = concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args' where- f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]- f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]- f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat- [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) +++ f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]+ f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2]+ f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat+ [(concatMap (lookupCon dflags subdocs . noLocA . extFieldOcc . unLoc) (cd_fld_names r)) ++ [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)+ funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y) apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)+ typeSig nm flds = operator nm ++ " :: " +++ outHsSigType dflags (unL $ mkEmptySigType $ 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 unLoc $ getConNames con+ name = commaSeparate dflags . map unL $ getConNames con - tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n- tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty+ tyVarArg (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n+ tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noAnn (reL (HsTyVar noAnn NotPromoted n)) lty tyVarArg _ = panic "ppCtor" resType = apps $ map reL $- (HsTyVar noExtField NotPromoted (reL (tcdName dat))) :+ (HsTyVar noAnn NotPromoted (reL (tcdName dat))) : map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) -ppCtor dflags _dat subdocs con@(ConDeclGADT { })- = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f+ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names+ , con_bndrs = L _ outer_bndrs+ , con_mb_cxt = mcxt+ , con_g_args = args+ , con_res_ty = res_ty })+ = concatMap (lookupCon dflags subdocs) names ++ [typeSig] where- f = [typeSig name (getGADTConTypeG con)]-- typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty)- name = out dflags $ map unLoc $ getConNames con+ typeSig = operator name ++ " :: " ++ outHsSigType dflags con_sig_ty+ name = out dflags $ map unL names+ con_sig_ty = HsSig noExtField outer_bndrs theta_ty where+ theta_ty = case mcxt of+ Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })+ Nothing -> tau_ty+ tau_ty = foldr mkFunTy res_ty $+ case args of PrefixConGADT pos_args -> map hsScaledThing pos_args+ RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds+ mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b) ppFixity :: DynFlags -> (Name, Fixity) -> [String]-ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)]+ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)] ---------------------------------------------------------------------@@ -294,7 +311,10 @@ lines header ++ ["" | header /= "" && isJust d] ++ maybe [] (showTags . markup (markupTag dflags)) d -mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String]+mkSubdocN :: DynFlags -> LocatedN Name -> [(Name, DocForDecl Name)] -> [String] -> [String]+mkSubdocN dflags n subdocs s = mkSubdoc dflags (n2l n) subdocs s++mkSubdoc :: DynFlags -> LocatedA Name -> [(Name, DocForDecl Name)] -> [String] -> [String] mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s where getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs)
haddock-api/src/Haddock/Backends/Hyperlinker.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} module Haddock.Backends.Hyperlinker ( ppHyperlinkedSource , module Haddock.Backends.Hyperlinker.Types@@ -18,7 +19,7 @@ import System.Directory import System.FilePath -import GHC.Iface.Ext.Types ( HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) )+import GHC.Iface.Ext.Types ( pattern HiePath, HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) ) import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..)) import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc ) import Data.Map as M@@ -70,10 +71,10 @@ -- Get the AST and tokens corresponding to the source file we want let fileFs = mkFastString file mast | M.size asts == 1 = snd <$> M.lookupMin asts- | otherwise = M.lookup fileFs asts+ | otherwise = M.lookup (HiePath (mkFastString file)) asts+ tokens = parse df file rawSrc ast = fromMaybe (emptyHieAst fileFs) mast fullAst = recoverFullIfaceTypes df types ast- tokens = parse df file rawSrc -- Warn if we didn't find an AST, but there were still ASTs if M.null asts
haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs view
@@ -10,15 +10,18 @@ import qualified Data.ByteString as BS -import GHC.Types.Basic ( IntegralLit(..) )+import GHC.Types.SourceText import GHC.Driver.Session-import GHC.Utils.Error ( pprLocErrMsg )+import GHC.Utils.Error ( pprLocMsgEnvelope ) import GHC.Data.FastString ( mkFastString )+import GHC.Parser.Errors.Ppr ( pprError ) import GHC.Parser.Lexer as Lexer ( P(..), ParseResult(..), PState(..), Token(..)- , mkPStatePure, lexer, mkParserFlags', getErrorMessages)+ , initParserState, lexer, mkParserOpts, getErrorMessages) import GHC.Data.Bag ( bagToList )-import GHC.Utils.Outputable ( showSDoc, panic, text, ($$) )+import GHC.Utils.Outputable ( text, ($$) )+import GHC.Utils.Panic ( panic )+import GHC.Driver.Ppr ( showSDoc ) import GHC.Types.SrcLoc import GHC.Data.StringBuffer ( StringBuffer, atEnd ) @@ -37,17 +40,16 @@ parse dflags fpath bs = case unP (go False []) initState of POk _ toks -> reverse toks PFailed pst ->- let err:_ = bagToList (getErrorMessages pst dflags) in+ let err:_ = bagToList (fmap pprError (getErrorMessages pst)) in panic $ showSDoc dflags $- text "Hyperlinker parse error:" $$ pprLocErrMsg err+ text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err where - initState = mkPStatePure pflags buf start+ initState = initParserState pflags buf start buf = stringBufferFromByteString bs start = mkRealSrcLoc (mkFastString fpath) 1 1- pflags = mkParserFlags' (warningFlags dflags)+ pflags = mkParserOpts (warningFlags dflags) (extensionFlags dflags)- (homeUnitId dflags) (safeImportsOn dflags) False -- lex Haddocks as comment tokens True -- produce comment tokens@@ -240,7 +242,6 @@ ITline_prag {} -> TkPragma ITcolumn_prag {} -> TkPragma ITscc_prag {} -> TkPragma- ITgenerated_prag {} -> TkPragma ITunpack_prag {} -> TkPragma ITnounpack_prag {} -> TkPragma ITann_prag {} -> TkPragma@@ -273,6 +274,7 @@ ITprefixminus -> TkGlyph ITbang -> TkGlyph ITdot -> TkOperator+ ITproj {} -> TkOperator ITstar {} -> TkOperator ITtypeApp -> TkGlyph ITpercent -> TkGlyph@@ -358,7 +360,7 @@ -- the GHC lexer for more), so we have to manually reverse this. The -- following is a hammer: it smashes _all_ pragma-like block comments into -- pragmas.- ITblockComment c+ ITblockComment c _ | isPrefixOf "{-#" c , isSuffixOf "#-}" c -> TkPragma | otherwise -> TkComment@@ -381,7 +383,6 @@ ITline_prag {} -> True ITcolumn_prag {} -> True ITscc_prag {} -> True- ITgenerated_prag {} -> True ITunpack_prag {} -> True ITnounpack_prag {} -> True ITann_prag {} -> True
haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs view
@@ -21,7 +21,7 @@ import GHC.Iface.Ext.Types ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat ) import GHC.Iface.Type import GHC.Types.Name ( getOccFS, getOccString )-import GHC.Utils.Outputable( showSDoc )+import GHC.Driver.Ppr ( showSDoc ) import GHC.Types.Var ( VarBndr(..) ) import System.FilePath.Posix ((</>), (<.>))
haddock-api/src/Haddock/Backends/LaTeX.hs view
@@ -25,13 +25,13 @@ import qualified GHC.Utils.Ppr as Pretty import GHC.Types.Basic ( PromotionFlag(..) )-import GHC+import GHC hiding (fromMaybeContext ) import GHC.Types.Name.Occurrence import GHC.Types.Name ( nameOccName ) import GHC.Types.Name.Reader ( rdrNameOcc ) import GHC.Core.Type ( Specificity(..) ) import GHC.Data.FastString ( unpackFS )-import GHC.Utils.Outputable ( panic)+import GHC.Utils.Panic ( panic) import qualified Data.Map as Map import System.Directory@@ -108,7 +108,7 @@ -- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100 -- often overflows the line). latex2String :: LaTeX -> String-latex2String = fullRender PageMode 90 1 txtPrinter ""+latex2String = fullRender (PageMode True) 90 1 txtPrinter "" ppLaTeXTop :: String@@ -177,7 +177,7 @@ body = processExports exports --- writeUtf8File (odir </> moduleLaTeXFile mdl) (show tex)+ writeUtf8File (odir </> moduleLaTeXFile mdl) (fullRender (PageMode True) 80 1 txtPrinter "" tex) -- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX@@ -215,10 +215,10 @@ processExport e $$ processExports es -isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI)+isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI) isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }- | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t))+ | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t)) isSimpleSig _ = Nothing @@ -301,7 +301,7 @@ -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode- SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode+ SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode ForD _ d -> ppFor (doc, fnArgsDoc) d unicode InstD _ _ -> empty@@ -313,7 +313,7 @@ ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode =- ppFunSig Nothing doc [name] (hsSigTypeI typ) unicode+ ppFunSig Nothing doc [name] typ unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -350,9 +350,9 @@ -- Individual equations of a closed type family ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX- ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n- , feqn_rhs = rhs- , feqn_pats = ts } })+ ppFamDeclEqn (FamEqn { feqn_tycon = L _ n+ , feqn_rhs = rhs+ , feqn_pats = ts }) = hsep [ ppAppNameTypeArgs n ts unicode , equals , ppType unicode (unLoc rhs)@@ -390,10 +390,11 @@ injAnn = case injectivity of Nothing -> empty- Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( decltt (text "|")- : ppLDocName lhs- : arrow unicode- : map ppLDocName rhs)+ Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( decltt (text "|")+ : ppLDocName lhs+ : arrow unicode+ : map ppLDocName rhs)+ Just _ -> empty @@ -407,7 +408,7 @@ ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode- = ppTypeOrFunSig (unLoc ltype) doc (full, hdr, char '=') unicode+ = ppTypeOrFunSig (mkHsImplicitSigTypeI ltype) doc (full, hdr, char '=') unicode where hdr = hsep (keyword "type" : ppDocBinder name@@ -426,7 +427,7 @@ :: Maybe LaTeX -- ^ a prefix to put right before the signature -> DocForDecl DocName -- ^ documentation -> [DocName] -- ^ pattern names in the pattern signature- -> LHsType DocNameI -- ^ type of the pattern synonym+ -> LHsSigType DocNameI -- ^ type of the pattern synonym -> Bool -- ^ unicode -> LaTeX ppFunSig leader doc docnames (L _ typ) unicode =@@ -447,11 +448,11 @@ -> Bool -- ^ unicode -> LaTeX ppLPatSig doc docnames ty unicode- = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigTypeI ty) unicode+ = ppFunSig (Just (keyword "pattern")) doc docnames ty unicode -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed.-ppTypeOrFunSig :: HsType DocNameI+ppTypeOrFunSig :: HsSigType DocNameI -> DocForDecl DocName -- ^ documentation -> ( LaTeX -- first-line (no-argument docs only) , LaTeX -- first-line (argument docs only)@@ -471,13 +472,24 @@ -- to the arguments. The output is a list of (leader/seperator, argument and -- its doc) ppSubSigLike :: Bool -- ^ unicode- -> HsType DocNameI -- ^ type signature+ -> HsSigType DocNameI -- ^ type signature -> FnArgsDoc DocName -- ^ docs to add -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`) -> LaTeX -- ^ seperator (beginning of first line) -> [(LaTeX, LaTeX)] -- ^ arguments (leader/sep, type)-ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ+ppSubSigLike unicode typ argDocs subdocs leader = do_sig_args 0 leader typ where+ do_sig_args :: Int -> LaTeX -> HsSigType DocNameI -> [(LaTeX, LaTeX)]+ do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) =+ case outer_bndrs of+ HsOuterExplicit{hso_bndrs = bndrs} ->+ [ ( decltt leader+ , decltt (ppHsForAllTelescope (mkHsForAllInvisTeleI bndrs) unicode)+ <+> ppLType unicode ltype+ ) ]+ HsOuterImplicit{} -> do_largs n leader ltype++ do_largs :: Int -> LaTeX -> LHsType DocNameI -> [(LaTeX, LaTeX)] do_largs n leader (L _ t) = do_args n leader t arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs@@ -515,12 +527,16 @@ gadtOpen = char '{' -ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX+ppTypeSig :: [Name] -> HsSigType DocNameI -> Bool -> LaTeX ppTypeSig nms ty unicode = hsep (punctuate comma $ map ppSymName nms) <+> dcolon unicode- <+> ppType unicode ty+ <+> ppSigType unicode ty +ppHsOuterTyVarBndrs :: HsOuterTyVarBndrs flag DocNameI -> Bool -> LaTeX+ppHsOuterTyVarBndrs (HsOuterImplicit{}) _ = empty+ppHsOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) unicode =+ hsep (forallSymbol unicode : ppTyVars bndrs) <> dot ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX ppHsForAllTelescope tele unicode = case tele of@@ -582,23 +598,25 @@ ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName- -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]+ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName+ -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class"- <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)+ <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode else empty) <+> ppAppDocNameNames summ n (tyvarNames tvs) <+> ppFds fds unicode --ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX+-- ppFds :: [Located ([LocatedA DocName], [LocatedA DocName])] -> Bool -> LaTeX+ppFds :: [LHsFunDep DocNameI] -> Bool -> LaTeX ppFds fds unicode = if null fds then empty else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where- fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+>+ fundep (FunDep _ vars1 vars2)+ = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+> hsep (map (ppDocName . unLoc) vars2)+ fundep (XFunDep _) = error "ppFds" -- TODO: associated type defaults, docs on default methods@@ -635,7 +653,7 @@ methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$- vcat [ ppFunSig leader doc names (hsSigTypeI typ) unicode+ vcat [ ppFunSig leader doc names typ unicode | L _ (ClassOpSig _ is_def lnames typ) <- lsigs , let doc | is_def = noDocForDecl | otherwise = lookupAnySubdoc (head names) subdocs@@ -789,13 +807,13 @@ decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars- , con_forall = L _ forall_+ , con_forall = forall_ , con_mb_cxt = cxt- } -> let context = unLoc (fromMaybe (noLoc []) cxt)+ } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode in case det of -- Prefix constructor, e.g. 'Just a'- PrefixCon args+ PrefixCon _ args | hasArgDocs -> header_ <+> ppOcc | otherwise -> hsep [ header_ , ppOcc@@ -819,23 +837,25 @@ | otherwise -> hsep [ ppOcc , dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT- , ppLType unicode (getGADTConType con)+ , ppLSigType unicode (getGADTConType con) ] - fieldPart = case (con, getConArgsI con) of- -- Record style GADTs- (ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs []-- -- Regular record declarations- (_, RecCon (L _ fields)) -> doRecordFields fields-- -- Any GADT or a regular H98 prefix data constructor- (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)-- -- An infix H98 data constructor- (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])+ fieldPart = case con of+ ConDeclGADT{con_g_args = con_args'} -> case con_args' of+ -- GADT record declarations+ RecConGADT _ -> doConstrArgsWithDocs []+ -- GADT prefix data constructors+ PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)+ _ -> empty - _ -> empty+ ConDeclH98{con_args = con_args'} -> case con_args' of+ -- H98 record declarations+ RecCon (L _ fields) -> doRecordFields fields+ -- H98 prefix data constructors+ PrefixCon _ args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)+ -- H98 infix data constructor+ InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])+ _ -> empty doRecordFields fields = vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl@@ -876,7 +896,7 @@ -- | Pretty-print a bundled pattern synonym-ppSideBySidePat :: [Located DocName] -- ^ pattern name(s)+ppSideBySidePat :: [LocatedN DocName] -- ^ pattern name(s) -> LHsSigType DocNameI -- ^ type of pattern(s) -> DocForDecl DocName -- ^ doc map -> Bool -- ^ unicode@@ -892,18 +912,16 @@ | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode- , ppLType unicode (hsSigTypeI typ)+ , ppLSigType unicode typ ] fieldPart | not hasArgDocs = empty | otherwise = vcat [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r- | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode)+ | (l,r) <- ppSubSigLike unicode (unLoc typ) argDocs [] (dcolon unicode) ] - patTy = hsSigTypeI typ- mDoc = fmap _doc $ combineDocumentation doc @@ -965,9 +983,11 @@ ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Bool -> LaTeX-ppLContext = ppContext . unLoc-ppLContextNoArrow = ppContextNoArrow . unLoc+ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX+ppLContext Nothing _ = empty+ppLContext (Just ctxt) unicode = ppContext (unLoc ctxt) unicode+ppLContextNoArrow Nothing _ = empty+ppLContextNoArrow (Just ctxt) unicode = ppContextNoArrow (unLoc ctxt) unicode ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing@@ -1019,17 +1039,23 @@ -- Stolen from Html and tweaked for LaTeX generation ------------------------------------------------------------------------------- -ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX+ppLType, ppLParendType, ppLFunLhType :: Bool -> LHsType DocNameI -> LaTeX ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) +ppLSigType :: Bool -> LHsSigType DocNameI -> LaTeX+ppLSigType unicode y = ppSigType unicode (unLoc y)+ ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode-ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode+ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode +ppSigType :: Bool -> HsSigType DocNameI -> LaTeX+ppSigType unicode sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode+ ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <>@@ -1061,6 +1087,11 @@ -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell +ppr_sig_ty :: HsSigType DocNameI -> Bool -> LaTeX+ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode+ = sep [ ppHsOuterTyVarBndrs outer_bndrs unicode+ , ppr_mono_lty ltype unicode ]+ ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode @@ -1076,9 +1107,9 @@ = sep [ ppr_mono_lty ty1 u , arr <+> ppr_mono_lty ty2 u ] where arr = case mult of- HsLinearArrow _ -> lollipop u+ HsLinearArrow _ _ -> lollipop u HsUnrestrictedArrow _ -> arrow u- HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u+ HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name@@ -1090,7 +1121,7 @@ ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u ppr_mono_ty (HsSpliceTy v _) _ = absurd v ppr_mono_ty (HsRecTy {}) _ = text "{..}"-ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy"+ppr_mono_ty (XHsType {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys@@ -1123,6 +1154,7 @@ ppr_tylit :: HsTyLit -> Bool -> LaTeX ppr_tylit (HsNumTy _ n) _ = integer n ppr_tylit (HsStrTy _ s) _ = text (show s)+ppr_tylit (HsCharTy _ c) _ = text (show c) -- XXX: Ok in verbatim, but not otherwise -- XXX: Do something with Unicode parameter? @@ -1158,7 +1190,7 @@ ppDocName :: DocName -> LaTeX ppDocName = ppOccName . nameOccName . getName -ppLDocName :: Located DocName -> LaTeX+ppLDocName :: GenLocated l DocName -> LaTeX ppLDocName (L _ d) = ppDocName d
haddock-api/src/Haddock/Backends/Xhtml.hs view
@@ -11,11 +11,10 @@ -- Stability : experimental -- Portability : portable ------------------------------------------------------------------------------{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, TypeApplications #-}+{-# LANGUAGE CPP, NamedFieldPuns #-} module Haddock.Backends.Xhtml ( ppHtml, copyHtmlBits, ppHtmlIndex, ppHtmlContents,- ppJsonIndex ) where @@ -39,22 +38,18 @@ import Control.Monad ( when, unless ) import qualified Data.ByteString.Builder as Builder-import Data.Bifunctor ( bimap ) import Data.Char ( toUpper, isSpace )-import Data.Either ( partitionEithers )-import Data.Foldable ( traverse_) import Data.List ( sortBy, isPrefixOf, intersperse ) import Data.Maybe import System.Directory import System.FilePath hiding ( (</>) ) import qualified System.IO as IO-import qualified System.FilePath as FilePath import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set hiding ( Set ) import Data.Ord ( comparing ) -import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) )+import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..), anchor ) import GHC.Types.Name import GHC.Unit.State @@ -73,7 +68,6 @@ -> Maybe String -- ^ The mathjax URL (--mathjax) -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki)- -> BaseURL -- ^ The base URL (--base-url) -> Maybe String -- ^ The contents URL (--use-contents) -> Maybe String -- ^ The index URL (--use-index) -> Bool -- ^ Whether to use unicode in output (--use-unicode)@@ -85,7 +79,7 @@ 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+ maybe_contents_url maybe_index_url unicode pkg qual debug withQuickjump = do let visible_ifaces = filter visible ifaces@@ -103,12 +97,12 @@ themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug - when withQuickjump $- ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual- visible_ifaces []+ when withQuickjump $+ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual+ visible_ifaces mapM_ (ppHtmlModule odir doctitle themes- maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url+ maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces @@ -125,23 +119,16 @@ return () -headHtml :: String -> Themes -> Maybe String -> Maybe String -> Html-headHtml docTitle themes mathjax_url base_url =- header ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url ]) base_url)- <<+headHtml :: String -> Themes -> Maybe String -> Html+headHtml docTitle themes mathjax_url =+ header << [ meta ! [ httpequiv "Content-Type", content "text/html; charset=UTF-8"] , meta ! [ XHtml.name "viewport", content "width=device-width, initial-scale=1"] , thetitle << docTitle- , styleSheet base_url themes- , thelink ! [ rel "stylesheet"- , thetype "text/css"- , href (withBaseURL base_url quickJumpCssFile) ]- << noHtml+ , styleSheet themes+ , thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml , thelink ! [ rel "stylesheet", thetype "text/css", href fontUrl] << noHtml- , script ! [ src (withBaseURL base_url haddockJsFile)- , emptyAttr "async"- , thetype "text/javascript" ]- << noHtml+ , script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf , script ! [src mjUrl, thetype "text/javascript"] << noHtml ]@@ -294,7 +281,7 @@ | iface <- ifaces , instIsSig iface] html =- headHtml doctitle themes mathjax_url Nothing ++++ headHtml doctitle themes mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [@@ -374,35 +361,6 @@ -- * Generate the index -------------------------------------------------------------------------------- -data JsonIndexEntry = JsonIndexEntry {- jieHtmlFragment :: String,- jieName :: String,- jieModule :: String,- jieLink :: String- }- deriving Show--instance ToJSON JsonIndexEntry where- toJSON JsonIndexEntry- { jieHtmlFragment- , jieName- , jieModule- , jieLink } =- Object- [ "display_html" .= String jieHtmlFragment- , "name" .= String jieName- , "module" .= String jieModule- , "link" .= String jieLink- ]--instance FromJSON JsonIndexEntry where- parseJSON = withObject "JsonIndexEntry" $ \v ->- JsonIndexEntry- <$> v .: "display_html"- <*> v .: "name"- <*> v .: "module"- <*> v .: "link"- ppJsonIndex :: FilePath -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki)@@ -410,50 +368,34 @@ -> Maybe Package -> QualOption -> [Interface]- -> [FilePath] -- ^ file paths to interface files- -- (--read-interface) -> IO ()-ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces installedIfacesPaths = do+ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = do createDirectoryIfMissing True odir- (errors, installedIndexes) <-- partitionEithers- <$> traverse- (\ifaceFile ->- let indexFile = takeDirectory ifaceFile- FilePath.</> "doc-index.json" in- bimap (indexFile,) (map (fixLink ifaceFile))- <$> eitherDecodeFile @[JsonIndexEntry] indexFile)- installedIfacesPaths- traverse_ (\(indexFile, err) -> putStrLn $ "haddock: Coudn't parse " ++ indexFile ++ ": " ++ err)- errors- IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h ->- Builder.hPutBuilder- h (encodeToBuilder (encodeIndexes (concat installedIndexes)))+ IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do+ Builder.hPutBuilder h (encodeToBuilder modules) where- encodeIndexes :: [JsonIndexEntry] -> Value- encodeIndexes installedIndexes =- toJSON- (concatMap fromInterface ifaces- ++ installedIndexes)+ modules :: Value+ modules = Array (concatMap goInterface ifaces) - fromInterface :: Interface -> [JsonIndexEntry]- fromInterface iface =- mkIndex mdl qual `mapMaybe` ifaceRnExportItems iface+ goInterface :: Interface -> [Value]+ goInterface iface =+ concatMap (goExport mdl qual) (ifaceRnExportItems iface) where aliases = ifaceModuleAliases iface qual = makeModuleQual qual_opt aliases mdl mdl = ifaceMod iface - mkIndex :: Module -> Qualification -> ExportItem DocNameI -> Maybe JsonIndexEntry- mkIndex mdl qual item+ goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value]+ goExport mdl qual item | Just item_html <- processExport True links_info unicode pkg qual item- = Just JsonIndexEntry- { jieHtmlFragment = showHtmlFragment item_html- , jieName = unwords (map getOccString names)- , jieModule = moduleString mdl- , jieLink = fromMaybe "" (listToMaybe (map (nameLink mdl) names))- }- | otherwise = Nothing+ = [ Object+ [ "display_html" .= String (showHtmlFragment item_html)+ , "name" .= String (unwords (map getOccString names))+ , "module" .= String (moduleString mdl)+ , "link" .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names)))+ ]+ ]+ | otherwise = [] where names = exportName item ++ exportSubs item @@ -471,13 +413,6 @@ links_info = (maybe_source_url, maybe_wiki_url) - -- update link using relative path to output directory- fixLink :: FilePath- -> JsonIndexEntry -> JsonIndexEntry- fixLink ifaceFile jie = - jie { jieLink = makeRelative odir (takeDirectory ifaceFile)- FilePath.</> jieLink jie }- ppHtmlIndex :: FilePath -> String -> Maybe String@@ -506,7 +441,7 @@ where indexPage showLetters ch items =- headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing ++++ headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url maybe_contents_url Nothing << [@@ -606,11 +541,11 @@ ppHtmlModule :: FilePath -> String -> Themes- -> Maybe String -> SourceURLs -> WikiURLs -> BaseURL+ -> Maybe String -> SourceURLs -> WikiURLs -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes- maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url+ maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode pkg qual debug iface = do let mdl = ifaceMod iface@@ -628,7 +563,7 @@ = toHtml mdl_str real_qual = makeModuleQual qual aliases mdl html =- headHtml mdl_str_annot themes maybe_mathjax_url maybe_base_url ++++ headHtml mdl_str_annot themes maybe_mathjax_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [
haddock-api/src/Haddock/Backends/Xhtml/Decl.hs view
@@ -37,7 +37,7 @@ import GHC.Core.Type ( Specificity(..) ) import GHC.Types.Basic (PromotionFlag(..), isPromoted)-import GHC hiding (LexicalFixity(..))+import GHC hiding (LexicalFixity(..), fromMaybeContext) import GHC.Exts import GHC.Types.Name import GHC.Data.BooleanFormula@@ -58,40 +58,40 @@ -> Qualification -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of- TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities loc mbDoc d splice unicode pkg qual- TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual- TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual- TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual- SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames- (hsSigWcType lty) fixities splice unicode pkg qual- SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames- (hsSigTypeI lty) fixities splice unicode pkg qual- ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual+ TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities (locA loc) mbDoc d splice unicode pkg qual+ TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs (locA loc) mbDoc d pats splice unicode pkg qual+ TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities (locA loc) (mbDoc, fnArgsDoc) d splice unicode pkg qual+ TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities (locA loc) mbDoc subdocs d splice unicode pkg qual+ SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames+ (dropWildCards lty) fixities splice unicode pkg qual+ SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames+ lty fixities splice unicode pkg qual+ ForD _ d -> ppFor summ links (locA loc) (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ _ -> noHtml DerivD _ _ -> noHtml _ -> error "declaration not supported by ppDecl" ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->- [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->+ [LocatedN DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities splice unicode pkg qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->- [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->+ [DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual = ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ) splice unicode pkg qual HideEmptyContexts where- pp_typ = ppLType unicode qual HideEmptyContexts typ+ pp_typ = ppLSigType unicode qual HideEmptyContexts typ -- | Pretty print a pattern synonym ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName- -> [Located DocName] -- ^ names of patterns in declaration- -> LHsType DocNameI -- ^ type of patterns in declaration+ -> [LocatedN DocName] -- ^ names of patterns in declaration+ -> LHsSigType DocNameI -- ^ type of patterns in declaration -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual =@@ -102,7 +102,7 @@ ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->- [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->+ [DocName] -> [(DocName, Fixity)] -> (HsSigType DocNameI, Html) -> Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) splice unicode pkg qual emptyCtxts =@@ -119,7 +119,7 @@ | otherwise = html <+> ppFixities fixities qual -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI+ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsSigType DocNameI -> DocForDecl DocName -> (Html, Html, Html) -> Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html@@ -140,15 +140,24 @@ -- If one passes in a list of the available subdocs, any top-level `HsRecTy` -- found will be expanded out into their fields. ppSubSigLike :: Unicode -> Qualification- -> HsType DocNameI -- ^ type signature+ -> HsSigType DocNameI -- ^ type signature -> FnArgsDoc DocName -- ^ docs to add -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when -- we expand an `HsRecTy`) -> Html -> HideEmptyContexts -> [SubDecl]-ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ+ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep typ where+ do_sig_args :: Int -> Html -> HsSigType DocNameI -> [SubDecl]+ do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) =+ case outer_bndrs of+ HsOuterExplicit{hso_bndrs = bndrs} -> do_largs n (leader' bndrs) ltype+ HsOuterImplicit{} -> do_largs n leader ltype+ where+ leader' bndrs = leader <+> ppForAllPart unicode qual (mkHsForAllInvisTeleI bndrs)+ argDoc n = Map.lookup n argDocs + do_largs :: Int -> Html -> LHsType DocNameI -> [SubDecl] do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]@@ -158,7 +167,7 @@ leader' = leader <+> ppForAllPart unicode qual tele do_args n leader (HsQualTy _ lctxt ltype)- | null (unLoc lctxt)+ | null (fromMaybeContext lctxt) = do_largs n leader ltype | otherwise = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])@@ -222,7 +231,7 @@ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual- = ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual+ = ppFunSig summary links loc noHtml doc [name] typ fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -233,13 +242,14 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) splice unicode pkg qual- = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc+ = ppTypeOrFunSig summary links loc [name] sig_type doc (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) splice unicode pkg qual ShowEmptyToplevelContexts where+ sig_type = mkHsImplicitSigTypeI ltype hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars))- full = hdr <+> equals <+> ppPatSigType unicode qual ltype+ full = hdr <+> equals <+> ppPatSigType unicode qual (noLocA sig_type) occ = nameOccName . getName $ name fixs | summary = noHtml@@ -253,15 +263,14 @@ where htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms - ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan- -> [DocName] -> HsType DocNameI+ -> [DocName] -> HsSigType DocNameI -> Html ppSimpleSig links splice unicode qual emptyCtxts loc names typ = topDeclElem' names $ ppTypeSig True occNames ppTyp unicode where topDeclElem' = topDeclElem links loc splice- ppTyp = ppType unicode qual emptyCtxts typ+ ppTyp = ppSigType unicode qual emptyCtxts typ occNames = map getOccName names @@ -301,9 +310,9 @@ -- Individual equation of a closed type family ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl- ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n- , feqn_rhs = rhs- , feqn_pats = ts } })+ ppFamDeclEqn (FamEqn { feqn_tycon = L _ n+ , feqn_rhs = rhs+ , feqn_pats = ts }) = ( ppAppNameTypeArgs n ts unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing@@ -321,7 +330,7 @@ , pfdTyVars = tvs , pfdLName = L loc name }) unicode qual =- topDeclElem links loc splice [name] leader+ topDeclElem links (locA loc) splice [name] leader where leader = hsep [ ppFamilyLeader True info , ppAppNameTypes name (map unLoc tvs) unicode qual@@ -352,10 +361,11 @@ injAnn = case injectivity of Nothing -> noHtml- Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( keyword "|"- : ppLDocName qual Raw lhs- : arrow unicode- : map (ppLDocName qual Raw) rhs)+ Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( keyword "|"+ : ppLDocName qual Raw lhs+ : arrow unicode+ : map (ppLDocName qual Raw) rhs)+ Just _ -> error "ppFamHeader:XInjectivityAnn" -- | Print the keywords that begin the family declaration ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html@@ -426,10 +436,12 @@ ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Unicode+ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Unicode -> Qualification -> HideEmptyContexts -> Html-ppLContext = ppContext . unLoc-ppLContextNoArrow = ppContextNoArrow . unLoc+ppLContext Nothing u q h = ppContext [] u q h+ppLContext (Just c) u q h = ppContext (unLoc c) u q h+ppLContextNoArrow Nothing u q h = ppContextNoArrow [] u q h+ppLContextNoArrow (Just c) u q h = ppContextNoArrow (unLoc c) u q h ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $@@ -463,22 +475,23 @@ ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName- -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]+ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName+ -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class"- <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)+ <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode qual HideEmptyContexts else noHtml) <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs) <+> ppFds fds unicode qual -ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html+ppFds :: [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html ppFds fds unicode qual = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where- fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2+ fundep (FunDep _ vars1 vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2+ fundep (XFunDep _) = error "ppFds" ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc) ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan@@ -497,7 +510,7 @@ -- ToDo: add associated type defaults - [ ppFunSig summary links loc noHtml doc names (hsSigTypeI typ)+ [ ppFunSig summary links loc noHtml doc names typ [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs@@ -561,14 +574,14 @@ lookupDAT name = Map.lookup (getName name) defaultAssocTys defaultAssocTys = Map.fromList [ (getName name, (vs, typ))- | L _ (TyFamInstDecl (HsIB _ (FamEqn { feqn_rhs = typ- , feqn_tycon = L _ name- , feqn_pats = vs }))) <- atsDefs+ | L _ (TyFamInstDecl _ (FamEqn { feqn_rhs = typ+ , feqn_tycon = L _ name+ , feqn_pats = vs })) <- atsDefs ] -- Methods methodBit = subMethods- [ ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ)+ [ ppFunSig summary links loc noHtml doc [name] typ subfixs splice unicode pkg qual <+> subDefaults (maybeToList defSigs)@@ -583,7 +596,7 @@ -- Default methods ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default")- d' [n] (hsSigTypeI t) [] splice unicode pkg qual+ d' [n] t [] splice unicode pkg qual lookupDM name = Map.lookup (getOccString name) defaultMethods defaultMethods = Map.fromList@@ -634,13 +647,11 @@ -- force Splice = True to use line URLs where instName = getOccString origin- instDecl :: Int -> DocInstance DocNameI -> (String, SubDecl, Maybe Module, Located DocName)+ instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName) instDecl no (inst, mdoc, loc, mdl) =- (instanceAnchor, mModule, mdl, loc)- where- instanceAnchor = getOccString (ihdClsName inst) <> "_" <> show no <> ":"- mModule = ppInstHead links splice unicode qual mdoc origin False no inst mdl+ ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), mdl, loc) + ppOrphanInstances :: LinksInfo -> [DocInstance DocNameI] -> Splice -> Unicode -> Maybe Package -> Qualification@@ -651,12 +662,9 @@ instOrigin :: InstHead name -> InstOrigin (IdP name) instOrigin inst = OriginClass (ihdClsName inst) - instDecl :: Int -> DocInstance DocNameI -> (String, SubDecl, Maybe Module, Located DocName)+ instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName) instDecl no (inst, mdoc, loc, mdl) =- (instanceAnchor, mModule, mdl, loc)- where- instanceAnchor = getOccString (ihdClsName inst) <> "_" <> show no <> ":"- mModule = ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing+ ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing), mdl, loc) ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification@@ -714,10 +722,10 @@ ppInstanceSigs links splice unicode qual sigs = do TypeSig _ lnames typ <- sigs let names = map unLoc lnames- L _ rtyp = hsSigWcType typ+ 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 (getLoc $ 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@@ -777,7 +785,7 @@ pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode- , ppPatSigType unicode qual (hsSigTypeI typ)+ , ppPatSigType unicode qual typ ] | (SigD _ (PatSynSig _ lnames typ),_) <- pats ]@@ -822,7 +830,7 @@ [ ppSideBySideConstr subdocs subfixs unicode pkg qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)- (map unLoc (getConNamesI (unLoc c)))) fixities+ (map unL (getConNamesI (unLoc c)))) fixities ] patternBit = subPatterns pkg qual@@ -849,14 +857,14 @@ = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars- , con_forall = L _ forall_+ , con_forall = forall_ , con_mb_cxt = cxt- } -> let context = unLoc (fromMaybe (noLoc []) cxt)+ } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a'- PrefixCon args ->+ PrefixCon _ args -> ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) , noHtml , noHtml@@ -883,13 +891,13 @@ -- GADT constructor, e.g. 'Foo :: Int -> Foo' ConDeclGADT {} ->- ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ]+ ( hsep [ ppOcc, dcolon unicode, ppLSigType unicode qual HideEmptyContexts (getGADTConType con) ] , noHtml , noHtml ) where- occ = map (nameOccName . getName . unLoc) $ getConNamesI con+ occ = map (nameOccName . getName . unL) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder summary) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) @@ -906,10 +914,10 @@ ) where -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list)- aConName = unLoc (head (getConNamesI con))+ aConName = unL (head (getConNamesI con)) fixity = ppFixities fixities qual- occ = map (nameOccName . getName . unLoc) $ getConNamesI con+ occ = map (nameOccName . getName . unL) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder False) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ))@@ -921,13 +929,13 @@ decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars- , con_forall = L _ forall_+ , con_forall = forall_ , con_mb_cxt = cxt- } -> let context = unLoc (fromMaybe (noLoc []) cxt)+ } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a'- PrefixCon args+ PrefixCon _ args | hasArgDocs -> header_ <+> ppOcc <+> fixity | otherwise -> hsep [ header_ <+> ppOcc , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args)@@ -952,24 +960,26 @@ | otherwise -> hsep [ ppOcc , dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT- , ppLType unicode qual HideEmptyContexts (getGADTConType con)+ , ppLSigType unicode qual HideEmptyContexts (getGADTConType con) , fixity ] - fieldPart = case (con, getConArgsI con) of- -- Record style GADTs- (ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ]-- -- Regular record declarations- (_, RecCon (L _ fields)) -> [ doRecordFields fields ]-- -- Any GADT or a regular H98 prefix data constructor- (_, PrefixCon args) | hasArgDocs -> [ doConstrArgsWithDocs args ]-- -- An infix H98 data constructor- (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]+ fieldPart = case con of+ ConDeclGADT{con_g_args = con_args'} -> case con_args' of+ -- GADT record declarations+ RecConGADT _ -> [ doConstrArgsWithDocs [] ]+ -- GADT prefix data constructors+ PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ]+ _ -> [] - _ -> []+ ConDeclH98{con_args = con_args'} -> case con_args' of+ -- H98 record declarations+ RecCon (L _ fields) -> [ doRecordFields fields ]+ -- H98 prefix data constructors+ PrefixCon _ args | hasArgDocs -> [ doConstrArgsWithDocs args ]+ -- H98 infix data constructor+ InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]+ _ -> [] doRecordFields fields = subFields pkg qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))@@ -986,7 +996,7 @@ -- 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 $ getConNamesI con) subdocs >>=+ mbDoc = lookup (unL $ head $ getConNamesI con) subdocs >>= combineDocumentation . fst @@ -1036,7 +1046,7 @@ -- | Pretty print an expanded pattern (for bundled patterns) ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification- -> [Located DocName] -- ^ pattern name(s)+ -> [LocatedN DocName] -- ^ pattern name(s) -> LHsSigType DocNameI -- ^ type of pattern(s) -> DocForDecl DocName -- ^ doc map -> SubDecl@@ -1054,18 +1064,17 @@ | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode- , ppPatSigType unicode qual (hsSigTypeI typ)+ , ppPatSigType unicode qual typ , fixity ] fieldPart | not hasArgDocs = []- | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc patTy)+ | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc typ) argDocs [] (dcolon unicode) emptyCtxt) ] - patTy = hsSigTypeI typ- emptyCtxt = patSigContext patTy+ emptyCtxt = patSigContext typ -- | Print the LHS of a data\/newtype declaration.@@ -1114,11 +1123,14 @@ -- * Rendering of HsType -------------------------------------------------------------------------------- -ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html+ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> LHsType DocNameI -> Html ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y) ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) +ppLSigType :: Unicode -> Qualification -> HideEmptyContexts -> LHsSigType DocNameI -> Html+ppLSigType unicode qual emptyCtxts y = ppSigType unicode qual emptyCtxts (unLoc y)+ ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts @@ -1127,6 +1139,9 @@ ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts +ppSigType :: Unicode -> Qualification -> HideEmptyContexts -> HsSigType DocNameI -> Html+ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode qual emptyCtxts+ ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <>@@ -1140,7 +1155,7 @@ 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 <+>+ parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) instance RenderableBndrFlag Specificity where@@ -1149,10 +1164,10 @@ ppHsTyVarBndr _ qual (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) =- parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>+ parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) =- braces (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>+ braces (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html@@ -1161,32 +1176,38 @@ ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts -patSigContext :: LHsType name -> HideEmptyContexts-patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts- | otherwise = HideEmptyContexts+patSigContext :: LHsSigType DocNameI -> HideEmptyContexts+patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts+ | otherwise = HideEmptyContexts where- hasNonEmptyContext :: LHsType name -> Bool+ typ = sig_body (unLoc sig_typ)+ hasNonEmptyContext t = case unLoc t of HsForAllTy _ _ s -> hasNonEmptyContext s- HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True+ HsQualTy _ cxt s -> if null (fromMaybeContext cxt) then hasNonEmptyContext s else True HsFunTy _ _ _ s -> hasNonEmptyContext s _ -> False- isFirstContextEmpty :: LHsType name -> Bool isFirstContextEmpty t = case unLoc t of HsForAllTy _ _ s -> isFirstContextEmpty s- HsQualTy _ cxt _ -> null (unLoc cxt)+ HsQualTy _ cxt _ -> null (fromMaybeContext cxt) HsFunTy _ _ _ s -> isFirstContextEmpty s _ -> False -- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in -- the right 'HideEmptyContext' value)-ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html+ppPatSigType :: Unicode -> Qualification -> LHsSigType DocNameI -> Html ppPatSigType unicode qual typ =- let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ+ let emptyCtxts = patSigContext typ in ppLSigType unicode qual emptyCtxts typ +ppHsOuterTyVarBndrs :: RenderableBndrFlag flag+ => Unicode -> Qualification -> HsOuterTyVarBndrs flag DocNameI -> Html+ppHsOuterTyVarBndrs unicode qual outer_bndrs = case outer_bndrs of+ HsOuterImplicit{} -> noHtml+ HsOuterExplicit{hso_bndrs = bndrs} ->+ hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html ppForAllPart unicode qual tele = case tele of@@ -1196,6 +1217,10 @@ HsForAllInvis { hsf_invis_bndrs = bndrs } -> hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot +ppr_sig_ty :: HsSigType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode qual emptyCtxts+ = ppHsOuterTyVarBndrs unicode qual outer_bndrs <+> ppr_mono_lty ltype unicode qual emptyCtxts+ ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ty = ppr_mono_ty (unLoc ty) @@ -1223,9 +1248,9 @@ , arr <+> ppr_mono_lty ty2 u q e ] where arr = case mult of- HsLinearArrow _ -> lollipop u+ HsLinearArrow _ _ -> lollipop u HsUnrestrictedArrow _ -> arrow u- HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u+ HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u ppr_mono_ty (HsTupleTy _ con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys)@@ -1241,7 +1266,7 @@ -- 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 (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy"+ppr_mono_ty (XHsType {}) _ _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys@@ -1260,7 +1285,7 @@ -- `(:)` 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'+ | (getOccString . getName . unL) op == ":" = promoQuote ppr_op' | otherwise = ppr_op' ppr_op' = ppLDocName qual Infix op @@ -1277,3 +1302,4 @@ ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s)+ppr_tylit (HsCharTy _ c) = toHtml (show c)
haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -31,7 +31,7 @@ import Text.XHtml hiding ( name, p, quote ) import Data.Maybe (fromMaybe) -import GHC+import GHC hiding (anchor) import GHC.Types.Name
haddock-api/src/Haddock/Backends/Xhtml/Layout.hs view
@@ -51,7 +51,7 @@ import Data.Maybe (fromMaybe) import GHC.Data.FastString ( unpackFS )-import GHC+import GHC hiding (anchor) import GHC.Types.Name (nameOccName) --------------------------------------------------------------------------------@@ -153,16 +153,16 @@ -- | Sub table with source information (optional). subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool- -> [(String, SubDecl, Maybe Module, Located DocName)] -> Maybe Html+ -> [(SubDecl, Maybe Module, Located DocName)] -> Maybe Html subTableSrc _ _ _ _ [] = Nothing subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) where- subRow (instanchor, (decl, mdoc, subs), mdl, L loc dn) =+ subRow ((decl, mdoc, subs), mdl, L loc dn) = (td ! [theclass "src clearfix"] << (thespan ! [theclass "inst-left"] << decl) <+> linkHtml loc mdl dn <->- docElement td << fmap (docToHtml (Just instanchor) pkg qual) mdoc+ docElement td << fmap (docToHtml Nothing pkg qual) mdoc ) : map (cell . (td <<)) subs @@ -201,7 +201,7 @@ subInstances :: Maybe Package -> Qualification -> String -- ^ Class name, used for anchor generation -> LinksInfo -> Bool- -> [(String, SubDecl, Maybe Module, Located DocName)] -> Html+ -> [(SubDecl, Maybe Module, Located DocName)] -> Html subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable where wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents))@@ -214,7 +214,7 @@ subOrphanInstances :: Maybe Package -> Qualification -> LinksInfo -> Bool- -> [(String, SubDecl, Maybe Module, Located DocName)] -> Html+ -> [(SubDecl, Maybe Module, Located DocName)] -> Html subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable where wrap = ((h1 << "Orphan instances") +++)
haddock-api/src/Haddock/Backends/Xhtml/Names.hs view
@@ -27,7 +27,7 @@ import qualified Data.Map as M import Data.List ( stripPrefix ) -import GHC hiding (LexicalFixity(..))+import GHC hiding (LexicalFixity(..), anchor) import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Data.FastString (unpackFS)@@ -57,8 +57,9 @@ occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName -- The Bool indicates if it is to be rendered in infix notation-ppLDocName :: Qualification -> Notation -> Located DocName -> Html+ppLDocName :: Qualification -> Notation -> GenLocated l DocName -> Html ppLDocName qual notation (L _ d) = ppDocName qual notation True d+ ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html ppDocName qual notation insertAnchors docName =
haddock-api/src/Haddock/Backends/Xhtml/Themes.hs view
@@ -17,7 +17,6 @@ where import Haddock.Options-import Haddock.Backends.Xhtml.Types ( BaseURL, withBaseURL ) import Control.Monad (liftM) import Data.Char (toLower)@@ -177,13 +176,13 @@ cssFiles ts = nub $ concatMap themeFiles ts -styleSheet :: BaseURL -> Themes -> Html-styleSheet base_url ts = toHtml $ zipWith mkLink rels ts+styleSheet :: Themes -> Html+styleSheet ts = toHtml $ zipWith mkLink rels ts where rels = "stylesheet" : repeat "alternate stylesheet" mkLink aRel t = thelink- ! [ href (withBaseURL base_url (themeHref t)), rel aRel, thetype "text/css",+ ! [ href (themeHref t), rel aRel, thetype "text/css", XHtml.title (themeName t) ] << noHtml
haddock-api/src/Haddock/Backends/Xhtml/Types.hs view
@@ -12,8 +12,6 @@ ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Types ( SourceURLs, WikiURLs,- BaseURL,- withBaseURL, LinksInfo, Splice, Unicode,@@ -22,21 +20,12 @@ import Data.Map import GHC-import qualified System.FilePath as FilePath -- the base, module and entity URLs for the source code and wiki links. type SourceURLs = (Maybe FilePath, Maybe FilePath, Map Unit FilePath, Map Unit FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) --- | base url for loading js, json, css resources. The default is "."----type BaseURL = Maybe String---- TODO: we shouldn't use 'FilePath.</>'-withBaseURL :: BaseURL -> String -> String-withBaseURL Nothing uri = uri-withBaseURL (Just baseUrl) uri = baseUrl FilePath.</> uri -- The URL for source and wiki links type LinksInfo = (SourceURLs, WikiURLs)
haddock-api/src/Haddock/Convert.hs view
@@ -22,8 +22,9 @@ #include "HsVersions.h" import GHC.Data.Bag ( emptyBag )-import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..)- , PromotionFlag(..), DefMethSpec(..) )+import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..), TopLevelFlag(..) )+import GHC.Types.SourceText (SourceText(..))+import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Core.Class import GHC.Core.Coercion.Axiom import GHC.Core.ConLike@@ -31,6 +32,7 @@ import GHC.Core.DataCon import GHC.Core.FamInstEnv import GHC.Hs+import GHC.Types.TyThing import GHC.Types.Name import GHC.Types.Name.Set ( emptyNameSet ) import GHC.Types.Name.Reader ( mkVarUnqual )@@ -43,19 +45,18 @@ import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName , unitTy, promotedNilDataCon, promotedConsDataCon ) import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey- , liftedRepDataConKey )+ , liftedDataConKey, boxedRepDataConKey ) import GHC.Types.Unique ( getUnique ) import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength , filterByList, filterOut )-import GHC.Utils.Outputable ( assertPanic )+import GHC.Utils.Panic ( assertPanic ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.SrcLoc-import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Haddock.Types import Haddock.Interface.Specialize-import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars )+import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars, mkEmptySigType ) import Data.Maybe ( catMaybes, mapMaybe, maybeToList ) @@ -90,26 +91,26 @@ extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" - cvt (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n- cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noExtField- (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind- cvt (XTyVarBndr nec) = noExtCon nec+ cvt :: HsTyVarBndr flag GhcRn -> HsType GhcRn+ -- Without this signature, we trigger GHC#18932+ cvt (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n+ cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noAnn+ (L (na2la name_loc) (HsTyVar noAnn NotPromoted (L name_loc n))) kind -- | Convert a LHsTyVarBndr to an equivalent LHsType.- hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p)+ hsLTyVarBndrToType :: LHsTyVarBndr flag GhcRn -> LHsType GhcRn hsLTyVarBndrToType = mapLoc cvt extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn extractFamDefDecl fd rhs =- TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd)- , hsib_body = FamEqn- { feqn_ext = noExtField+ TyFamInstDecl noAnn $ FamEqn+ { feqn_ext = noAnn , feqn_tycon = fdLName fd- , feqn_bndrs = Nothing+ , feqn_bndrs = HsOuterImplicit{hso_ximplicit = hsq_ext (fdTyVars fd)} , feqn_pats = map (HsValArg . hsLTyVarBndrToType) $ hsq_explicit $ fdTyVars fd , feqn_fixity = fdFixity fd- , feqn_rhs = synifyType WithinType [] rhs }}+ , feqn_rhs = synifyType WithinType [] rhs } extractAtItem :: ClassATItem@@ -117,8 +118,8 @@ extractAtItem (ATI at_tc def) = do tyDecl <- synifyTyCon prr Nothing at_tc famDecl <- extractFamilyDecl tyDecl- let defEqnTy = fmap (noLoc . extractFamDefDecl famDecl . fst) def- pure (noLoc famDecl, defEqnTy)+ let defEqnTy = fmap (noLocA . extractFamDefDecl famDecl . fst) def+ pure (noLocA famDecl, defEqnTy) atTyClDecls = map extractAtItem (classATItems cl) (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls)@@ -126,14 +127,14 @@ in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl)- , tcdLName = synifyName cl+ , tcdLName = synifyNameN cl , tcdTyVars = synifyTyVars vs , tcdFixity = synifyFixity cl- , tcdFDs = map (\ (l,r) -> noLoc- (map (noLoc . getName) l, map (noLoc . getName) r) ) $+ , tcdFDs = map (\ (l,r) -> noLocA+ (FunDep noAnn (map (noLocA . getName) l) (map (noLocA . getName) r)) ) $ snd $ classTvsFds cl- , tcdSigs = noLoc (MinimalSig noExtField NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) :- [ noLoc tcdSig+ , tcdSigs = noLocA (MinimalSig noAnn NoSourceText . noLocA . fmap noLocA $ classMinimalDef cl) :+ [ noLocA tcdSig | clsOp <- classOpItems cl , tcdSig <- synifyTcIdSig vs clsOp ] , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature@@ -150,30 +151,30 @@ ACoAxiom ax -> synifyAxiom ax >>= allOK -- a data-constructor alone just gets rendered as a function:- AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noExtField [synifyName dc]+ AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noAnn [synifyNameN dc] (synifySigWcType ImplicitizeForAll [] (dataConWrapperType dc))) AConLike (PatSynCon ps) ->- allOK . SigD noExtField $ PatSynSig noExtField [synifyName ps] (synifyPatSynSigType ps)+ allOK . SigD noExtField $ PatSynSig noAnn [synifyNameN ps] (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x) synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })- = let name = synifyName tc+ = let name = synifyNameN tc args_types_only = filterOutInvisibleTypes tc args typats = map (synifyType WithinType []) args_types_only annot_typats = zipWith3 annotHsType args_poly args_types_only typats hs_rhs = synifyType WithinType [] rhs- in HsIB { hsib_ext = map tyVarName tkvs- , hsib_body = FamEqn { feqn_ext = noExtField- , feqn_tycon = name- , feqn_bndrs = Nothing+ outer_bndrs = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs} -- TODO: this must change eventually- , feqn_pats = map HsValArg annot_typats- , feqn_fixity = synifyFixity name- , feqn_rhs = hs_rhs } }+ in FamEqn { feqn_ext = noAnn+ , feqn_tycon = name+ , feqn_bndrs = outer_bndrs+ , feqn_pats = map HsValArg annot_typats+ , feqn_fixity = synifyFixity name+ , feqn_rhs = hs_rhs } where args_poly = tyConArgsPolyKinded tc @@ -183,7 +184,7 @@ , Just branch <- coAxiomSingleBranch_maybe ax = return $ InstD noExtField $ TyFamInstD noExtField- $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch }+ $ TyFamInstDecl { tfid_xtn = noAnn, tfid_eqn = synifyAxBranch tc branch } | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error@@ -201,7 +202,7 @@ synifyTyCon prr _coax tc | isFunTyCon tc || isPrimTyCon tc = return $- DataDecl { tcdLName = synifyName tc+ DataDecl { tcdLName = synifyNameN tc , tcdTyVars = HsQTvs { hsq_ext = [] -- No kind polymorphism , hsq_explicit = zipWith mk_hs_tv (map scaledThing tyVarKinds)@@ -213,21 +214,21 @@ , tcdDataDefn = HsDataDefn { dd_ext = noExtField , dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype:- , dd_ctxt = noLoc []+ , dd_ctxt = Nothing , dd_cType = Nothing , dd_kindSig = synifyDataTyConReturnKind tc -- we have their kind accurately: , dd_cons = [] -- No constructors- , dd_derivs = noLoc [] }+ , dd_derivs = [] } , tcdDExt = DataDeclRn False emptyNameSet } where -- tyConTyVars doesn't work on fun/prim, but we can make them up: mk_hs_tv realKind fakeTyVar- | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField () (noLoc (getName fakeTyVar))- | otherwise = noLoc $ KindedTyVar noExtField () (noLoc (getName fakeTyVar)) (synifyKindSig realKind)+ | isLiftedTypeKind realKind = noLocA $ UserTyVar noAnn () (noLocA (getName fakeTyVar))+ | otherwise = noLocA $ KindedTyVar noAnn () (noLocA (getName fakeTyVar)) (synifyKindSig realKind) conKind = defaultType prr (tyConKind tc)- tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind+ tyVarKinds = fst . splitFunTys . snd . splitInvisPiTys $ conKind synifyTyCon _prr _coax tc | Just flav <- famTyConFlav_maybe tc@@ -237,7 +238,7 @@ ClosedSynFamilyTyCon mb | Just (CoAxiom { co_ax_branches = branches }) <- mb -> mkFamDecl $ ClosedTypeFamily $ Just- $ map (noLoc . synifyAxBranch tc) (fromBranches branches)+ $ map (noLocA . synifyAxBranch tc) (fromBranches branches) | otherwise -> mkFamDecl $ ClosedTypeFamily $ Just [] BuiltInSynFamTyCon {}@@ -249,9 +250,10 @@ where resultVar = famTcResVar tc mkFamDecl i = return $ FamDecl noExtField $- FamilyDecl { fdExt = noExtField+ FamilyDecl { fdExt = noAnn , fdInfo = i- , fdLName = synifyName tc+ , fdTopLevel = TopLevel+ , fdLName = synifyNameN tc , fdTyVars = synifyTyVars (tyConVisibleTyVars tc) , fdFixity = synifyFixity tc , fdResultSig =@@ -264,7 +266,7 @@ synifyTyCon _prr coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdSExt = emptyNameSet- , tcdLName = synifyName tc+ , tcdLName = synifyNameN tc , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) , tcdFixity = synifyFixity tc , tcdRhs = synifyType WithinType [] ty }@@ -274,9 +276,9 @@ alg_nd = if isNewTyCon tc then NewType else DataType alg_ctx = synifyCtx (tyConStupidTheta tc) name = case coax of- Just a -> synifyName a -- Data families are named according to their+ Just a -> synifyNameN a -- Data families are named according to their -- CoAxioms, not their TyCons- _ -> synifyName tc+ _ -> synifyNameN tc tyvars = synifyTyVars (tyConVisibleTyVars tc) kindSig = synifyDataTyConReturnKind tc -- The data constructors.@@ -299,7 +301,7 @@ consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any.- alg_deriv = noLoc []+ alg_deriv = [] defn = HsDataDefn { dd_ext = noExtField , dd_ND = alg_nd , dd_ctxt = alg_ctx@@ -340,15 +342,15 @@ 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+ let rhs = map (noLocA . tyVarName) (filterByList inj tvs)+ in Just $ noLoc $ InjectivityAnn noAnn (noLocA lhs) rhs synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind | isLiftedTypeKind kind = noLoc $ NoSig noExtField | otherwise = noLoc $ KindSig noExtField (synifyKindSig kind) synifyFamilyResultSig (Just name) kind =- noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField () (noLoc name) (synifyKindSig kind))+ noLoc $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA 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@@ -362,59 +364,77 @@ -- infix *syntax*. use_infix_syntax = dataConIsInfix dc use_named_field_syntax = not (null field_tys)- name = synifyName dc+ name = synifyNameN dc -- con_qvars means a different thing depending on gadt-syntax (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors + outer_bndrs | null user_tvbndrs+ = HsOuterImplicit { hso_ximplicit = [] }+ | otherwise+ = HsOuterExplicit { hso_xexplicit = noExtField+ , hso_bndrs = map synifyTyVarBndr user_tvbndrs }+ -- skip any EqTheta, use 'orig'inal syntax ctx | null theta = Nothing- | otherwise = Just $ synifyCtx theta+ | otherwise = synifyCtx theta linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType [] (scaledThing ty) in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn- bang' -> noLoc $ HsBangTy noExtField bang' tySyn)+ bang' -> noLocA $ HsBangTy noAnn bang' tySyn) arg_tys (dataConSrcBangs dc) field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys- con_decl_field fl synTy = noLoc $- ConDeclField noExtField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy+ con_decl_field fl synTy = noLocA $+ ConDeclField noAnn [noLoc $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel 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)- (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys)- (False,True) -> case linear_tys of- [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)- _ -> Left "synifyDataCon: infix with non-2 args?"++ mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn)+ mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of+ (True,True) -> Left "synifyDataCon: contradiction!"+ (True,False) -> return $ RecCon (noLocA field_tys)+ (False,False) -> return $ PrefixCon noTypeArgs (map hsUnrestricted linear_tys)+ (False,True) -> case linear_tys of+ [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)+ _ -> Left "synifyDataCon: infix with non-2 args?"++ mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn+ mk_gadt_arg_tys+ | use_named_field_syntax = RecConGADT (noLocA field_tys)+ | otherwise = PrefixConGADT (map hsUnrestricted linear_tys)+ -- finally we get synifyDataCon's result!- in hs_arg_tys >>=- \hat ->- if use_gadt_syntax- then return $ noLoc $- ConDeclGADT { con_g_ext = []- , con_names = [name]- , con_forall = noLoc $ not $ null user_tvbndrs- , con_qvars = map synifyTyVarBndr user_tvbndrs- , con_mb_cxt = ctx- , con_args = hat- , con_res_ty = synifyType WithinType [] res_ty- , con_doc = Nothing }- else return $ noLoc $- ConDeclH98 { con_ext = noExtField- , con_name = name- , con_forall = noLoc False- , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs- , con_mb_cxt = ctx- , con_args = hat- , con_doc = Nothing }+ in if use_gadt_syntax+ then do+ let hat = mk_gadt_arg_tys+ return $ noLocA $ ConDeclGADT+ { con_g_ext = noAnn+ , con_names = [name]+ , con_bndrs = noLocA outer_bndrs+ , con_mb_cxt = ctx+ , con_g_args = hat+ , con_res_ty = synifyType WithinType [] res_ty+ , con_doc = Nothing }+ else do+ hat <- mk_h98_arg_tys+ return $ noLocA $ ConDeclH98+ { con_ext = noAnn+ , con_name = name+ , con_forall = False+ , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs+ , con_mb_cxt = ctx+ , con_args = hat+ , con_doc = Nothing } -synifyName :: NamedThing n => n -> Located Name-synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n)+synifyNameN :: NamedThing n => n -> LocatedN Name+synifyNameN n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n) +-- synifyName :: NamedThing n => n -> LocatedA Name+-- synifyName n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n)+ -- | Guess the fixity of a something with a name. This isn't quite right, since -- a user can always declare an infix name in prefix form or a prefix name in -- infix form. Unfortunately, that is not something we can usually reconstruct.@@ -428,7 +448,7 @@ -> [TyVar] -- ^ free variables in the type to convert -> Id -- ^ the 'Id' from which to get the type signature -> Sig GhcRn-synifyIdSig prr s vs i = TypeSig noExtField [synifyName i] (synifySigWcType s vs t)+synifyIdSig prr s vs i = TypeSig noAnn [synifyNameN i] (synifySigWcType s vs t) where t = defaultType prr (varType i) @@ -437,15 +457,15 @@ -- 'ClassOpSig'. synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn] synifyTcIdSig vs (i, dm) =- [ ClassOpSig noExtField False [synifyName i] (mainSig (varType i)) ] ++- [ ClassOpSig noExtField True [noLoc dn] (defSig dt)+ [ ClassOpSig noAnn False [synifyNameN i] (mainSig (varType i)) ] +++ [ ClassOpSig noAnn True [noLocA dn] (defSig dt) | Just (dn, GenericDM dt) <- [dm] ] where mainSig t = synifySigType DeleteTopLevelQuantification vs t defSig t = synifySigType ImplicitizeForAll vs t -synifyCtx :: [PredType] -> LHsContext GhcRn-synifyCtx = noLoc . map (synifyType WithinType [])+synifyCtx :: [PredType] -> Maybe (LHsContext GhcRn)+synifyCtx ts = Just (noLocA ( map (synifyType WithinType []) ts)) synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn@@ -466,8 +486,8 @@ synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn synify_ty_var no_kinds flag tv | isLiftedTypeKind kind || tv `elemVarSet` no_kinds- = noLoc (UserTyVar noExtField flag (noLoc name))- | otherwise = noLoc (KindedTyVar noExtField flag (noLoc name) (synifyKindSig kind))+ = noLocA (UserTyVar noAnn flag (noLocA name))+ | otherwise = noLocA (KindedTyVar noAnn flag (noLocA name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv@@ -484,7 +504,7 @@ | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty = let ki = typeKind ty hs_ki = synifyType WithinType [] ki- in noLoc (HsKindSig noExtField hs_ty hs_ki)+ in noLocA (HsKindSig noAnn hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty -- | For every argument type that a type constructor accepts,@@ -526,17 +546,17 @@ synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn--- The empty binders is a bit suspicious;--- what if the type has free variables?-synifySigType s vs ty = mkEmptyImplicitBndrs (synifyType s vs ty)+-- The use of mkEmptySigType (which uses empty binders in OuterImplicit)+-- is a bit suspicious; what if the type has free variables?+synifySigType s vs ty = mkEmptySigType (synifyType s vs ty) synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType)-synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s vs ty))+synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (synifyType s vs ty)) synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType)-synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)+synifyPatSynSigType ps = mkEmptySigType (synifyPatSynType ps) -- | Depending on the first argument, try to default all type variables of kind -- 'RuntimeRep' to 'LiftedType'.@@ -550,7 +570,7 @@ -> [TyVar] -- ^ free variables in the type to convert -> Type -- ^ the type to convert -> LHsType GhcRn-synifyType _ _ (TyVarTy tv) = noLoc $ HsTyVar noExtField NotPromoted $ noLoc (getName tv)+synifyType _ _ (TyVarTy tv) = noLocA $ HsTyVar noAnn NotPromoted $ noLocA (getName tv) synifyType _ vs (TyConApp tc tys) = maybe_sig res_ty where@@ -558,65 +578,66 @@ res_ty -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473) | tc `hasKey` tYPETyConKey- , [TyConApp lev []] <- tys- , lev `hasKey` liftedRepDataConKey- = noLoc (HsTyVar noExtField NotPromoted (noLoc liftedTypeKindTyConName))+ , [TyConApp rep [TyConApp lev []]] <- tys+ , rep `hasKey` boxedRepDataConKey+ , lev `hasKey` liftedDataConKey+ = noLocA (HsTyVar noAnn NotPromoted (noLocA liftedTypeKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc , tyConArity tc == tys_len- = noLoc $ HsTupleTy noExtField+ = noLocA $ HsTupleTy noAnn (case sort of- BoxedTuple -> HsBoxedTuple- ConstraintTuple -> HsConstraintTuple+ BoxedTuple -> HsBoxedOrConstraintTuple+ ConstraintTuple -> HsBoxedOrConstraintTuple UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType vs) vis_tys)- | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExtField (map (synifyType WithinType vs) vis_tys)+ | isUnboxedSumTyCon tc = noLocA $ HsSumTy noAnn (map (synifyType WithinType vs) vis_tys) | Just dc <- isPromotedDataCon_maybe tc , isTupleDataCon dc , dataConSourceArity dc == length vis_tys- = noLoc $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys)+ = noLocA $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys) -- ditto for lists | getName tc == listTyConName, [ty] <- vis_tys =- noLoc $ HsListTy noExtField (synifyType WithinType vs ty)+ noLocA $ HsListTy noAnn (synifyType WithinType vs ty) | tc == promotedNilDataCon, [] <- vis_tys- = noLoc $ HsExplicitListTy noExtField IsPromoted []+ = noLocA $ HsExplicitListTy noExtField IsPromoted [] | tc == promotedConsDataCon , [ty1, ty2] <- vis_tys = let hTy = synifyType WithinType vs ty1 in case synifyType WithinType vs ty2 of tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy- -> noLoc $ HsExplicitListTy noExtField IsPromoted (hTy : tTy')+ -> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy') | otherwise- -> noLoc $ HsOpTy noExtField hTy (noLoc $ getName tc) tTy+ -> noLocA $ HsOpTy noExtField hTy (noLocA $ getName tc) tTy -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name- = noLoc $ HsIParamTy noExtField (noLoc $ HsIPName x) (synifyType WithinType vs ty)+ = noLocA $ HsIParamTy noAnn (noLoc $ HsIPName x) (synifyType WithinType vs ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys- = noLoc $ HsOpTy noExtField+ = noLocA $ HsOpTy noExtField (synifyType WithinType vs ty1)- (noLoc eqTyConName)+ (noLocA eqTyConName) (synifyType WithinType vs ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) , ty1:ty2:tys_rest <- vis_tys = mk_app_tys (HsOpTy noExtField (synifyType WithinType vs ty1)- (noLoc $ getName tc)+ (noLocA $ getName tc) (synifyType WithinType vs ty2)) tys_rest -- Most TyCons: | otherwise- = mk_app_tys (HsTyVar noExtField prom $ noLoc (getName tc))+ = mk_app_tys (HsTyVar noAnn prom $ noLocA (getName tc)) vis_tys where prom = if isPromotedDataCon tc then IsPromoted else NotPromoted mk_app_tys ty_app ty_args =- foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2)- (noLoc ty_app)+ foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2)+ (noLocA ty_app) (map (synifyType WithinType vs) $ filterOut isCoercionTy ty_args) @@ -628,7 +649,7 @@ | tyConAppNeedsKindSig False tc tys_len = let full_kind = typeKind (mkTyConApp tc tys) full_kind' = synifyType WithinType vs full_kind- in noLoc $ HsKindSig noExtField ty' full_kind'+ in noLocA $ HsKindSig noAnn ty' full_kind' | otherwise = ty' synifyType _ vs ty@(AppTy {}) = let@@ -638,19 +659,19 @@ filterOut isCoercionTy $ filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) ty_args- in foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) ty_head' ty_args'+ in foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) ty_head' ty_args' synifyType s vs funty@(FunTy InvisArg _ _ _) = synifySigmaType s vs funty synifyType _ vs (FunTy VisArg w t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2 w' = synifyMult vs w- in noLoc $ HsFunTy noExtField w' s1 s2+ in noLocA $ HsFunTy noAnn w' s1 s2 synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) = case argf of Required -> synifyVisForAllType vs forallty Invisible _ -> synifySigmaType s vs forallty -synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExtField $ synifyTyLit t+synifyType _ _ (LitTy t) = noLocA $ HsTyLit noExtField $ synifyTyLit t synifyType s vs (CastTy t _) = synifyType s vs t synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" @@ -668,9 +689,9 @@ -- absence of an explicit forall tvs' = orderedFVs (mkVarSet vs) [rho] - in noLoc $ HsForAllTy { hst_tele = mkHsForAllVisTele sTvs- , hst_xforall = noExtField- , hst_body = synifyType WithinType (tvs' ++ vs) rho }+ in noLocA $ HsForAllTy { hst_tele = mkHsForAllVisTele noAnn sTvs+ , hst_xforall = noExtField+ , hst_body = synifyType WithinType (tvs' ++ vs) rho } -- | Process a 'Type' which starts with an invisible @forall@ or a constraint -- into an 'HsType'@@ -685,9 +706,9 @@ , hst_xqual = noExtField , hst_body = synifyType WithinType (tvs' ++ vs) tau } - sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs+ sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs , hst_xforall = noExtField- , hst_body = noLoc sPhi }+ , hst_body = noLocA sPhi } sTvs = map synifyTyVarBndr tvs @@ -700,8 +721,8 @@ -- Put a forall in if there are any type variables WithinType- | not (null tvs) -> noLoc sTy- | otherwise -> noLoc sPhi+ | not (null tvs) -> noLocA sTy+ | otherwise -> noLocA sPhi ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau @@ -717,9 +738,9 @@ -> Type -- ^ inner type -> LHsType GhcRn implicitForAll tycons vs tvs ctx synInner tau- | any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy- | tvs' /= (binderVars tvs) = noLoc sTy- | otherwise = noLoc sPhi+ | any (isHsKindedTyVar . unLoc) sTvs = noLocA sTy+ | tvs' /= (binderVars tvs) = noLocA sTy+ | otherwise = noLocA sPhi where sRho = synInner (tvs' ++ vs) tau sPhi | null ctx = unLoc sRho@@ -727,9 +748,9 @@ = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExtField , hst_body = synInner (tvs' ++ vs) tau }- sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs+ sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs , hst_xforall = noExtField- , hst_body = noLoc sPhi }+ , hst_body = noLocA sPhi } no_kinds_needed = noKindTyVars tycons tau sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs@@ -778,9 +799,9 @@ synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn synifyMult vs t = case t of- One -> HsLinearArrow NormalSyntax+ One -> HsLinearArrow NormalSyntax Nothing Many -> HsUnrestrictedArrow NormalSyntax- ty -> HsExplicitMult NormalSyntax (synifyType WithinType vs ty)+ ty -> HsExplicitMult NormalSyntax Nothing (synifyType WithinType vs ty) @@ -804,6 +825,7 @@ synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s+synifyTyLit (CharTyLit c) = HsCharTy NoSourceText c synifyKindSig :: Kind -> LHsKind GhcRn synifyKindSig k = synifyType WithinType [] k
haddock-api/src/Haddock/GhcUtils.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -21,17 +24,19 @@ import Control.Arrow import Data.Char ( isSpace )-import Data.Maybe ( mapMaybe )+import Data.Maybe ( mapMaybe, fromMaybe ) -import Haddock.Types( DocName, DocNameI )+import Haddock.Types( DocName, DocNameI, XRecCond ) import GHC.Utils.FV as FV-import GHC.Utils.Outputable ( Outputable, panic, showPpr )-import GHC.Types.Basic (PromotionFlag(..))+import GHC.Utils.Outputable ( Outputable )+import GHC.Utils.Panic ( panic )+import GHC.Driver.Ppr (showPpr ) import GHC.Types.Name import GHC.Unit.Module import GHC import GHC.Driver.Session+import GHC.Types.Basic import GHC.Types.SrcLoc ( advanceSrcLoc ) import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder , tyVarKind, updateTyVarKind, isInvisibleArgFlag )@@ -39,8 +44,7 @@ import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) import GHC.Core.TyCo.Rep ( Type(..) ) import GHC.Core.Type ( isRuntimeRepVar )-import GHC.Builtin.Types( liftedRepDataConTyCon )-import GHC.Parser.Annotation (IsUnicodeSyntax(..))+import GHC.Builtin.Types( liftedRepTy ) import GHC.Data.StringBuffer ( StringBuffer ) import qualified GHC.Data.StringBuffer as S@@ -49,6 +53,8 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS +import GHC.HsToCore.Docs+ moduleString :: Module -> String moduleString = moduleNameString . moduleName @@ -68,45 +74,32 @@ filterSigNames p (FixSig _ (FixitySig _ ns ty)) = case filter (p . unLoc) ns of [] -> Nothing- filtered -> Just (FixSig noExtField (FixitySig noExtField filtered ty))+ filtered -> Just (FixSig noAnn (FixitySig noExtField filtered ty)) filterSigNames _ orig@(MinimalSig _ _ _) = Just orig filterSigNames p (TypeSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing- filtered -> Just (TypeSig noExtField filtered ty)+ filtered -> Just (TypeSig noAnn filtered ty) filterSigNames p (ClassOpSig _ is_default ns ty) = case filter (p . unLoc) ns of [] -> Nothing- filtered -> Just (ClassOpSig noExtField is_default filtered ty)+ filtered -> Just (ClassOpSig noAnn is_default filtered ty) filterSigNames p (PatSynSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing- filtered -> Just (PatSynSig noExtField filtered ty)+ filtered -> Just (PatSynSig noAnn filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name ifTrueJust True = Just ifTrueJust False = const Nothing -sigName :: LSig name -> [IdP name]+sigName :: LSig GhcRn -> [IdP GhcRn] sigName (L _ sig) = sigNameNoLoc sig -sigNameNoLoc :: Sig name -> [IdP name]-sigNameNoLoc (TypeSig _ ns _) = map unLoc ns-sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns-sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns-sigNameNoLoc (SpecSig _ n _ _) = [unLoc n]-sigNameNoLoc (InlineSig _ n _) = [unLoc n]-sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns-sigNameNoLoc _ = []- -- | Was this signature given by the user?-isUserLSig :: LSig name -> Bool-isUserLSig (L _ (TypeSig {})) = True-isUserLSig (L _ (ClassOpSig {})) = True-isUserLSig (L _ (PatSynSig {})) = True-isUserLSig _ = False-+isUserLSig :: forall p. UnXRec p => LSig p -> Bool+isUserLSig = isUserSig . unXRec @p isClassD :: HsDecl a -> Bool isClassD (TyClD _ d) = isClassDecl d@@ -121,10 +114,10 @@ -- instantiated at DocNameI instead of (GhcPass _). -- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _)-hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr flag n -> IdP n-hsTyVarBndrName (UserTyVar _ _ name) = unLoc name-hsTyVarBndrName (KindedTyVar _ _ (L _ name) _) = name-hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec+hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ NoExtCon, UnXRec n)+ => HsTyVarBndr flag n -> IdP n+hsTyVarBndrName (UserTyVar _ _ name) = unXRec @n name+hsTyVarBndrName (KindedTyVar _ _ name _) = unXRec @n name hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName hsTyVarNameI (UserTyVar _ _ (L _ n)) = n@@ -133,50 +126,62 @@ hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName hsLTyVarNameI = hsTyVarNameI . unLoc -getConNamesI :: ConDecl DocNameI -> [Located DocName]+getConNamesI :: ConDecl DocNameI -> [LocatedN DocName] getConNamesI ConDeclH98 {con_name = name} = [name] getConNamesI ConDeclGADT {con_names = names} = names -hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing-hsImplicitBodyI (HsIB { hsib_body = body }) = body- hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI-hsSigTypeI = hsImplicitBodyI+hsSigTypeI = sig_body . unLoc +mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn+-- Dubious, because the implicit binders are empty even+-- though the type might have free varaiables+mkEmptySigType lty@(L loc ty) = L loc $ case ty of+ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }+ , hst_body = body }+ -> HsSig { sig_ext = noExtField+ , sig_bndrs = HsOuterExplicit { hso_xexplicit = noExtField+ , hso_bndrs = bndrs }+ , sig_body = body }+ _ -> HsSig { sig_ext = noExtField+ , sig_bndrs = HsOuterImplicit{hso_ximplicit = []}+ , sig_body = lty }+ mkHsForAllInvisTeleI :: [LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI mkHsForAllInvisTeleI invis_bndrs = HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs } -getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI-getConArgsI d = con_args d+mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI+mkHsImplicitSigTypeI body =+ HsSig { sig_ext = noExtField+ , sig_bndrs = HsOuterImplicit{hso_ximplicit = noExtField}+ , sig_body = body } -getGADTConType :: ConDecl DocNameI -> LHsType DocNameI+getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So -- we are cavalier about locations and extensions, hence the -- 'undefined's-getGADTConType (ConDeclGADT { con_forall = L _ has_forall- , con_qvars = qtvs- , con_mb_cxt = mcxt, con_args = args+getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs+ , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty })- | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField- , hst_tele = mkHsForAllInvisTeleI qtvs- , hst_body = theta_ty })- | otherwise = theta_ty+ = noLocA (HsSig { sig_ext = noExtField+ , sig_bndrs = outer_bndrs+ , sig_body = theta_ty }) where theta_ty | Just theta <- mcxt- = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })+ = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = Just theta, hst_body = tau_ty }) | otherwise = tau_ty -- tau_ty :: LHsType DocNameI tau_ty = case args of- RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty- PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)- InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty)+ RecConGADT flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty+ PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) - mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)+ mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI+ mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT@@ -184,7 +189,7 @@ getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI] getMainDeclBinderI (TyClD _ d) = [tcdNameI d] getMainDeclBinderI (ValD _ d) =- case collectHsBindBinders d of+ case collectHsBindBinders CollNoDictBinders d of [] -> [] (name:_) -> [name] getMainDeclBinderI (SigD _ d) = sigNameNoLoc d@@ -192,10 +197,10 @@ getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinderI _ = [] -familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName+familyDeclLNameI :: FamilyDecl DocNameI -> LocatedN DocName familyDeclLNameI (FamilyDecl { fdLName = n }) = n -tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName+tyClDeclLNameI :: TyClDecl DocNameI -> LocatedN DocName tyClDeclLNameI (FamDecl { tcdFam = fd }) = familyDeclLNameI fd tyClDeclLNameI (SynDecl { tcdLName = ln }) = ln tyClDeclLNameI (DataDecl { tcdLName = ln }) = ln@@ -204,73 +209,35 @@ tcdNameI :: TyClDecl DocNameI -> DocName tcdNameI = unLoc . tyClDeclLNameI --- ---------------------------------------getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn--- The full type of a GADT data constructor We really only get this in--- order to pretty-print it, and currently only in Haddock's code. So--- we are cavalier about locations and extensions, hence the--- 'undefined's-getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall- , con_qvars = qtvs- , con_mb_cxt = mcxt, con_args = args- , con_res_ty = res_ty })- | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField- , hst_tele = mkHsForAllInvisTele qtvs- , hst_body = theta_ty })- | otherwise = theta_ty- where- theta_ty | Just theta <- mcxt- = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })- | otherwise- = tau_ty---- tau_ty :: LHsType DocNameI- tau_ty = case args of- RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty- PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)- InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty)-- -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI- mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)--getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"- -- Should only be called on ConDeclGADT---mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn--- Dubious, because the implicit binders are empty even--- though the type might have free varaiables-mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty)-- addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))- = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype))))- -- The mkEmptySigWcType is suspicious+ = L pos (TypeSig noAnn lname (mkEmptyWildCardBndrs (go_sig_ty ltype))) where- go (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))- = L loc (HsForAllTy { hst_tele = tele, hst_xforall = noExtField- , hst_body = go ty })- go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))+ go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty }))+ = L loc (HsSig { sig_ext = noExtField+ , sig_bndrs = bndrs, sig_body = go_ty ty })++ go_ty (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))+ = L loc (HsForAllTy { hst_xforall = noExtField+ , hst_tele = tele, hst_body = go_ty ty })+ go_ty (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt ctxt, hst_body = ty })- go (L loc ty)+ go_ty (L loc ty) = L loc (HsQualTy { hst_xqual = noExtField- , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })+ , hst_ctxt = add_ctxt Nothing, hst_body = L loc ty }) - extra_pred :: LHsType GhcRn- extra_pred = nlHsTyConApp Prefix cls (map HsValArg (lHsQTyVarsToTypes tvs0))+ extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0) - add_ctxt :: LHsContext GhcRn -> LHsContext GhcRn- add_ctxt (L loc preds) = L loc (extra_pred : preds)+ add_ctxt Nothing = Just $ noLocA [extra_pred]+ add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds) addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine -lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]+lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn] lHsQTyVarsToTypes tvs- = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))+ = [ HsValArg $ noLocA (HsTyVar noAnn NotPromoted (noLocA (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] @@ -278,7 +245,6 @@ -- * Making abstract declarations -------------------------------------------------------------------------------- - restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn restrictTo names (L loc decl) = L loc $ case decl of TyClD x d | isDataDecl d ->@@ -301,17 +267,27 @@ restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where- keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =- case con_args d of- PrefixCon _ -> Just d- RecCon fields- | all field_avail (unLoc fields) -> Just d- | otherwise -> Just (d { con_args = PrefixCon (field_types $ unLoc 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+ keep :: ConDecl GhcRn -> Maybe (ConDecl GhcRn)+ keep d+ | any (\n -> n `elem` names) (map unLoc $ getConNames d) =+ case d of+ ConDeclH98 { con_args = con_args' } -> case con_args' of+ PrefixCon {} -> Just d+ RecCon fields+ | all field_avail (unLoc fields) -> Just d+ | otherwise -> Just (d { con_args = PrefixCon [] (field_types $ unLoc 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++ ConDeclGADT { con_g_args = con_args' } -> case con_args' of+ PrefixConGADT {} -> Just d+ RecConGADT fields+ | all field_avail (unLoc fields) -> Just d+ | otherwise -> Just (d { con_g_args = PrefixConGADT (field_types $ unLoc fields) })+ -- see above where field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField _ fs _ _))@@ -356,17 +332,18 @@ -- -- We cannot add parens that may be required by fixities because we do not have -- any fixity information to work with in the first place :(.-reparenTypePrec :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a+reparenTypePrec :: forall a. (XRecCond a)+ => Precedence -> HsType a -> HsType a reparenTypePrec = go where -- Shorter name for 'reparenType'- go :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a+ go :: XParTy a ~ EpAnn AnnParen => Precedence -> HsType a -> HsType a go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty) go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys) go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys) go _ (HsListTy x ty) = HsListTy x (reparenLType ty)- go _ (HsRecTy x flds) = HsRecTy x (map (fmap reparenConDeclField) flds)+ go _ (HsRecTy x flds) = HsRecTy x (map (mapXRec @a reparenConDeclField) flds) go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys) go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)@@ -379,7 +356,11 @@ go p (HsQualTy x ctxt ty) = let p' [_] = PREC_CTX p' _ = PREC_TOP -- parens will get added anyways later...- in paren p PREC_CTX $ HsQualTy x (fmap (\xs -> map (goL (p' xs)) xs) ctxt) (goL PREC_TOP ty)+ ctxt' = case ctxt of+ Nothing -> Nothing+ Just c -> Just $ mapXRec @a (\xs -> map (goL (p' xs)) xs) c+ in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty)+ -- = paren p PREC_FUN $ HsQualTy x (fmap (mapXRec @a (map reparenLType)) ctxt) (reparenLType ty) go p (HsFunTy x w ty1 ty2) = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2) go p (HsAppTy x fun_ty arg_ty)@@ -388,7 +369,7 @@ = paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki) go p (HsOpTy x ty1 op ty2) = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2)- go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed+ go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed go _ t@HsTyVar{} = t go _ t@HsStarTy{} = t go _ t@HsSpliceTy{} = t@@ -397,43 +378,58 @@ go _ t@XHsType{} = t -- Located variant of 'go'- goL :: (XParTy a ~ NoExtField) => Precedence -> LHsType a -> LHsType a- goL ctxt_prec = fmap (go ctxt_prec)+ goL :: XParTy a ~ EpAnn AnnParen => Precedence -> LHsType a -> LHsType a+ goL ctxt_prec = mapXRec @a (go ctxt_prec) -- Optionally wrap a type in parens- paren :: (XParTy a ~ NoExtField)+ paren :: XParTy a ~ EpAnn AnnParen => Precedence -- Precedence of context -> Precedence -- Precedence of top-level operator -> HsType a -> HsType a -- Wrap in parens if (ctxt >= op)- paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . noLoc+ paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noAnn . wrapXRec @a | otherwise = id -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')-reparenType :: (XParTy a ~ NoExtField) => HsType a -> HsType a+reparenType :: XRecCond a => HsType a -> HsType a reparenType = reparenTypePrec PREC_TOP -- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')-reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a-reparenLType = fmap reparenType+reparenLType :: forall a. (XRecCond a) => LHsType a -> LHsType a+reparenLType = mapXRec @a reparenType +-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec')+reparenSigType :: forall a. ( XRecCond a )+ => HsSigType a -> HsSigType a+reparenSigType (HsSig x bndrs body) =+ HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body)+reparenSigType v@XHsSigType{} = v++-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec')+reparenOuterTyVarBndrs :: forall flag a. ( XRecCond a )+ => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a+reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp+reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =+ HsOuterExplicit x (map (mapXRec @(NoGhcTc a) reparenTyVar) exp_bndrs)+reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v+ -- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')-reparenHsForAllTelescope :: (XParTy a ~ NoExtField)+reparenHsForAllTelescope :: forall a. (XRecCond a ) => HsForAllTelescope a -> HsForAllTelescope a reparenHsForAllTelescope (HsForAllVis x bndrs) =- HsForAllVis x (map (fmap reparenTyVar) bndrs)+ HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs) reparenHsForAllTelescope (HsForAllInvis x bndrs) =- HsForAllInvis x (map (fmap reparenTyVar) bndrs)+ HsForAllInvis x (map (mapXRec @a reparenTyVar) bndrs) reparenHsForAllTelescope v@XHsForAllTelescope{} = v -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')-reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a+reparenTyVar :: (XRecCond a) => HsTyVarBndr flag a -> HsTyVarBndr flag a reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind) reparenTyVar v@XTyVarBndr{} = v -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')-reparenConDeclField :: (XParTy a ~ NoExtField) => ConDeclField a -> ConDeclField a+reparenConDeclField :: (XRecCond a) => ConDeclField a -> ConDeclField a reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d reparenConDeclField c@XConDeclField{} = c @@ -443,13 +439,15 @@ ------------------------------------------------------------------------------- -unL :: Located a -> a+unL :: GenLocated l a -> a unL (L _ x) = x --reL :: a -> Located a+reL :: a -> GenLocated l a reL = L undefined +mapMA :: Monad m => (a -> m b) -> LocatedAn an a -> m (Located b)+mapMA f (L al a) = L (locA al) <$> f a+ ------------------------------------------------------------------------------- -- * NamedThing instances -------------------------------------------------------------------------------@@ -469,10 +467,9 @@ instance Parent (ConDecl GhcRn) where children con =- case con_args con of- RecCon fields -> map (extFieldOcc . unLoc) $- concatMap (cd_fld_names . unLoc) (unLoc fields)- _ -> []+ case getRecConArgs_maybe con of+ Nothing -> []+ Just flds -> map (extFieldOcc . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds) instance Parent (TyClDecl GhcRn) where children d@@ -738,7 +735,7 @@ go subs (TyVarTy tv) | tv `elemVarEnv` subs- = TyConApp liftedRepDataConTyCon []+ = liftedRepTy | otherwise = TyVarTy (updateTyVarKind (go subs) tv) @@ -756,3 +753,6 @@ go _ ty@(LitTy {}) = ty go _ ty@(CoercionTy {}) = ty++fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI+fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt
haddock-api/src/Haddock/Interface.hs view
@@ -43,39 +43,40 @@ import Haddock.Types (DocOption (..), Documentation (..), ExportItem (..), IfaceMap, InstIfaceMap, Interface, LinkEnv, expItemDecl, expItemMbDoc, ifaceDoc, ifaceExportItems, ifaceExports, ifaceHaddockCoverage, ifaceInstances, ifaceMod, ifaceOptions, ifaceVisibleExports, instMod, runWriter, throwE)-import Haddock.Utils (Verbosity, normal, out, verbose)+import Haddock.Utils (Verbosity (..), normal, out, verbose) import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.List (foldl', isPrefixOf, nub)+import Text.Printf (printf) import qualified Data.Map as Map import qualified Data.Set as Set-import Text.Printf (printf) import GHC hiding (verbosity) import GHC.Data.FastString (unpackFS)-import GHC.Data.Graph.Directed-import GHC.Driver.Monad (modifySession)+import GHC.Data.Graph.Directed (flattenSCCs)+import GHC.Driver.Env (hsc_dflags, hsc_home_unit, hsc_logger, hsc_static_plugins, hsc_units)+import GHC.Driver.Monad (modifySession, withTimingM) import GHC.Driver.Session hiding (verbosity)-import GHC.Driver.Types (isBootSummary) import GHC.HsToCore.Docs (getMainDeclBinder)-import GHC.Plugins (HscEnv (..), Outputable, Plugin (..), PluginWithArgs (..), StaticPlugin (..), defaultPlugin,- keepRenamedSource)+import GHC.Plugins (Outputable, Plugin (..), PluginWithArgs (..), StaticPlugin (..), defaultPlugin, keepRenamedSource) import GHC.Tc.Types (TcGblEnv (..), TcM) import GHC.Tc.Utils.Env (tcLookupGlobal)-import GHC.Tc.Utils.Monad (setGblEnv)+import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) import GHC.Types.Name.Occurrence (isTcOcc)-import GHC.Types.Name.Reader (globalRdrEnvElts, gre_name, unQualOK)+import GHC.Types.Name.Reader (globalRdrEnvElts, greMangledName, unQualOK) import GHC.Unit.Module.Env (ModuleSet, emptyModuleSet, mkModuleSet, unionModuleSet)+import GHC.Unit.Module.Graph (ModuleGraphNode (..))+import GHC.Unit.Module.ModSummary (emsModSummary, isBootSummary) import GHC.Unit.Types (IsBootInterface (..))-import GHC.Utils.Error (withTimingD)+import GHC.Utils.Error (withTiming) #if defined(mingw32_HOST_OS)-import GHC.IO.Encoding.CodePage (mkLocaleEncoding)-import GHC.IO.Encoding.Failure (CodingFailureMode (TransliterateCodingFailure)) import System.IO+import GHC.IO.Encoding.CodePage (mkLocaleEncoding)+import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure)) #endif -- | Create 'Interface's and a link environment by typechecking the list of@@ -112,7 +113,7 @@ mods = Set.fromList $ map ifaceMod interfaces out verbosity verbose "Attaching instances..." interfaces' <- {-# SCC attachInstances #-}- withTimingD "attachInstances" (const ()) $ do+ withTimingM "attachInstances" (const ()) $ do attachInstances (exportedNames, mods) interfaces instIfaceMap ms out verbosity verbose "Building cross-linking environment..."@@ -146,10 +147,10 @@ installHaddockPlugin :: HscEnv -> HscEnv installHaddockPlugin hsc_env = hsc_env {- hsc_dflags = (gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy)- {- staticPlugins = haddockPlugin : staticPlugins (hsc_dflags hsc_env)- }+ hsc_dflags =+ gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy+ , hsc_static_plugins =+ haddockPlugin : hsc_static_plugins hsc_env } -- Note that we would rather use withTempSession but as long as we@@ -160,7 +161,7 @@ targets <- mapM (\filePath -> guessTarget filePath Nothing) modules setTargets targets - loadOk <- withTimingD "load" (const ()) $+ loadOk <- withTimingM "load" (const ()) $ {-# SCC load #-} GHC.load LoadAllTargets case loadOk of@@ -176,9 +177,9 @@ ifaces = [ Map.findWithDefault (error "haddock:iface")- (ms_mod ms)+ (ms_mod (emsModSummary ems)) ifaceMap- | ms <- flattenSCCs $ topSortModuleGraph True modGraph Nothing+ | ModuleNode ems <- flattenSCCs $ topSortModuleGraph True modGraph Nothing ] return (ifaces, moduleSet)@@ -209,9 +210,11 @@ | IsBoot <- isBootSummary mod_summary = pure () | otherwise = do+ hsc_env <- getTopEnv ifaces <- liftIO $ readIORef ifaceMapRef- (iface, modules) <- withTimingD "processModule" (const ()) $- processModule1 verbosity flags ifaces instIfaceMap mod_summary tc_gbl_env+ (iface, modules) <- withTiming (hsc_logger hsc_env) (hsc_dflags hsc_env)+ "processModule" (const ()) $+ processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env liftIO $ do atomicModifyIORef' ifaceMapRef $ \xs ->@@ -249,44 +252,50 @@ -> [Flag] -> IfaceMap -> InstIfaceMap+ -> HscEnv -> ModSummary -> TcGblEnv -> TcM (Interface, ModuleSet)-processModule1 verbosity flags ifaces inst_ifaces mod_summary tc_gbl_env = do+processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env = do out verbosity verbose "Creating interface..." let TcGblEnv { tcg_rdr_env } = tc_gbl_env - (!interface, messages) <- {-# SCC createInterface #-}- withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $- createInterface1 flags mod_summary tc_gbl_env ifaces inst_ifaces+ unit_state = hsc_units hsc_env + (!interface, messages) <- do+ logger <- getLogger+ dflags <- getDynFlags+ {-# SCC createInterface #-}+ withTiming logger dflags "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $+ createInterface1 flags unit_state mod_summary tc_gbl_env+ ifaces inst_ifaces+ -- We need to keep track of which modules were somehow in scope so that when -- Haddock later looks for instances, it also looks in these modules too. -- -- See https://github.com/haskell/haddock/issues/469.- dflags <- getDynFlags let mods :: ModuleSet !mods = mkModuleSet [ nameModule name | gre <- globalRdrEnvElts tcg_rdr_env- , let name = gre_name gre- , nameIsFromExternalPackage (homeUnit dflags) name+ , let name = greMangledName gre+ , nameIsFromExternalPackage (hsc_home_unit hsc_env) name , isTcOcc (nameOccName name) -- Types and classes only , unQualOK gre -- In scope unqualified ] liftIO $ mapM_ putStrLn (nub messages)+ dflags <- getDynFlags let (haddockable, haddocked) = ifaceHaddockCoverage interface percentage :: Int- percentage =- round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double)+ percentage = div (haddocked * 100) haddockable modString :: String modString = moduleString (ifaceMod interface)@@ -302,7 +311,7 @@ undocumentedExports :: [String] undocumentedExports =- [ formatName s n+ [ formatName (locA s) n | ExportDecl { expItemDecl = L s n , expItemMbDoc = (Documentation Nothing _, _) } <- ifaceExportItems interface
haddock-api/src/Haddock/Interface/AttachInstances.hs view
@@ -30,14 +30,11 @@ import GHC.Data.FastString (unpackFS) import GHC.Core.Class-import GHC.Driver.Session import GHC.Core (isOrphan)-import GHC.Utils.Error import GHC.Core.FamInstEnv import GHC import GHC.Core.InstEnv import GHC.Unit.Module.Env ( ModuleSet, moduleSetElts )-import GHC.Utils.Monad (liftIO) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable (text, sep, (<+>))@@ -104,7 +101,7 @@ fam_instances = maybeToList mb_instances >>= snd fam_insts = [ ( synFamInst , getInstDoc n- , spanNameE n synFamInst (L eSpan (tcdName d))+ , spanNameE n synFamInst (L (locA eSpan) (tcdName d)) , nameModule_maybe n ) | i <- sortBy (comparing instFam) fam_instances@@ -116,7 +113,7 @@ ] cls_insts = [ ( synClsInst , getInstDoc n- , spanName n synClsInst (L eSpan (tcdName d))+ , spanName n synClsInst (L (locA eSpan) (tcdName d)) , nameModule_maybe n ) | let is = [ (instanceSig i, getName i) | i <- cls_instances ]@@ -128,9 +125,8 @@ cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ] famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ] in do- dfs <- getDynFlags let mkBug = (text "haddock-bug:" <+>) . text- liftIO $ putMsg dfs (sep $ map mkBug famInstErrs)+ putMsgM (sep $ map mkBug famInstErrs) return $ cls_insts ++ cleanFamInsts return $ e { expItemInstances = insts } e -> return e@@ -197,6 +193,7 @@ data SimpleType = SimpleType SName [SimpleType] | SimpleIntTyLit Integer | SimpleStringTyLit String+ | SimpleCharTyLit Char deriving (Eq,Ord) @@ -222,6 +219,7 @@ (mapMaybe simplify_maybe ts) simplify (LitTy (NumTyLit n)) = SimpleIntTyLit n simplify (LitTy (StrTyLit s)) = SimpleStringTyLit (unpackFS s)+simplify (LitTy (CharTyLit c)) = SimpleCharTyLit c simplify (CastTy ty _) = simplify ty simplify (CoercionTy _) = error "simplify:Coercion"
haddock-api/src/Haddock/Interface/Create.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-}@@ -32,50 +33,54 @@ import Documentation.Haddock.Doc (metaDocAppend) import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl)-import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigWcType, moduleString, parents,- pretty, restrictTo, sigName)-import Haddock.Interface.LexParseRn+import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigType, moduleString, parents,+ pretty, restrictTo, sigName, unL)+import Haddock.Interface.LexParseRn (processDocString, processDocStringParas, processDocStrings, processModuleHeader) import Haddock.Options (Flag (..), modulePackageInfo) import Haddock.Types hiding (liftErrMsg) import Haddock.Utils (replace) -import Control.Monad.Catch (MonadCatch, MonadThrow)-import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks)+import Control.Applicative ((<|>))+import Control.Monad.Reader (MonadReader (..), ReaderT, asks, runReaderT) import Control.Monad.Writer.Strict hiding (tell) import Data.Bitraversable (bitraverse) import Data.List (find, foldl')+import qualified Data.IntMap as IM+import Data.IntMap (IntMap) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe, maybeToList) import Data.Traversable (for)-import GHC.Stack (HasCallStack) import GHC hiding (lookupName) import GHC.Core.Class (ClassMinimalDef, classMinimalDef) import GHC.Core.ConLike (ConLike (..)) import GHC.Data.FastString (bytesFS, unpackFS)-import GHC.Driver.Types (HscSource (..), WarningTxt (..), Warnings (..), msHsFilePath)+import GHC.Driver.Ppr (showSDoc) import GHC.HsToCore.Docs hiding (mkMaps)+import GHC.IORef (readIORef) import GHC.Parser.Annotation (IsUnicodeSyntax (..))+import GHC.Stack (HasCallStack) import GHC.Tc.Types hiding (IfM) import GHC.Tc.Utils.Monad (finalSafeMode) import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail-import GHC.Types.Basic (PromotionFlag (..), SourceText (..), StringLiteral (..))+import GHC.Types.Basic (PromotionFlag (..)) import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName) import GHC.Types.Name.Env (lookupNameEnv)-import GHC.Types.Name.Reader (GlobalRdrEnv, globalRdrEnvElts, gre_name, gresToAvailInfo, isLocalGRE, lookupGlobalRdrEnv)+import GHC.Types.Name.Reader (GlobalRdrEnv, greMangledName, lookupGlobalRdrEnv) import GHC.Types.Name.Set (elemNameSet, mkNameSet)+import GHC.Types.SourceFile (HscSource (..))+import GHC.Types.SourceText (SourceText (..), sl_fs) import qualified GHC.Types.SrcLoc as SrcLoc import qualified GHC.Unit.Module as Module-import GHC.Unit.State+import GHC.Unit.Module.ModSummary (msHsFilePath)+import GHC.Unit.Module.Warnings (WarningTxt (..), Warnings (..))+import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits) import qualified GHC.Utils.Outputable as O---mkExceptionContext :: ModSummary -> String-mkExceptionContext =- ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name-+import GHC.Utils.Panic (pprPanic)+import GHC.HsToCore.Docs hiding (mkMaps)+import GHC.Unit.Module.Warnings newtype IfEnv m = IfEnv {@@ -92,14 +97,13 @@ -- over the Ghc specific clarifies where side effects happen. newtype IfM m a = IfM { unIfM :: ReaderT (IfEnv m) (WriterT [ErrMsg] m) a } + deriving newtype instance Functor m => Functor (IfM m) deriving newtype instance Applicative m => Applicative (IfM m) deriving newtype instance Monad m => Monad (IfM m) deriving newtype instance MonadIO m => MonadIO (IfM m) deriving newtype instance Monad m => MonadReader (IfEnv m) (IfM m) deriving newtype instance Monad m => MonadWriter [ErrMsg] (IfM m)-deriving newtype instance (MonadThrow m) => MonadThrow (IfM m)-deriving newtype instance (MonadCatch m) => MonadCatch (IfM m) -- | Run an `IfM` action.@@ -132,15 +136,15 @@ createInterface1- :: (MonadIO m, MonadCatch m)+ :: MonadIO m => [Flag]+ -> UnitState -> ModSummary -> TcGblEnv -> IfaceMap -> InstIfaceMap -> IfM m Interface-createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces =- withExceptionContext (mkExceptionContext mod_sum) $ do+createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do let ModSummary@@ -171,6 +175,7 @@ , tcg_rn_exports , tcg_rn_decls + , tcg_th_docs , tcg_doc_hdr } = tc_gbl_env @@ -179,7 +184,7 @@ is_sig = tcg_src == HsigFile (pkg_name_fs, _) =- modulePackageInfo dflags flags (Just tcg_mod)+ modulePackageInfo unit_state flags (Just tcg_mod) pkg_name :: Maybe Package pkg_name =@@ -197,7 +202,7 @@ loc_splices :: [SrcSpan] loc_splices = case tcg_rn_decls of Nothing -> []- Just HsGroup { hs_splcds } -> [ loc | L loc _ <- hs_splcds ]+ Just HsGroup { hs_splcds } -> [ locA loc | L loc _ <- hs_splcds ] decls <- case tcg_rn_decls of Nothing -> do@@ -221,16 +226,9 @@ Nothing -- All the exported Names of this module.- actual_exports :: [AvailInfo]- actual_exports- | OptIgnoreExports `elem` doc_opts =- gresToAvailInfo $ filter isLocalGRE $ globalRdrEnvElts tcg_rdr_env- | otherwise =- tcg_exports- exported_names :: [Name] exported_names =- concatMap availNamesWithSelectors actual_exports+ concatMap availNamesWithSelectors tcg_exports -- Module imports of the form `import X`. Note that there is -- a) no qualification and@@ -253,9 +251,13 @@ -- Infer module safety safety <- liftIO (finalSafeMode ms_hspp_opts tc_gbl_env) + -- The docs added via Template Haskell's putDoc+ thDocs@ExtractedTHDocs { ethd_mod_header = thMbDocStr } <-+ liftIO $ extractTHDocs <$> readIORef tcg_th_docs+ -- Process the top-level module header documentation. (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name- tcg_rdr_env safety tcg_doc_hdr+ tcg_rdr_env safety (thMbDocStr <|> (unLoc <$> tcg_doc_hdr)) -- Warnings on declarations in this module decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names)@@ -269,11 +271,11 @@ warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces)) maps@(!docs, !arg_docs, !decl_map, _) <-- liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls)+ liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls thDocs) export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod warnings tcg_rdr_env exported_names (map fst decls) maps fixities- imported_modules loc_splices export_list actual_exports inst_ifaces dflags+ imported_modules loc_splices export_list tcg_exports inst_ifaces dflags let visible_names :: [Name]@@ -290,7 +292,7 @@ !coverage = (haddockable, haddocked) aliases :: Map Module ModuleName- aliases = mkAliasMap (unitState dflags) tcg_rn_imports+ aliases = mkAliasMap unit_state tcg_rn_imports return $! Interface {@@ -365,7 +367,7 @@ -- -- With our mapping we know that we can display exported modules M1 and M2. ---unrestrictedModuleImports :: [ImportDecl name] -> M.Map ModuleName [ModuleName]+unrestrictedModuleImports :: [ImportDecl GhcRn] -> M.Map ModuleName [ModuleName] unrestrictedModuleImports idecls = M.map (map (unLoc . ideclName)) $ M.filter (all isInteresting) impModMap@@ -414,7 +416,7 @@ let ws' = [ (n, w) | (occ, w) <- ws , elt <- lookupGlobalRdrEnv gre occ- , let n = gre_name elt, n `elem` exps ]+ , let n = greMangledName elt, n `elem` exps ] in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))@@ -481,11 +483,14 @@ -> GlobalRdrEnv -> [Name] -> [(LHsDecl GhcRn, [HsDocString])]+ -> ExtractedTHDocs -- ^ Template Haskell putDoc docs -> ErrMsgM Maps-mkMaps dflags pkgName gre instances decls = do+mkMaps dflags pkgName gre instances decls thDocs = do (a, b, c) <- unzip3 <$> traverse mappings decls- pure ( f' (map (nubByName fst) a)- , f (filterMapping (not . M.null) b)+ (th_a, th_b) <- thMappings+ pure ( th_a `M.union` f' (map (nubByName fst) a)+ , fmap intmap2mapint $+ th_b `unionArgMaps` (f (filterMapping (not . IM.null) b)) , f (filterMapping (not . null) c) , instanceMap )@@ -499,14 +504,37 @@ filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]] filterMapping p = map (filter (p . snd)) + -- Convert IntMap -> IntMap+ -- TODO: should ArgMap eventually be switched over to IntMap?+ intmap2mapint = M.fromList . IM.toList++ -- | Extract the mappings from template haskell.+ -- No DeclMap/InstMap is needed since we already have access to the+ -- doc strings+ thMappings :: ErrMsgM (Map Name (MDoc Name), Map Name (IntMap (MDoc Name)))+ thMappings = do+ let ExtractedTHDocs+ _+ (DeclDocMap declDocs)+ (ArgDocMap argDocs)+ (DeclDocMap instDocs) = thDocs+ ds2mdoc :: HsDocString -> ErrMsgM (MDoc Name)+ ds2mdoc = processDocStringParas dflags pkgName gre++ declDocs' <- mapM ds2mdoc declDocs+ argDocs' <- mapM (mapM ds2mdoc) argDocs+ instDocs' <- mapM ds2mdoc instDocs+ return (declDocs' <> instDocs', argDocs')++ mappings :: (LHsDecl GhcRn, [HsDocString]) -> ErrMsgM ( [(Name, MDoc Name)]- , [(Name, Map Int (MDoc Name))]+ , [(Name, IntMap (MDoc Name))] , [(Name, [LHsDecl GhcRn])] )- mappings (ldecl@(L (RealSrcSpan l _) decl), docStrs) = do- let declDoc :: [HsDocString] -> Map Int HsDocString- -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name))+ mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), docStrs) = do+ let declDoc :: [HsDocString] -> IntMap HsDocString+ -> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name)) declDoc strs m = do doc' <- processDocStrings dflags pkgName gre strs m' <- traverse (processDocStringParas dflags pkgName gre) m@@ -515,7 +543,7 @@ (doc, args) <- declDoc docStrs (declTypeDocs decl) let- subs :: [(Name, [HsDocString], Map Int HsDocString)]+ subs :: [(Name, [HsDocString], IntMap HsDocString)] subs = subordinates instanceMap decl (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs@@ -533,7 +561,7 @@ seqList subDocs `seq` seqList subArgs `seq` pure (dm, am, cm)- mappings (L (UnhelpfulSpan _) _, _) = pure ([], [], [])+ mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = pure ([], [], []) instanceMap :: Map RealSrcSpan Name instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ]@@ -544,7 +572,7 @@ -- The CoAx's loc is the whole line, but only for TFs. The -- workaround is to dig into the family instance declaration and -- get the identifier with the right location.- TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon (hsib_body d'))+ TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d') _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. names _ decl = getMainDeclBinder decl@@ -578,7 +606,7 @@ -- We create the export items even if the module is hidden, since they -- might be useful when creating the export items for other modules. mkExportItems- :: (Monad m)+ :: Monad m => Bool -- is it a signature -> IfaceMap -> Maybe Package -- this package@@ -617,7 +645,7 @@ return [ExportDoc doc] lookupExport (IEDocNamed _ str, _) = liftErrMsg $- findNamedDoc str [ unLoc d | d <- decls ] >>= \case+ findNamedDoc str [ unL d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do doc <- processDocStringParas dflags pkgName gre docStr@@ -675,18 +703,19 @@ let t = availName avail r <- findDecl avail case r of- ([L l (ValD _ _)], (doc, _)) -> do+ ([L l' (ValD _ _)], (doc, _)) -> do+ let l = locA l' -- Top-level binding without type signature export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->- let declNames = getMainDeclBinder (unLoc decl)+ let declNames = getMainDeclBinder (unL decl) in case () of _ -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. | t `notElem` declNames,- Just p <- find isExported (parents t $ unLoc decl) ->+ Just p <- find isExported (parents t $ unL decl) -> do liftErrMsg $ tell [ "Warning: " ++ moduleString thisMod ++ ": " ++ pretty dflags (nameOccName t) ++ " is exported separately but " ++@@ -706,11 +735,11 @@ let newDecl = L loc . SigD noExtField . fromJust $ filterSigNames (== t) sig in availExportDecl avail newDecl docs_ - L loc (TyClD _ cl@ClassDecl{}) -> do+ L loc (TyClD _ ClassDecl {..}) -> do mdef <- minimalDef t- let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef+ let sig = maybeToList $ fmap (noLocA . MinimalSig noAnn NoSourceText . noLocA . fmap noLocA) mdef availExportDecl avail- (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_+ (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_ _ -> availExportDecl avail decl docs_ @@ -744,7 +773,7 @@ synifiedDeclOpt <- hiDecl dflags declName case synifiedDeclOpt of Just synifiedDecl -> pure synifiedDecl- Nothing -> O.pprPanic "availExportItem" (O.text err)+ Nothing -> pprPanic "availExportItem" (O.text err) availExportDecl :: AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)])@@ -842,16 +871,8 @@ constructor_names = filter isDataConName (availSubordinates avail) --- this heavily depends on the invariants stated in Avail-availExportsDecl :: AvailInfo -> Bool-availExportsDecl (AvailTC ty_name names _)- | n : _ <- names = ty_name == n- | otherwise = False-availExportsDecl _ = True- availSubordinates :: AvailInfo -> [Name]-availSubordinates avail =- filter (/= availName avail) (availNamesWithSelectors avail)+availSubordinates = map greNameMangledName . availSubordinateGreNames availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)] availNoDocs avail =@@ -864,7 +885,6 @@ | Module.isHoleModule m = mkModule this_uid (moduleName m) | otherwise = m --- | Reify a declaration from the GHC internal 'TyThing' representation. hiDecl :: Monad m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do mayTyThing <- lookupName t@@ -875,12 +895,12 @@ Just x -> case tyThingToLHsDecl ShowRuntimeRep x of Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing Right (m, t') -> liftErrMsg (tell $ map bugWarn m)- >> return (Just $ noLoc t')+ >> return (Just $ noLocA t') where warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<> O.comma O.<+> O.quotes (O.ppr t) O.<+> O.text "-- Please report this on Haddock issue tracker!"- bugWarn = O.showSDoc dflags . warnLine+ bugWarn = showSDoc dflags . warnLine -- | This function is called for top-level bindings without type signatures. -- It gets the type signature from GHC and that means it's not going to@@ -895,7 +915,7 @@ Nothing -> return (ExportNoDecl name []) Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice) where- fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t+ fixSpan (L (SrcSpanAnn a l) t) = L (SrcSpanAnn a (SrcLoc.combineSrcSpans l nLoc)) t fixities = case fixity of Just f -> [(name, f)] Nothing -> []@@ -996,7 +1016,7 @@ doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr) return [[ExportDoc doc]] (L _ (ValD _ valDecl))- | name:_ <- collectHsBindBinders valDecl+ | name:_ <- collectHsBindBinders CollNoDictBinders valDecl , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap -> return [] _ ->@@ -1011,7 +1031,6 @@ isSigD (L _ SigD{}) = True isSigD _ = False - -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble@@ -1062,7 +1081,7 @@ TyClD _ d@DataDecl { tcdLName = L _ dataNm , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do- let ty_args = map HsValArg (lHsQTyVarsToTypes (tyClDeclTyVars d))+ let ty_args = lHsQTyVarsToTypes (tyClDeclTyVars d) lsig <- if isDataConName name then extractPatternSyn name dataNm ty_args dataCons else extractRecSel name dataNm ty_args dataCons@@ -1072,43 +1091,42 @@ | isValName name , Just (famInst:_) <- M.lookup name declMap -> extractDecl declMap name famInst- InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body =- FamEqn { feqn_tycon = L _ famName- , feqn_pats = ty_args- , feqn_rhs = HsDataDefn { dd_cons = dataCons } }}))) -> do- lsig <- if isDataConName name- then extractPatternSyn name famName ty_args dataCons- else extractRecSel name famName ty_args dataCons- pure (SigD noExtField <$> lsig)+ InstD _ (DataFamInstD _ (DataFamInstDecl+ (FamEqn { feqn_tycon = L _ n+ , feqn_pats = tys+ , feqn_rhs = defn }))) ->+ if isDataConName name+ then fmap (SigD noExtField) <$> extractPatternSyn name n tys (dd_cons defn)+ else fmap (SigD noExtField) <$> extractRecSel name n tys (dd_cons defn) InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) | isDataConName name ->- let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body =- FamEqn { feqn_rhs = HsDataDefn { dd_cons = dataCons }- }- })) <- insts- , name `elem` map unLoc (concatMap (getConNames . unLoc) dataCons)+ let matches = [ d' | L _ d'@(DataFamInstDecl (FamEqn { feqn_rhs = dd })) <- insts+ , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd)) ] in case matches of- [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0)))+ [d0] -> extractDecl declMap name (noLocA (InstD noExtField (DataFamInstD noExtField d0))) _ -> Left "internal: extractDecl (ClsInstD)" | otherwise ->- let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))+ let matches = [ d' | L _ d'@(DataFamInstDecl d ) <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)- , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d))+ , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , extFieldOcc n == name ] in case matches of- [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0)+ [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0) _ -> Left "internal: extractDecl (ClsInstD)" _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn)+extractPatternSyn :: HasCallStack+ => Name -> Name+ -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]+ -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons = case filter matches cons of- [] -> Left . O.showSDocUnsafe $+ [] -> Left . O.showSDocOneLine O.defaultSDocContext $ O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t con:_ -> pure (extract <$> con) where@@ -1117,37 +1135,41 @@ extract :: ConDecl GhcRn -> Sig GhcRn extract con = let args =- case getConArgs con of- PrefixCon args' -> (map hsScaledThing args')- RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields- InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]+ case con of+ ConDeclH98 { con_args = con_args' } -> case con_args' of+ PrefixCon _ args' -> map hsScaledThing args'+ RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields+ InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]+ ConDeclGADT { con_g_args = con_args' } -> case con_args' of+ PrefixConGADT args' -> map hsScaledThing args'+ RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields typ = longArrow args (data_ty con) typ' = case con of- ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ)+ ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField (Just cxt) typ) _ -> typ- typ'' = noLoc (HsQualTy noExtField (noLoc []) typ')- in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'')+ typ'' = noLocA (HsQualTy noExtField Nothing typ')+ in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn- longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs+ longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con- | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs+ | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki- mkAppTyArg f (HsArgPar _) = HsParTy noExtField f+ mkAppTyArg f (HsArgPar _) = HsParTy noAnn f extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) extractRecSel _ _ _ [] = Left "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) =- case getConArgs con of- RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->- pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))+ case getRecConArgs_maybe con of+ Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->+ pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]@@ -1156,11 +1178,11 @@ data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = con_res_ty con- | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs+ | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki- mkAppTyArg f (HsArgPar _) = HsParTy noExtField f+ mkAppTyArg f (HsArgPar _) = HsParTy noAnn f -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]
haddock-api/src/Haddock/Interface/Json.hs view
@@ -5,7 +5,7 @@ , renderJson ) where -import GHC.Types.Basic+import GHC.Types.Fixity import GHC.Utils.Json import GHC.Unit.Module import GHC.Types.Name
haddock-api/src/Haddock/Interface/LexParseRn.hs view
@@ -22,8 +22,8 @@ import Control.Arrow import Control.Monad-import Data.Functor (($>))-import Data.List (maximumBy, (\\))+import Data.Functor+import Data.List ((\\), maximumBy) import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) import GHC.Driver.Session (languageExtensions)@@ -33,8 +33,9 @@ import Haddock.Parser import Haddock.Types import GHC.Types.Name+import GHC.Types.Avail ( availName ) import GHC.Parser.PostProcess-import GHC.Utils.Outputable ( showPpr, showSDoc )+import GHC.Driver.Ppr ( showPpr, showSDoc ) import GHC.Types.Name.Reader import GHC.Data.EnumSet as EnumSet @@ -57,13 +58,13 @@ processDocString dflags gre hds = rename dflags gre $ parseString dflags (unpackHDS hds) -processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString+processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe HsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) processModuleHeader dflags pkgName gre safety mayStr = do (hmi, doc) <- case mayStr of Nothing -> return failure- Just (L _ hds) -> do+ Just hds -> do let str = unpackHDS hds (hmi, doc) = parseModuleHeader dflags pkgName str !descr <- case hmi_description hmi of@@ -135,7 +136,7 @@ -- There is only one name in the environment that matches so -- use it.- [a] -> pure (DocIdentifier (i $> gre_name a))+ [a] -> pure $ DocIdentifier (i $> greMangledName a) -- There are multiple names available. gres -> ambiguous dflags i gres@@ -200,9 +201,10 @@ -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above. -> ErrMsgM (Doc Name) ambiguous dflags x gres = do- let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres+ let noChildren = map availName (gresToAvailInfo gres)+ dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++- concatMap (\n -> " * " ++ defnLoc n ++ "\n") gres +++ concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map greMangledName gres) ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ " by specifying the type/value namespace explicitly.\n" ++ " Defaulting to the one defined " ++ defnLoc dflt@@ -211,10 +213,12 @@ -- of the same name, but not the only constructor. -- For example, for @data D = C | D@, someone may want to reference the @D@ -- constructor.- when (length (gresToAvailInfo gres) > 1) $ tell [msg]- pure (DocIdentifier (x $> gre_name dflt))+ when (length noChildren > 1) $ tell [msg]+ pure (DocIdentifier (x $> dflt)) where- defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name+ isLocalName (nameSrcLoc -> RealSrcLoc {}) = True+ isLocalName _ = False+ defnLoc = showSDoc dflags . pprNameDefnLoc -- | Handle value-namespaced names that cannot be for values. --
haddock-api/src/Haddock/Interface/Rename.hs view
@@ -34,6 +34,7 @@ import qualified Data.Set as Set import Prelude hiding (mapM) import GHC.HsToCore.Docs+import GHC.Types.Basic ( TopLevelFlag(..) ) -- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to -- 'DocName'.@@ -173,10 +174,9 @@ rename = lookupRn -renameL :: Located Name -> RnM (Located DocName)+renameL :: GenLocated l Name -> RnM (GenLocated l DocName) renameL = mapM rename - renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI] renameExportItems = mapM renameExportItem @@ -213,10 +213,10 @@ renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI)-renameLSigType = renameImplicit renameLType+renameLSigType = mapM renameSigType renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI)-renameLSigWcType = renameWc (renameImplicit renameLType)+renameLSigWcType = renameWc renameLSigType renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI) renameLKind = renameLType@@ -235,10 +235,10 @@ ; return (L loc (TyVarSig noExtField bndr')) } renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI)-renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))+renameInjectivityAnn (L loc (InjectivityAnn _ lhs rhs)) = do { lhs' <- renameL lhs ; rhs' <- mapM renameL rhs- ; return (L loc (InjectivityAnn lhs' rhs')) }+ ; return (L loc (InjectivityAnn noExtField lhs' rhs')) } renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> RnM (Maybe (LInjectivityAnn DocNameI))@@ -246,76 +246,82 @@ renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI) renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u)-renameArrow (HsLinearArrow u) = return (HsLinearArrow u)-renameArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p+renameArrow (HsLinearArrow u a) = return (HsLinearArrow u a)+renameArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of HsForAllTy { hst_tele = tele, hst_body = ltype } -> do tele' <- renameHsForAllTelescope tele ltype' <- renameLType ltype- return (HsForAllTy { hst_xforall = noExtField+ return (HsForAllTy { hst_xforall = noAnn , hst_tele = tele', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do- lcontext' <- renameLContext lcontext+ lcontext' <- traverse renameLContext lcontext ltype' <- renameLType ltype- return (HsQualTy { hst_xqual = noExtField, hst_ctxt = lcontext', hst_body = ltype' })+ return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar _ ip (L l n) -> return . HsTyVar noExtField ip . L l =<< rename n- HsBangTy _ b ltype -> return . HsBangTy noExtField b =<< renameLType ltype+ HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< rename n+ HsBangTy _ b ltype -> return . HsBangTy noAnn b =<< renameLType ltype - HsStarTy _ isUni -> return (HsStarTy noExtField isUni)+ HsStarTy _ isUni -> return (HsStarTy noAnn isUni) HsAppTy _ a b -> do a' <- renameLType a b' <- renameLType b- return (HsAppTy noExtField a' b')+ return (HsAppTy noAnn a' b') HsAppKindTy _ a b -> do a' <- renameLType a b' <- renameLKind b- return (HsAppKindTy noExtField a' b')+ return (HsAppKindTy noAnn a' b') HsFunTy _ w a b -> do a' <- renameLType a b' <- renameLType b w' <- renameArrow w- return (HsFunTy noExtField w' a' b')+ return (HsFunTy noAnn w' a' b') - HsListTy _ ty -> return . (HsListTy noExtField) =<< renameLType ty- HsIParamTy _ n ty -> liftM (HsIParamTy noExtField n) (renameLType ty)+ HsListTy _ ty -> return . (HsListTy noAnn) =<< renameLType ty+ HsIParamTy _ n ty -> liftM (HsIParamTy noAnn n) (renameLType ty) - HsTupleTy _ b ts -> return . HsTupleTy noExtField b =<< mapM renameLType ts- HsSumTy _ ts -> HsSumTy noExtField <$> mapM renameLType ts+ HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts+ HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts HsOpTy _ a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b- return (HsOpTy noExtField a' (L loc op') b')+ return (HsOpTy noAnn a' (L loc op') b') - HsParTy _ ty -> return . (HsParTy noExtField) =<< renameLType ty+ HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty HsKindSig _ ty k -> do ty' <- renameLType ty k' <- renameLKind k- return (HsKindSig noExtField ty' k')+ return (HsKindSig noAnn ty' k') HsDocTy _ ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc- return (HsDocTy noExtField ty' doc')+ return (HsDocTy noAnn ty' doc') - HsTyLit _ x -> return (HsTyLit noExtField x)+ HsTyLit _ x -> return (HsTyLit noAnn x) - HsRecTy _ a -> HsRecTy noExtField <$> mapM renameConDeclFieldField a- (XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a))- HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b- HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b+ HsRecTy _ a -> HsRecTy noAnn <$> mapM renameConDeclFieldField a+ XHsType a -> pure (XHsType a)+ HsExplicitListTy _ a b -> HsExplicitListTy noAnn a <$> mapM renameLType b+ HsExplicitTupleTy _ b -> HsExplicitTupleTy noAnn <$> mapM renameLType b HsSpliceTy _ s -> renameHsSpliceTy s- HsWildCardTy a -> pure (HsWildCardTy a)+ HsWildCardTy _ -> pure (HsWildCardTy noAnn) +renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI)+renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do+ bndrs' <- renameOuterTyVarBndrs bndrs+ body' <- renameLType body+ pure $ HsSig { sig_ext = noExtField, sig_bndrs = bndrs', sig_body = body' }+ -- | Rename splices, but _only_ those that turn out to be for types. -- I think this is actually safe for our possible inputs: --@@ -335,21 +341,21 @@ renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI) renameHsForAllTelescope tele = case tele of- HsForAllVis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs- pure $ HsForAllVis x bndrs'- HsForAllInvis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs- pure $ HsForAllInvis x bndrs'+ HsForAllVis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs+ pure $ HsForAllVis noExtField bndrs'+ HsForAllInvis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs+ pure $ HsForAllInvis noExtField bndrs' renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI)-renameLTyVarBndr (L loc (UserTyVar x fl (L l n)))+renameLTyVarBndr (L loc (UserTyVar _ fl (L l n))) = do { n' <- rename n- ; return (L loc (UserTyVar x fl (L l n'))) }-renameLTyVarBndr (L loc (KindedTyVar x fl (L lv n) kind))+ ; return (L loc (UserTyVar noExtField fl (L l n'))) }+renameLTyVarBndr (L loc (KindedTyVar _ fl (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind- ; return (L loc (KindedTyVar x fl (L lv n') kind')) }+ ; return (L loc (KindedTyVar noExtField fl (L lv n') kind')) } -renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI])+renameLContext :: LocatedC [LHsType GhcRn] -> RnM (LocatedC [LHsType DocNameI]) renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context')@@ -400,8 +406,8 @@ return (DerivD noExtField d') _ -> error "renameDecl" -renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI))-renameLThing fn (L loc x) = return . L loc =<< fn x+renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> LocatedAn an (a GhcRn) -> RnM (Located (a DocNameI))+renameLThing fn (L loc x) = return . L (locA loc) =<< fn x renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI) renameTyClD d = case d of@@ -426,7 +432,7 @@ ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do- lcontext' <- renameLContext lcontext+ lcontext' <- traverse renameLContext lcontext lname' <- renameL lname ltyvars' <- renameLHsQTyVars ltyvars lfundeps' <- mapM renameLFunDep lfundeps@@ -440,12 +446,13 @@ , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = noExtField }) where- renameLFunDep (L loc (xs, ys)) = do+ renameLFunDep :: LHsFunDep GhcRn -> RnM (LHsFunDep DocNameI)+ renameLFunDep (L loc (FunDep _ xs ys)) = do xs' <- mapM rename (map unLoc xs) ys' <- mapM rename (map unLoc ys)- return (L loc (map noLoc xs', map noLoc ys'))+ return (L (locA loc) (FunDep noExtField (map noLocA xs') (map noLocA ys'))) - renameLSig (L loc sig) = return . L loc =<< renameSig sig+ renameLSig (L loc sig) = return . L (locA loc) =<< renameSig sig renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname@@ -458,7 +465,8 @@ ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity- return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdLName = lname'+ return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdTopLevel = TopLevel+ , fdLName = lname' , fdTyVars = ltyvars' , fdFixity = fixity , fdResultSig = result'@@ -484,64 +492,73 @@ renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI) renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k, dd_cons = cons }) = do- lcontext' <- renameLContext lcontext+ lcontext' <- traverse renameLContext lcontext k' <- renameMaybeLKind k- cons' <- mapM (mapM renameCon) cons+ cons' <- mapM (mapMA renameCon) cons -- I don't think we need the derivings, so we return Nothing return (HsDataDefn { dd_ext = noExtField , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons'- , dd_derivs = noLoc [] })+ , dd_derivs = [] }) renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars , con_mb_cxt = lcontext, con_args = details- , con_doc = mbldoc }) = do+ , con_doc = mbldoc+ , con_forall = forall }) = do lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext- details' <- renameDetails details+ details' <- renameH98Details details mbldoc' <- mapM renameLDocHsSyn mbldoc return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext'+ , con_forall = forall -- Remove when #18311 is fixed , con_args = details', con_doc = mbldoc' }) -renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars- , con_mb_cxt = lcontext, con_args = details+renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs+ , con_mb_cxt = lcontext, con_g_args = details , con_res_ty = res_ty- , con_doc = mbldoc }) = do+ , con_doc = mbldoc } = do lnames' <- mapM renameL lnames- ltyvars' <- mapM renameLTyVarBndr ltyvars+ bndrs' <- mapM renameOuterTyVarBndrs bndrs lcontext' <- traverse renameLContext lcontext- details' <- renameDetails details+ details' <- renameGADTDetails details res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc- return (decl { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars'- , con_mb_cxt = lcontext', con_args = details'+ return (ConDeclGADT+ { con_g_ext = noExtField, con_names = lnames', con_bndrs = bndrs'+ , con_mb_cxt = lcontext', con_g_args = details' , con_res_ty = res_ty', con_doc = mbldoc' }) renameHsScaled :: HsScaled GhcRn (LHsType GhcRn) -> RnM (HsScaled DocNameI (LHsType DocNameI)) renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty -renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI)-renameDetails (RecCon (L l fields)) = do+renameH98Details :: HsConDeclH98Details GhcRn+ -> RnM (HsConDeclH98Details DocNameI)+renameH98Details (RecCon (L l fields)) = do fields' <- mapM renameConDeclFieldField fields- return (RecCon (L l fields'))- -- This causes an assertion failure---renameDetails (PrefixCon ps) = -- return . PrefixCon =<< mapM (_renameLType) ps-renameDetails (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps-renameDetails (InfixCon a b) = do+ return (RecCon (L (locA l) fields'))+renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps+renameH98Details (InfixCon a b) = do a' <- renameHsScaled a b' <- renameHsScaled b return (InfixCon a' b') +renameGADTDetails :: HsConDeclGADTDetails GhcRn+ -> RnM (HsConDeclGADTDetails DocNameI)+renameGADTDetails (RecConGADT (L l fields)) = do+ fields' <- mapM renameConDeclFieldField fields+ return (RecConGADT (L (locA l) fields'))+renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps+ renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc- return $ L l (ConDeclField noExtField names' t' doc')+ return $ L (locA l) (ConDeclField noExtField names' t' doc') renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do@@ -606,10 +623,10 @@ , deriv_overlap_mode = omode }) renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI)-renameDerivStrategy StockStrategy = pure StockStrategy-renameDerivStrategy AnyclassStrategy = pure AnyclassStrategy-renameDerivStrategy NewtypeStrategy = pure NewtypeStrategy-renameDerivStrategy (ViaStrategy ty) = ViaStrategy <$> renameLSigType ty+renameDerivStrategy (StockStrategy a) = pure (StockStrategy a)+renameDerivStrategy (AnyclassStrategy a) = pure (AnyclassStrategy a)+renameDerivStrategy (NewtypeStrategy a) = pure (NewtypeStrategy a)+renameDerivStrategy (ViaStrategy ty) = ViaStrategy <$> renameLSigType ty renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode@@ -627,35 +644,29 @@ renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) = do { eqn' <- renameTyFamInstEqn eqn- ; return (TyFamInstDecl { tfid_eqn = eqn' }) }+ ; return (TyFamInstDecl { tfid_xtn = noExtField, tfid_eqn = eqn' }) } renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI)-renameTyFamInstEqn eqn- = renameImplicit rename_ty_fam_eqn eqn- where- rename_ty_fam_eqn- :: FamEqn GhcRn (LHsType GhcRn)- -> RnM (FamEqn DocNameI (LHsType DocNameI))- rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs- , feqn_pats = pats, feqn_fixity = fixity- , feqn_rhs = rhs })- = do { tc' <- renameL tc- ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs- ; pats' <- mapM renameLTypeArg pats- ; rhs' <- renameLType rhs- ; return (FamEqn { feqn_ext = noExtField- , feqn_tycon = tc'- , feqn_bndrs = bndrs'- , feqn_pats = pats'- , feqn_fixity = fixity- , feqn_rhs = rhs' }) }+renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs+ , feqn_pats = pats, feqn_fixity = fixity+ , feqn_rhs = rhs })+ = do { tc' <- renameL tc+ ; bndrs' <- renameOuterTyVarBndrs bndrs+ ; pats' <- mapM renameLTypeArg pats+ ; rhs' <- renameLType rhs+ ; return (FamEqn { feqn_ext = noExtField+ , feqn_tycon = tc'+ , feqn_bndrs = bndrs'+ , feqn_pats = pats'+ , feqn_fixity = fixity+ , feqn_rhs = rhs' }) } renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI) renameTyFamDefltD = renameTyFamInstD renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })- = do { eqn' <- renameImplicit rename_data_fam_eqn eqn+ = do { eqn' <- rename_data_fam_eqn eqn ; return (DataFamInstDecl { dfid_eqn = eqn' }) } where rename_data_fam_eqn@@ -665,7 +676,7 @@ , feqn_pats = pats, feqn_fixity = fixity , feqn_rhs = defn }) = do { tc' <- renameL tc- ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs+ ; bndrs' <- renameOuterTyVarBndrs bndrs ; pats' <- mapM renameLTypeArg pats ; defn' <- renameDataDefn defn ; return (FamEqn { feqn_ext = noExtField@@ -675,13 +686,12 @@ , feqn_fixity = fixity , feqn_rhs = defn' }) } -renameImplicit :: (in_thing -> RnM out_thing)- -> HsImplicitBndrs GhcRn in_thing- -> RnM (HsImplicitBndrs DocNameI out_thing)-renameImplicit rn_thing (HsIB { hsib_body = thing })- = do { thing' <- rn_thing thing- ; return (HsIB { hsib_body = thing'- , hsib_ext = noExtField }) }+renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn+ -> RnM (HsOuterTyVarBndrs flag DocNameI)+renameOuterTyVarBndrs (HsOuterImplicit{}) =+ pure $ HsOuterImplicit{hso_ximplicit = noExtField}+renameOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = exp_bndrs}) =+ HsOuterExplicit noExtField <$> mapM renameLTyVarBndr exp_bndrs renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing
haddock-api/src/Haddock/Interface/Specialize.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Haddock.Interface.Specialize@@ -18,7 +19,6 @@ import GHC.Types.Name import GHC.Data.FastString import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )-import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Control.Monad import Control.Monad.Trans.State@@ -38,7 +38,7 @@ go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map - strip_kind_sig :: HsType name -> HsType name+ strip_kind_sig :: HsType GhcRn -> HsType GhcRn strip_kind_sig (HsKindSig _ (L _ t) _) = t strip_kind_sig typ = typ @@ -57,7 +57,7 @@ -- -- 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 :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn+specializeTyVarBndrs :: Data a => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs@@ -74,13 +74,13 @@ -> Sig GhcRn -> Sig GhcRn specializeSig bndrs typs (TypeSig _ lnames typ) =- TypeSig noExtField lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})+ TypeSig noAnn lnames (typ {hswc_body = noLocA typ'}) where- true_type :: HsType GhcRn- true_type = unLoc (hsSigWcType typ)- typ' :: HsType GhcRn+ true_type :: HsSigType GhcRn+ true_type = unLoc (dropWildCards typ)+ typ' :: HsSigType GhcRn typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type- fv = foldr Set.union Set.empty . map freeVariables $ typs+ fv = foldr Set.union Set.empty . map freeVariablesType $ typs specializeSig _ _ sig = sig @@ -110,7 +110,7 @@ sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp)- | getName name == listTyConName = HsListTy noExtField ltyp+ | getName name == listTyConName = HsListTy noAnn ltyp sugarLists typ = typ @@ -121,7 +121,7 @@ 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 noExtField HsBoxedTuple apps+ | isBuiltInSyntax name' && suitable = HsTupleTy noAnn HsBoxedOrConstraintTuple apps where name' = getName name strName = getOccString name@@ -131,10 +131,10 @@ aux _ _ = typ -sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)+sugarOperators :: HsType GhcRn -> HsType GhcRn sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb- | unrestrictedFunTyConName == name' = HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) la lb+ | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) la lb where name' = getName name sugarOperators typ = typ@@ -176,19 +176,25 @@ -- 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+newtype NameRep+ = NameRep FastString+ deriving (Eq) +instance Ord NameRep where+ compare (NameRep fs1) (NameRep fs2) = uniqCompareFS fs1 fs2++ getNameRep :: NamedThing name => name -> NameRep-getNameRep = getOccFS+getNameRep = NameRep . getOccFS nameRepString :: NameRep -> String-nameRepString = unpackFS+nameRepString (NameRep fs) = unpackFS fs stringNameRep :: String -> NameRep-stringNameRep = mkFastString+stringNameRep = NameRep . mkFastString setInternalNameRep :: SetName name => NameRep -> name -> name-setInternalNameRep = setInternalOccName . mkVarOccFS+setInternalNameRep (NameRep fs) = setInternalOccName (mkVarOccFS fs) setInternalOccName :: SetName name => OccName -> name -> name setInternalOccName occ name =@@ -198,25 +204,39 @@ nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) --- | Compute set of free variables of given type.-freeVariables :: HsType GhcRn -> Set Name-freeVariables =- everythingWithState Set.empty Set.union query- where- query term ctx = case cast term :: Maybe (HsType GhcRn) of- Just (HsForAllTy _ tele _) ->- (Set.empty, Set.union ctx (teleNames tele))- Just (HsTyVar _ _ (L _ name))- | getName name `Set.member` ctx -> (Set.empty, ctx)- | otherwise -> (Set.singleton $ getName name, ctx)- _ -> (Set.empty, ctx)+-- | Compute set of free variables of a given 'HsType'.+freeVariablesType :: HsType GhcRn -> Set Name+freeVariablesType =+ everythingWithState Set.empty Set.union+ (mkQ (\ctx -> (Set.empty, ctx)) queryType) +-- | Compute set of free variables of a given 'HsType'.+freeVariablesSigType :: HsSigType GhcRn -> Set Name+freeVariablesSigType =+ everythingWithState Set.empty Set.union+ (mkQ (\ctx -> (Set.empty, ctx)) queryType `extQ` querySigType)++queryType :: HsType GhcRn -> Set Name -> (Set Name, Set Name)+queryType term ctx = case term of+ HsForAllTy _ tele _ ->+ (Set.empty, Set.union ctx (teleNames tele))+ HsTyVar _ _ (L _ name)+ | getName name `Set.member` ctx -> (Set.empty, ctx)+ | otherwise -> (Set.singleton $ getName name, ctx)+ _ -> (Set.empty, ctx)+ where+ teleNames :: HsForAllTelescope GhcRn -> Set Name teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs - bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc)+querySigType :: HsSigType GhcRn -> Set Name -> (Set Name, Set Name)+querySigType (HsSig { sig_bndrs = outer_bndrs }) ctx =+ (Set.empty, Set.union ctx (bndrsNames (hsOuterExplicitBndrs outer_bndrs))) +bndrsNames :: [LHsTyVarBndr flag GhcRn] -> Set Name+bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) + -- | Make given type visually unambiguous. -- -- After applying 'specialize' method, some free type variables may become@@ -225,12 +245,12 @@ -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something -- like @(a -> b0) -> b@).-rename :: Set Name -> HsType GhcRn -> HsType GhcRn-rename fv typ = evalState (renameType typ) env+rename :: Set Name -> HsSigType GhcRn -> HsSigType GhcRn+rename fv typ = evalState (renameSigType typ) env where env = RenameEnv { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv- , rneSigFVs = Set.map getNameRep $ freeVariables typ+ , rneSigFVs = Set.map getNameRep $ freeVariablesSigType typ , rneCtx = Map.empty } mkPair name = (getNameRep name, name)@@ -245,6 +265,17 @@ } +renameSigType :: HsSigType GhcRn -> Rename (IdP GhcRn) (HsSigType GhcRn)+renameSigType (HsSig x bndrs body) =+ HsSig x <$> renameOuterTyVarBndrs bndrs <*> renameLType body++renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn+ -> Rename (IdP GhcRn) (HsOuterTyVarBndrs flag GhcRn)+renameOuterTyVarBndrs (HsOuterImplicit imp_tvs) =+ HsOuterImplicit <$> mapM renameName imp_tvs+renameOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =+ HsOuterExplicit x <$> mapM renameLBinder exp_bndrs+ renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) renameType (HsForAllTy x tele lt) = HsForAllTy x@@ -252,9 +283,9 @@ <*> renameLType lt renameType (HsQualTy x lctxt lt) = HsQualTy x- <$> located renameContext lctxt+ <$> renameMContext lctxt <*> renameLType lt-renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name+renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name renameType t@(HsStarTy _ _) = pure t renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk@@ -263,7 +294,7 @@ renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt renameType (HsOpTy x la lop lb) =- HsOpTy x <$> renameLType la <*> located renameName lop <*> renameLType lb+ HsOpTy x <$> renameLType la <*> locatedN renameName lop <*> renameLType lb renameType (HsParTy x lt) = HsParTy x <$> renameLType lt renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk@@ -271,7 +302,7 @@ renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt renameType t@(HsRecTy _ _) = pure t-renameType t@(XHsType (NHsCoreTy _)) = pure t+renameType t@(XHsType _) = pure t renameType (HsExplicitListTy x ip ltys) = HsExplicitListTy x ip <$> renameLTypes ltys renameType (HsExplicitTupleTy x ltys) =@@ -280,7 +311,7 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)-renameHsArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p+renameHsArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p renameHsArrow mult = pure mult @@ -293,6 +324,11 @@ renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType +renameMContext :: Maybe (LHsContext GhcRn) -> Rename (IdP GhcRn) (Maybe (LHsContext GhcRn))+renameMContext Nothing = return Nothing+renameMContext (Just (L l ctxt)) = do+ ctxt' <- renameContext ctxt+ return (Just (L l ctxt')) renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes@@ -305,9 +341,9 @@ HsForAllInvis x <$> mapM renameLBinder bndrs renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn)-renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> located renameName lname+renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> locatedN renameName lname renameBinder (KindedTyVar x fl lname lkind) =- KindedTyVar x fl <$> located renameName lname <*> located renameType lkind+ KindedTyVar x fl <$> locatedN renameName lname <*> located renameType lkind renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn) renameLBinder = located renameBinder@@ -360,5 +396,13 @@ str = nameRepString name -located :: Functor f => (a -> f b) -> Located a -> f (Located b)+located :: Functor f => (a -> f b) -> GenLocated l a -> f (GenLocated l b) located f (L loc e) = L loc <$> f e++locatedN :: Functor f => (a -> f b) -> LocatedN a -> f (LocatedN b)+locatedN f (L loc e) = L loc <$> f e+++tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn+tyVarName (UserTyVar _ _ name) = unLoc name+tyVarName (KindedTyVar _ _ (L _ name) _) = name
haddock-api/src/Haddock/InterfaceFile.hs view
@@ -38,7 +38,7 @@ import GHC.Data.FastString import GHC hiding (NoLink) import GHC.Driver.Monad (withSession)-import GHC.Driver.Types+import GHC.Driver.Env import GHC.Types.Name.Cache import GHC.Iface.Env import GHC.Types.Name@@ -94,7 +94,7 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16-#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,1,0)+#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) binaryInterfaceVersion = 38 binaryInterfaceVersionCompatibility :: [Word16]@@ -123,14 +123,12 @@ put_ bh0 symtab_p_p -- Make some intial state- symtab_next <- newFastMutInt- writeFastMutInt symtab_next 0+ symtab_next <- newFastMutInt 0 symtab_map <- newIORef emptyUFM let bin_symtab = BinSymbolTable { bin_symtab_next = symtab_next, bin_symtab_map = symtab_map }- dict_next_ref <- newFastMutInt- writeFastMutInt dict_next_ref 0+ dict_next_ref <- newFastMutInt 0 dict_map_ref <- newIORef emptyUFM let bin_dict = BinDictionary { bin_dict_next = dict_next_ref,
haddock-api/src/Haddock/Options.hs view
@@ -24,7 +24,6 @@ optSourceCssFile, sourceUrls, wikiUrls,- baseUrl, optParCount, optDumpInterfaceFile, optShowInterfaceFile,@@ -47,9 +46,8 @@ import Data.Version import Control.Applicative import GHC.Data.FastString-import GHC ( DynFlags, Module, moduleUnit, unitState )-import GHC.Unit.Info ( PackageName(..), unitPackageName, unitPackageVersion )-import GHC.Unit.State ( lookupUnit )+import GHC ( Module, moduleUnit )+import GHC.Unit.State import Haddock.Types import Haddock.Utils import System.Console.GetOpt@@ -74,7 +72,6 @@ | Flag_SourceEntityURL String | Flag_SourceLEntityURL String | Flag_WikiBaseURL String- | Flag_BaseURL String | Flag_WikiModuleURL String | Flag_WikiEntityURL String | Flag_LaTeX@@ -160,8 +157,6 @@ "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.", Option [] ["comments-base"] (ReqArg Flag_WikiBaseURL "URL") "URL for a comments link on the contents\nand index pages",- Option [] ["base-url"] (ReqArg Flag_BaseURL "URL")- "Base URL for static assets (eg. css, javascript, json files etc.).\nWhen given statis assets will not be copied.", Option [] ["comments-module"] (ReqArg Flag_WikiModuleURL "URL") "URL for a comments link for each module\n(using the %{MODULE} var)", Option [] ["comments-entity"] (ReqArg Flag_WikiEntityURL "URL")@@ -306,9 +301,6 @@ ,optLast [str | Flag_WikiEntityURL str <- flags]) -baseUrl :: [Flag] -> Maybe String-baseUrl flags = optLast [str | Flag_BaseURL str <- flags]- optDumpInterfaceFile :: [Flag] -> Maybe FilePath optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] @@ -388,16 +380,16 @@ -- -- The @--package-name@ and @--package-version@ Haddock flags allow the user to -- specify this information manually and it is returned here if present.-modulePackageInfo :: DynFlags+modulePackageInfo :: UnitState -> [Flag] -- ^ Haddock flags are checked as they may contain -- the package name or version provided by the user -- which we prioritise -> Maybe Module -> (Maybe PackageName, Maybe Data.Version.Version)-modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing)-modulePackageInfo dflags flags (Just modu) =+modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing)+modulePackageInfo unit_state flags (Just modu) = ( optPackageName flags <|> fmap unitPackageName pkgDb , optPackageVersion flags <|> fmap unitPackageVersion pkgDb ) where- pkgDb = lookupUnit (unitState dflags) (moduleUnit modu)+ pkgDb = lookupUnit unit_state (moduleUnit modu)
haddock-api/src/Haddock/Parser.hs view
@@ -19,8 +19,9 @@ import Haddock.Types import GHC.Driver.Session ( DynFlags )+import GHC.Driver.Config import GHC.Data.FastString ( fsLit )-import GHC.Parser.Lexer ( mkPState, unP, ParseResult(POk, PFailed) )+import GHC.Parser.Lexer ( initParserState, unP, ParseResult(POk, PFailed) ) import GHC.Parser ( parseIdentifier ) import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Name.Reader ( RdrName(..) )@@ -48,7 +49,7 @@ PFailed{} -> Nothing where realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0- pstate str = mkPState dflags (stringToStringBuffer str) realSrcLc+ pstate str = initParserState (initParserOpts dflags) (stringToStringBuffer str) realSrcLc (wrap,str1) = case str0 of '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names -> (Parenthesized, init s)
haddock-api/src/Haddock/Syb.hs view
@@ -6,7 +6,7 @@ module Haddock.Syb ( everything, everythingButType, everythingWithState , everywhere, everywhereButType- , mkT+ , mkT, mkQ, extQ , combine ) where @@ -90,6 +90,21 @@ mkT f = case cast f of Just f' -> f' Nothing -> id++-- | Create generic query.+--+-- Another function stolen from SYB package.+mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r+(r `mkQ` br) a = case cast a of+ Just b -> br b+ Nothing -> r+++-- | Extend a generic query by a type-specific case.+--+-- Another function stolen from SYB package.+extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q+extQ f g a = maybe (f a) g (cast a) -- | Combine two queries into one using alternative combinator. combine :: Alternative f => (forall a. Data a => a -> f r)
haddock-api/src/Haddock/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]@@ -44,7 +45,9 @@ import Data.Data (Data) import Data.Void (Void) import Documentation.Haddock.Types-import GHC.Types.Basic (Fixity(..), PromotionFlag(..))+import GHC.Types.Basic (PromotionFlag(..))+import GHC.Types.Fixity (Fixity(..))+import GHC.Types.Var (Specificity) import GHC import GHC.Driver.Session (Language)@@ -311,10 +314,12 @@ data DocNameI +type instance NoGhcTc DocNameI = DocNameI+ type instance IdP DocNameI = DocName instance CollectPass DocNameI where- collectXXPat _ ext = noExtCon ext+ collectXXPat _ _ ext = noExtCon ext instance NamedThing DocName where getName (Documented name _) = name@@ -403,13 +408,13 @@ -- 'PseudoFamilyDecl' type is introduced. data PseudoFamilyDecl name = PseudoFamilyDecl { pfdInfo :: FamilyInfo name- , pfdLName :: Located (IdP name)+ , pfdLName :: LocatedN (IdP name) , pfdTyVars :: [LHsType name] , pfdKindSig :: LFamilyResultSig name } -mkPseudoFamilyDecl :: FamilyDecl (GhcPass p) -> PseudoFamilyDecl (GhcPass p)+mkPseudoFamilyDecl :: FamilyDecl GhcRn -> PseudoFamilyDecl GhcRn mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl { pfdInfo = fdInfo , pfdLName = fdLName@@ -417,12 +422,12 @@ , pfdKindSig = fdResultSig } where- mkType :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p)+ mkType :: HsTyVarBndr flag GhcRn -> HsType GhcRn mkType (KindedTyVar _ _ (L loc name) lkind) =- HsKindSig noExtField tvar lkind+ HsKindSig noAnn tvar lkind where- tvar = L loc (HsTyVar noExtField NotPromoted (L loc name))- mkType (UserTyVar _ _ name) = HsTyVar noExtField NotPromoted name+ tvar = L (na2la loc) (HsTyVar noAnn NotPromoted (L loc name))+ mkType (UserTyVar _ _ name) = HsTyVar noAnn NotPromoted name -- | An instance head that may have documentation and a source location.@@ -687,41 +692,71 @@ liftErrMsg :: ErrMsgM a -> ErrMsgGhc a liftErrMsg = writer . runWriter -instance MonadThrow ErrMsgGhc where- throwM e = ErrMsgGhc (throwM e)--instance MonadCatch ErrMsgGhc where- catch (ErrMsgGhc m) f = ErrMsgGhc (catch m (unErrMsgGhc . f))- ----------------------------------------------------------------------------- -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance XRec DocNameI f = Located (f DocNameI)+type instance XRec DocNameI a = GenLocated (Anno a) a+instance UnXRec DocNameI where+ unXRec = unLoc+instance MapXRec DocNameI where+ mapXRec = fmap+instance WrapXRec DocNameI (HsType DocNameI) where+ wrapXRec = noLocA -type instance XForAllTy DocNameI = NoExtField-type instance XQualTy DocNameI = NoExtField-type instance XTyVar DocNameI = NoExtField-type instance XStarTy DocNameI = NoExtField-type instance XAppTy DocNameI = NoExtField-type instance XAppKindTy DocNameI = NoExtField-type instance XFunTy DocNameI = NoExtField-type instance XListTy DocNameI = NoExtField-type instance XTupleTy DocNameI = NoExtField-type instance XSumTy DocNameI = NoExtField-type instance XOpTy DocNameI = NoExtField-type instance XParTy DocNameI = NoExtField-type instance XIParamTy DocNameI = NoExtField-type instance XKindSig DocNameI = NoExtField+type instance Anno DocName = SrcSpanAnnN+type instance Anno (HsTyVarBndr flag DocNameI) = SrcSpanAnnA+type instance Anno [LocatedA (HsType DocNameI)] = SrcSpanAnnC+type instance Anno (HsType DocNameI) = SrcSpanAnnA+type instance Anno (DataFamInstDecl DocNameI) = SrcSpanAnnA+type instance Anno (DerivStrategy DocNameI) = SrcSpan+type instance Anno (FieldOcc DocNameI) = SrcSpan+type instance Anno (ConDeclField DocNameI) = SrcSpan+type instance Anno (Located (ConDeclField DocNameI)) = SrcSpan+type instance Anno [Located (ConDeclField DocNameI)] = SrcSpan+type instance Anno (ConDecl DocNameI) = SrcSpan+type instance Anno (FunDep DocNameI) = SrcSpan+type instance Anno (TyFamInstDecl DocNameI) = SrcSpanAnnA+type instance Anno [LocatedA (TyFamInstDecl DocNameI)] = SrcSpanAnnL+type instance Anno (FamilyDecl DocNameI) = SrcSpan+type instance Anno (Sig DocNameI) = SrcSpan+type instance Anno (InjectivityAnn DocNameI) = SrcSpan+type instance Anno (HsDecl DocNameI) = SrcSpanAnnA+type instance Anno (FamilyResultSig DocNameI) = SrcSpan+type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA+type instance Anno (HsSigType DocNameI) = SrcSpanAnnA++type XRecCond a+ = ( XParTy a ~ EpAnn AnnParen+ , NoGhcTc a ~ a+ , MapXRec a+ , UnXRec a+ , WrapXRec a (HsType a)+ )++type instance XForAllTy DocNameI = EpAnn [AddEpAnn]+type instance XQualTy DocNameI = EpAnn [AddEpAnn]+type instance XTyVar DocNameI = EpAnn [AddEpAnn]+type instance XStarTy DocNameI = EpAnn [AddEpAnn]+type instance XAppTy DocNameI = EpAnn [AddEpAnn]+type instance XAppKindTy DocNameI = EpAnn [AddEpAnn]+type instance XFunTy DocNameI = EpAnn [AddEpAnn]+type instance XListTy DocNameI = EpAnn AnnParen+type instance XTupleTy DocNameI = EpAnn AnnParen+type instance XSumTy DocNameI = EpAnn AnnParen+type instance XOpTy DocNameI = EpAnn [AddEpAnn]+type instance XParTy DocNameI = EpAnn AnnParen+type instance XIParamTy DocNameI = EpAnn [AddEpAnn]+type instance XKindSig DocNameI = EpAnn [AddEpAnn] type instance XSpliceTy DocNameI = Void -- see `renameHsSpliceTy`-type instance XDocTy DocNameI = NoExtField-type instance XBangTy DocNameI = NoExtField-type instance XRecTy DocNameI = NoExtField-type instance XExplicitListTy DocNameI = NoExtField-type instance XExplicitTupleTy DocNameI = NoExtField-type instance XTyLit DocNameI = NoExtField-type instance XWildCardTy DocNameI = NoExtField-type instance XXType DocNameI = NewHsTypeX+type instance XDocTy DocNameI = EpAnn [AddEpAnn]+type instance XBangTy DocNameI = EpAnn [AddEpAnn]+type instance XRecTy DocNameI = EpAnn [AddEpAnn]+type instance XExplicitListTy DocNameI = EpAnn [AddEpAnn]+type instance XExplicitTupleTy DocNameI = EpAnn [AddEpAnn]+type instance XTyLit DocNameI = EpAnn [AddEpAnn]+type instance XWildCardTy DocNameI = EpAnn [AddEpAnn]+type instance XXType DocNameI = HsCoreTy type instance XHsForAllVis DocNameI = NoExtField type instance XHsForAllInvis DocNameI = NoExtField@@ -763,6 +798,9 @@ type instance XCClsInstDecl DocNameI = NoExtField type instance XCDerivDecl DocNameI = NoExtField+type instance XStockStrategy DocNameI = NoExtField+type instance XAnyClassStrategy DocNameI = NoExtField+type instance XNewtypeStrategy DocNameI = NoExtField type instance XViaStrategy DocNameI = LHsSigType DocNameI type instance XDataFamInstD DocNameI = NoExtField type instance XTyFamInstD DocNameI = NoExtField@@ -776,12 +814,23 @@ type instance XXFamilyDecl DocNameI = NoExtCon type instance XXTyClDecl DocNameI = NoExtCon -type instance XHsIB DocNameI _ = NoExtField-type instance XHsWC DocNameI _ = NoExtField-type instance XXHsImplicitBndrs DocNameI _ = NoExtCon+type instance XHsWC DocNameI _ = NoExtField +type instance XHsOuterExplicit DocNameI _ = NoExtField+type instance XHsOuterImplicit DocNameI = NoExtField+type instance XXHsOuterTyVarBndrs DocNameI = NoExtCon++type instance XHsSig DocNameI = NoExtField+type instance XXHsSigType DocNameI = NoExtCon+ type instance XHsQTvs DocNameI = NoExtField type instance XConDeclField DocNameI = NoExtField type instance XXConDeclField DocNameI = NoExtCon type instance XXPat DocNameI = NoExtCon++type instance XCInjectivityAnn DocNameI = NoExtField++type instance XCFunDep DocNameI = NoExtField++type instance XCTyFamInstDecl DocNameI = NoExtField
haddock-api/src/Haddock/Utils.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Utils
haddock-api/src/Haddock/Utils/Json.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} -- | Minimal JSON / RFC 7159 support --@@ -14,53 +12,35 @@ , encodeToString , encodeToBuilder , ToJSON(toJSON)-- , Parser(..)- , Result(..)- , FromJSON(parseJSON)- , withObject- , withArray- , withString- , withDouble- , withBool- , fromJSON- , parse- , parseEither- , (.:)- , (.:?)- , decode- , decodeWith- , eitherDecode- , eitherDecodeWith- , decodeFile- , eitherDecodeFile ) where -import Control.Applicative (Alternative (..))-import Control.Monad (MonadPlus (..), zipWithM, (>=>))-import qualified Control.Monad as Monad-import qualified Control.Monad.Fail as Fail--import qualified Data.ByteString.Lazy as BSL-import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder as BB import Data.Char import Data.Int+import Data.String import Data.Word import Data.List (intersperse) import Data.Monoid -import GHC.Natural+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BB -- TODO: We may want to replace 'String' with 'Text' or 'ByteString' -import qualified Text.Parsec.ByteString.Lazy as Parsec.Lazy-import qualified Text.ParserCombinators.Parsec as Parsec+-- | A JSON value represented as a Haskell value.+data Value = Object !Object+ | Array [Value]+ | String String+ | Number !Double+ | Bool !Bool+ | Null+ deriving (Eq, Read, Show) -import Haddock.Utils.Json.Types-import Haddock.Utils.Json.Parser+-- | A key\/value pair for an 'Object'+type Pair = (String, Value) +-- | A JSON \"object\" (key/value map).+type Object = [Pair] infixr 8 .= @@ -68,7 +48,14 @@ (.=) :: ToJSON v => String -> v -> Pair k .= v = (k, toJSON v) +-- | Create a 'Value' from a list of name\/value 'Pair's.+object :: [Pair] -> Value+object = Object +instance IsString Value where+ fromString = String++ -- | A type that can be converted to JSON. class ToJSON a where -- | Convert a Haskell value to a JSON-friendly intermediate type.@@ -236,324 +223,3 @@ -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF needsEscape c = ord c < 0x20 || c `elem` ['\\','"']----------------------------------------------------------------------------------- FromJSON---- | Elements of a JSON path used to describe the location of an--- error.-data JSONPathElement- = Key String- -- ^ JSON path element of a key into an object,- -- \"object.key\".- | Index !Int- -- ^ JSON path element of an index into an- -- array, \"array[index]\".- deriving (Eq, Show, Ord)--type JSONPath = [JSONPathElement]---- | Failure continuation.-type Failure f r = JSONPath -> String -> f r---- | Success continuation.-type Success a f r = a -> f r--newtype Parser a = Parser {- runParser :: forall f r.- JSONPath- -> Failure f r- -> Success a f r- -> f r- }--modifyFailure :: (String -> String) -> Parser a -> Parser a-modifyFailure f (Parser p) = Parser $ \path kf ks ->- p path (\p' m -> kf p' (f m)) ks--prependFailure :: String -> Parser a -> Parser a-prependFailure = modifyFailure . (++)--prependContext :: String -> Parser a -> Parser a-prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")--typeMismatch :: String -> Value -> Parser a-typeMismatch expected actual =- fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual--instance Monad.Monad Parser where- m >>= g = Parser $ \path kf ks ->- runParser m path kf- (\a -> runParser (g a) path kf ks)- return = pure--instance Fail.MonadFail Parser where- fail msg = Parser $ \path kf _ks -> kf (reverse path) msg--instance Functor Parser where- fmap f m = Parser $ \path kf ks ->- let ks' a = ks (f a)- in runParser m path kf ks'--instance Applicative Parser where- pure a = Parser $ \_path _kf ks -> ks a- (<*>) = apP--instance Alternative Parser where- empty = fail "empty"- (<|>) = mplus--instance MonadPlus Parser where- mzero = fail "mzero"- mplus a b = Parser $ \path kf ks ->- runParser a path (\_ _ -> runParser b path kf ks) ks--instance Semigroup (Parser a) where- (<>) = mplus--instance Monoid (Parser a) where- mempty = fail "mempty"- mappend = (<>)--apP :: Parser (a -> b) -> Parser a -> Parser b-apP d e = do- b <- d- b <$> e--(<?>) :: Parser a -> JSONPathElement -> Parser a-p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks--parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a-parseIndexedJSON p idx value = p value <?> Index idx--unexpected :: Value -> Parser a-unexpected actual = fail $ "unexpected " ++ typeOf actual--withObject :: String -> (Object -> Parser a) -> Value -> Parser a-withObject _ f (Object obj) = f obj-withObject name _ v = prependContext name (typeMismatch "Object" v)--withArray :: String -> ([Value] -> Parser a) -> Value -> Parser a-withArray _ f (Array arr) = f arr-withArray name _ v = prependContext name (typeMismatch "Array" v)--withString :: String -> (String -> Parser a) -> Value -> Parser a-withString _ f (String txt) = f txt-withString name _ v = prependContext name (typeMismatch "String" v)--withDouble :: String -> (Double -> Parser a) -> Value -> Parser a-withDouble _ f (Number duble) = f duble-withDouble name _ v = prependContext name (typeMismatch "Number" v)--withBool :: String -> (Bool -> Parser a) -> Value -> Parser a-withBool _ f (Bool arr) = f arr-withBool name _ v = prependContext name (typeMismatch "Boolean" v)--class FromJSON a where- parseJSON :: Value -> Parser a-- parseJSONList :: Value -> Parser [a]- parseJSONList = withArray "[]" (zipWithM (parseIndexedJSON parseJSON) [0..])--instance FromJSON Bool where- parseJSON (Bool b) = pure b- parseJSON v = typeMismatch "Bool" v--instance FromJSON () where- parseJSON =- withArray "()" $ \v ->- if null v- then pure ()- else prependContext "()" $ fail "expected an empty array"--instance FromJSON Char where- parseJSON = withString "Char" parseChar-- parseJSONList (String s) = pure s- parseJSONList v = typeMismatch "String" v--parseChar :: String -> Parser Char-parseChar t =- if length t == 1- then pure $ head t- else prependContext "Char" $ fail "expected a string of length 1"--parseRealFloat :: RealFloat a => String -> Value -> Parser a-parseRealFloat _ (Number s) = pure $ realToFrac s-parseRealFloat _ Null = pure (0/0)-parseRealFloat name v = prependContext name (unexpected v)--instance FromJSON Double where- parseJSON = parseRealFloat "Double"--instance FromJSON Float where- parseJSON = parseRealFloat "Float"--parseNatural :: Integer -> Parser Natural-parseNatural integer =- if integer < 0 then- fail $ "parsing Natural failed, unexpected negative number " <> show integer- else- pure $ fromIntegral integer--parseIntegralFromDouble :: Integral a => Double -> Parser a-parseIntegralFromDouble d =- let r = toRational d- x = truncate r- in if toRational x == r- then pure $ x- else fail $ "unexpected floating number " <> show d--parseIntegral :: Integral a => String -> Value -> Parser a-parseIntegral name = withDouble name parseIntegralFromDouble--instance FromJSON Integer where- parseJSON = parseIntegral "Integer"--instance FromJSON Natural where- parseJSON = withDouble "Natural"- (parseIntegralFromDouble >=> parseNatural)--instance FromJSON Int where- parseJSON = parseIntegral "Int"--instance FromJSON Int8 where- parseJSON = parseIntegral "Int8"--instance FromJSON Int16 where- parseJSON = parseIntegral "Int16"--instance FromJSON Int32 where- parseJSON = parseIntegral "Int32"--instance FromJSON Int64 where- parseJSON = parseIntegral "Int64"--instance FromJSON Word where- parseJSON = parseIntegral "Word"--instance FromJSON Word8 where- parseJSON = parseIntegral "Word8"--instance FromJSON Word16 where- parseJSON = parseIntegral "Word16"--instance FromJSON Word32 where- parseJSON = parseIntegral "Word32"--instance FromJSON Word64 where- parseJSON = parseIntegral "Word64"--instance FromJSON a => FromJSON [a] where- parseJSON = parseJSONList--data Result a = Error String- | Success a- deriving (Eq, Show)--fromJSON :: FromJSON a => Value -> Result a-fromJSON = parse parseJSON--parse :: (a -> Parser b) -> a -> Result b-parse m v = runParser (m v) [] (const Error) Success--parseEither :: (a -> Parser b) -> a -> Either String b-parseEither m v = runParser (m v) [] onError Right- where onError path msg = Left (formatError path msg)--formatError :: JSONPath -> String -> String-formatError path msg = "Error in " ++ formatPath path ++ ": " ++ msg--formatPath :: JSONPath -> String-formatPath path = "$" ++ formatRelativePath path--formatRelativePath :: JSONPath -> String-formatRelativePath path = format "" path- where- format :: String -> JSONPath -> String- format pfx [] = pfx- format pfx (Index idx:parts) = format (pfx ++ "[" ++ show idx ++ "]") parts- format pfx (Key key:parts) = format (pfx ++ formatKey key) parts-- formatKey :: String -> String- formatKey key- | isIdentifierKey key = "." ++ key- | otherwise = "['" ++ escapeKey key ++ "']"-- isIdentifierKey :: String -> Bool- isIdentifierKey [] = False- isIdentifierKey (x:xs) = isAlpha x && all isAlphaNum xs-- escapeKey :: String -> String- escapeKey = concatMap escapeChar-- escapeChar :: Char -> String- escapeChar '\'' = "\\'"- escapeChar '\\' = "\\\\"- escapeChar c = [c]--explicitParseField :: (Value -> Parser a) -> Object -> String -> Parser a-explicitParseField p obj key =- case key `lookup` obj of- Nothing -> fail $ "key " ++ key ++ " not found"- Just v -> p v <?> Key key--(.:) :: FromJSON a => Object -> String -> Parser a-(.:) = explicitParseField parseJSON--explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> String -> Parser (Maybe a)-explicitParseFieldMaybe p obj key =- case key `lookup` obj of- Nothing -> pure Nothing- Just v -> Just <$> p v <?> Key key--(.:?) :: FromJSON a => Object -> String -> Parser (Maybe a)-(.:?) = explicitParseFieldMaybe parseJSON---decodeWith :: (Value -> Result a) -> BSL.ByteString -> Maybe a-decodeWith decoder bsl =- case Parsec.parse parseJSONValue "<input>" bsl of- Left _ -> Nothing- Right json ->- case decoder json of- Success a -> Just a- Error _ -> Nothing--decode :: FromJSON a => BSL.ByteString -> Maybe a-decode = decodeWith fromJSON--eitherDecodeWith :: (Value -> Result a) -> BSL.ByteString -> Either String a-eitherDecodeWith decoder bsl =- case Parsec.parse parseJSONValue "<input>" bsl of- Left parsecError -> Left (show parsecError)- Right json ->- case decoder json of- Success a -> Right a- Error err -> Left err--eitherDecode :: FromJSON a => BSL.ByteString -> Either String a-eitherDecode = eitherDecodeWith fromJSON---decodeFile :: FromJSON a => FilePath -> IO (Maybe a)-decodeFile filePath = do- parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath- case parsecResult of- Right r ->- case fromJSON r of- Success a -> return (Just a)- Error _ -> return Nothing- Left _ -> return Nothing---eitherDecodeFile :: FromJSON a => FilePath -> IO (Either String a)-eitherDecodeFile filePath = do- parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath- case parsecResult of- Right r ->- case fromJSON r of- Success a -> return (Right a)- Error err -> return (Left err)- Left err -> return $ Left (show err)-
− haddock-api/src/Haddock/Utils/Json/Parser.hs
@@ -1,102 +0,0 @@--- | Json "Parsec" parser, based on--- [json](https://hackage.haskell.org/package/json) package.----module Haddock.Utils.Json.Parser- ( parseJSONValue- ) where--import Prelude hiding (null)--import Control.Applicative (Alternative (..))-import Control.Monad (MonadPlus (..))-import Data.Char (isHexDigit)-import Data.Functor (($>))-import qualified Data.ByteString.Lazy.Char8 as BSCL-import Numeric-import Text.Parsec.ByteString.Lazy (Parser)-import Text.ParserCombinators.Parsec ((<?>))-import qualified Text.ParserCombinators.Parsec as Parsec--import Haddock.Utils.Json.Types hiding (object)--parseJSONValue :: Parser Value-parseJSONValue = Parsec.spaces *> parseValue--tok :: Parser a -> Parser a-tok p = p <* Parsec.spaces--parseValue :: Parser Value-parseValue =- parseNull- <|> Bool <$> parseBoolean- <|> Array <$> parseArray- <|> String <$> parseString- <|> Object <$> parseObject- <|> Number <$> parseNumber- <?> "JSON value"--parseNull :: Parser Value-parseNull = tok- $ Parsec.string "null"- $> Null--parseBoolean :: Parser Bool-parseBoolean = tok- $ Parsec.string "true" $> True- <|> Parsec.string "false" $> False--parseArray :: Parser [Value]-parseArray =- Parsec.between- (tok (Parsec.char '['))- (tok (Parsec.char ']'))- (parseValue `Parsec.sepBy` tok (Parsec.char ','))--parseString :: Parser String-parseString =- Parsec.between- (tok (Parsec.char '"'))- (tok (Parsec.char '"'))- (many char)- where- char = (Parsec.char '\\' >> escapedChar)- <|> Parsec.satisfy (\x -> x /= '"' && x /= '\\')-- escapedChar =- Parsec.char '"' $> '"'- <|> Parsec.char '\\' $> '\\'- <|> Parsec.char '/' $> '/'- <|> Parsec.char 'b' $> '\b'- <|> Parsec.char 'f' $> '\f'- <|> Parsec.char 'n' $> '\n'- <|> Parsec.char 'r' $> '\r'- <|> Parsec.char 't' $> '\t'- <|> Parsec.char 'u' *> uni- <?> "escape character"-- uni = check =<< Parsec.count 4 (Parsec.satisfy isHexDigit)- where- check x | code <= max_char = return (toEnum code)- | otherwise = mzero- where code = fst $ head $ readHex x- max_char = fromEnum (maxBound :: Char)--parseObject :: Parser Object-parseObject =- Parsec.between- (tok (Parsec.char '{'))- (tok (Parsec.char '}'))- (field `Parsec.sepBy` tok (Parsec.char ','))- where- field :: Parser (String, Value)- field = (,)- <$> parseString- <* tok (Parsec.char ':')- <*> parseValue--parseNumber :: Parser Double-parseNumber = tok $ do- s <- BSCL.unpack <$> Parsec.getInput- case readSigned readFloat s of- [(n,s')] -> Parsec.setInput (BSCL.pack s') $> n- _ -> mzero
− haddock-api/src/Haddock/Utils/Json/Types.hs
@@ -1,42 +0,0 @@-module Haddock.Utils.Json.Types- ( Value(..)- , typeOf- , Pair- , Object- , object- ) where--import Data.String---- TODO: We may want to replace 'String' with 'Text' or 'ByteString'---- | A JSON value represented as a Haskell value.-data Value = Object !Object- | Array [Value]- | String String- | Number !Double- | Bool !Bool- | Null- deriving (Eq, Read, Show)--typeOf :: Value -> String-typeOf v = case v of- Object _ -> "Object"- Array _ -> "Array"- String _ -> "String"- Number _ -> "Number"- Bool _ -> "Boolean"- Null -> "Null"---- | A key\/value pair for an 'Object'-type Pair = (String, Value)---- | A JSON \"object\" (key/value map).-type Object = [Pair]---- | Create a 'Value' from a list of name\/value 'Pair's.-object :: [Pair] -> Value-object = Object--instance IsString Value where- fromString = String
haddock.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: haddock-version: 2.25.1+version: 2.26.0 synopsis: A documentation-generation tool for Haskell libraries description: This is Haddock, a tool for automatically generating documentation@@ -27,13 +27,13 @@ license: BSD-3-Clause license-file: LICENSE author: Simon Marlow, David Waern-maintainer: Hécate Moonlight <hecate@glitchbra.in>, Alex Biehl <alexbiehl@gmail.com>+maintainer: Alec Theriault <alec.theriault@gmail.com>, Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple-tested-with: GHC==9.0.*+tested-with: GHC==9.2.* extra-source-files: CHANGES.md@@ -81,7 +81,7 @@ xhtml >= 3000.2 && < 3000.3, ghc-boot, ghc-boot-th,- ghc == 9.0.*,+ ghc == 9.2.*, bytestring, parsec, text,@@ -111,8 +111,6 @@ Haddock.Parser Haddock.Utils Haddock.Utils.Json- Haddock.Utils.Json.Parser- Haddock.Utils.Json.Types Haddock.Backends.Xhtml Haddock.Backends.Xhtml.Decl Haddock.Backends.Xhtml.DocMarkup@@ -148,7 +146,7 @@ else -- in order for haddock's advertised version number to have proper meaning, -- we pin down to a single haddock-api version.- build-depends: haddock-api == 2.25.1+ build-depends: haddock-api == 2.26.0 test-suite html-test type: exitcode-stdio-1.0
hoogle-test/ref/Bug806/test.txt view
@@ -20,6 +20,6 @@ class C a where { -- | <a>AT</a> docs- type family AT a;+ type AT a; type AT a = Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy))))))))); }
hoogle-test/ref/assoc-types/test.txt view
@@ -6,8 +6,8 @@ module AssocTypes class Foo a where {- type family Bar a b;- type family Baz a;+ type Bar a b;+ type Baz a; type Baz a = [(a, a)]; } bar :: Foo a => Bar a a
html-test/ref/Bug1004.html view
@@ -1472,8 +1472,150 @@ ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Generic:16"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Monoid:16" ></span+ > (<a href="#" title="Data.Monoid"+ >Monoid</a+ > (f a), <a href="#" title="Data.Monoid"+ >Monoid</a+ > (g a)) => <a href="#" title="Data.Monoid"+ >Monoid</a+ > (<a href="#" title="Bug1004"+ >Product</a+ > f g a)</span+ ></td+ ><td class="doc"+ ><p+ ><em+ >Since: base-4.16.0.0</em+ ></p+ ></td+ ></tr+ ><tr+ ><td colspan="2"+ ><details id="i:id:Product:Monoid:16"+ ><summary class="hide-when-js-enabled"+ >Instance details</summary+ ><p+ >Defined in <a href="#"+ >Data.Functor.Product</a+ ></p+ > <div class="subs methods"+ ><p class="caption"+ >Methods</p+ ><p class="src"+ ><a href="#"+ >mempty</a+ > :: <a href="#" title="Bug1004"+ >Product</a+ > f g a <a href="#" class="selflink"+ >#</a+ ></p+ ><p class="src"+ ><a href="#"+ >mappend</a+ > :: <a href="#" title="Bug1004"+ >Product</a+ > f g a -> <a href="#" title="Bug1004"+ >Product</a+ > f g a -> <a href="#" title="Bug1004"+ >Product</a+ > f g a <a href="#" class="selflink"+ >#</a+ ></p+ ><p class="src"+ ><a href="#"+ >mconcat</a+ > :: [<a href="#" title="Bug1004"+ >Product</a+ > f g a] -> <a href="#" title="Bug1004"+ >Product</a+ > f g a <a href="#" class="selflink"+ >#</a+ ></p+ ></div+ ></details+ ></td+ ></tr+ ><tr+ ><td class="src clearfix"+ ><span class="inst-left"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Semigroup:17"+ ></span+ > (<a href="#" title="Prelude"+ >Semigroup</a+ > (f a), <a href="#" title="Prelude"+ >Semigroup</a+ > (g a)) => <a href="#" title="Prelude"+ >Semigroup</a+ > (<a href="#" title="Bug1004"+ >Product</a+ > f g a)</span+ ></td+ ><td class="doc"+ ><p+ ><em+ >Since: base-4.16.0.0</em+ ></p+ ></td+ ></tr+ ><tr+ ><td colspan="2"+ ><details id="i:id:Product:Semigroup:17"+ ><summary class="hide-when-js-enabled"+ >Instance details</summary+ ><p+ >Defined in <a href="#"+ >Data.Functor.Product</a+ ></p+ > <div class="subs methods"+ ><p class="caption"+ >Methods</p+ ><p class="src"+ ><a href="#"+ >(<>)</a+ > :: <a href="#" title="Bug1004"+ >Product</a+ > f g a -> <a href="#" title="Bug1004"+ >Product</a+ > f g a -> <a href="#" title="Bug1004"+ >Product</a+ > f g a <a href="#" class="selflink"+ >#</a+ ></p+ ><p class="src"+ ><a href="#"+ >sconcat</a+ > :: <a href="#" title="Data.List.NonEmpty"+ >NonEmpty</a+ > (<a href="#" title="Bug1004"+ >Product</a+ > f g a) -> <a href="#" title="Bug1004"+ >Product</a+ > f g a <a href="#" class="selflink"+ >#</a+ ></p+ ><p class="src"+ ><a href="#"+ >stimes</a+ > :: <a href="#" title="Prelude"+ >Integral</a+ > b => b -> <a href="#" title="Bug1004"+ >Product</a+ > f g a -> <a href="#" title="Bug1004"+ >Product</a+ > f g a <a href="#" class="selflink"+ >#</a+ ></p+ ></div+ ></details+ ></td+ ></tr+ ><tr+ ><td class="src clearfix"+ ><span class="inst-left"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Generic:18"+ ></span > <a href="#" title="GHC.Generics" >Generic</a > (<a href="#" title="Bug1004"@@ -1485,7 +1627,7 @@ ></tr ><tr ><td colspan="2"- ><details id="i:id:Product:Generic:16"+ ><details id="i:id:Product:Generic:18" ><summary class="hide-when-js-enabled" >Instance details</summary ><p@@ -1544,7 +1686,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Read:17"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Read:19" ></span > (<a href="#" title="Data.Functor.Classes" >Read1</a@@ -1567,7 +1709,7 @@ ></tr ><tr ><td colspan="2"- ><details id="i:id:Product:Read:17"+ ><details id="i:id:Product:Read:19" ><summary class="hide-when-js-enabled" >Instance details</summary ><p@@ -1626,7 +1768,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Show:18"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Show:20" ></span > (<a href="#" title="Data.Functor.Classes" >Show1</a@@ -1649,7 +1791,7 @@ ></tr ><tr ><td colspan="2"- ><details id="i:id:Product:Show:18"+ ><details id="i:id:Product:Show:20" ><summary class="hide-when-js-enabled" >Instance details</summary ><p@@ -1698,7 +1840,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Eq:19"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Eq:21" ></span > (<a href="#" title="Data.Functor.Classes" >Eq1</a@@ -1721,7 +1863,7 @@ ></tr ><tr ><td colspan="2"- ><details id="i:id:Product:Eq:19"+ ><details id="i:id:Product:Eq:21" ><summary class="hide-when-js-enabled" >Instance details</summary ><p@@ -1762,7 +1904,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Ord:20"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Ord:22" ></span > (<a href="#" title="Data.Functor.Classes" >Ord1</a@@ -1785,7 +1927,7 @@ ></tr ><tr ><td colspan="2"- ><details id="i:id:Product:Ord:20"+ ><details id="i:id:Product:Ord:22" ><summary class="hide-when-js-enabled" >Instance details</summary ><p@@ -1886,7 +2028,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Rep1:21"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Rep1:23" ></span > <span class="keyword" >type</span@@ -1907,7 +2049,7 @@ ></tr ><tr ><td colspan="2"- ><details id="i:id:Product:Rep1:21"+ ><details id="i:id:Product:Rep1:23" ><summary class="hide-when-js-enabled" >Instance details</summary ><p@@ -1982,7 +2124,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Rep:22"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Rep:24" ></span > <span class="keyword" >type</span@@ -2001,7 +2143,7 @@ ></tr ><tr ><td colspan="2"- ><details id="i:id:Product:Rep:22"+ ><details id="i:id:Product:Rep:24" ><summary class="hide-when-js-enabled" >Instance details</summary ><p
html-test/ref/Bug1035.html view
@@ -138,7 +138,7 @@ ><p >A link to <code ><a href="#" title="Bug1035"- >Bar</a+ >Foo</a ></code ></p ></div
− html-test/ref/Bug1206.html
@@ -1,488 +0,0 @@-<html xmlns="http://www.w3.org/1999/xhtml"-><head- ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"- /><meta name="viewport" content="width=device-width, initial-scale=1"- /><title- >Bug1206</title- ><link href="#" rel="stylesheet" type="text/css" title="Linuwial"- /><link rel="stylesheet" type="text/css" href="#"- /><link rel="stylesheet" type="text/css" href="#"- /><script src="haddock-bundle.min.js" async="async" type="text/javascript"- ></script- ><script type="text/x-mathjax-config"- >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script- ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"- ></script- ></head- ><body- ><div id="package-header"- ><span class="caption empty"- > </span- ><ul class="links" id="page-menu"- ><li- ><a href="#"- >Contents</a- ></li- ><li- ><a href="#"- >Index</a- ></li- ></ul- ></div- ><div id="content"- ><div id="module-header"- ><table class="info"- ><tr- ><th- >Safe Haskell</th- ><td- >Safe-Inferred</td- ></tr- ><tr- ><th- >Language</th- ><td- >Haskell2010</td- ></tr- ></table- ><p class="caption"- >Bug1206</p- ></div- ><div id="description"- ><p class="caption"- >Description</p- ><div class="doc"- ><p- >Bug 1206</p- ></div- ></div- ><div id="synopsis"- ><details id="syn"- ><summary- >Synopsis</summary- ><ul class="details-toggle" data-details-id="syn"- ><li class="src short"- ><span class="keyword"- >data</span- > <a href="#"- >T</a- > a = <a href="#"- >T</a- > a</li- ></ul- ></details- ></div- ><div id="interface"- ><h1- >Documentation</h1- ><div class="top"- ><p class="src"- ><span class="keyword"- >data</span- > <a id="t:T" class="def"- >T</a- > a <a href="#" class="selflink"- >#</a- ></p- ><div class="doc"- ><p- >A simple identity type</p- ></div- ><div class="subs constructors"- ><p class="caption"- >Constructors</p- ><table- ><tr- ><td class="src"- ><a id="v:T" class="def"- >T</a- > a</td- ><td class="doc empty"- > </td- ></tr- ></table- ></div- ><div class="subs instances"- ><h4 class="instances details-toggle-control details-toggle" data-details-id="i:T"- >Instances</h4- ><details id="i:T" open="open"- ><summary class="hide-when-js-enabled"- >Instances details</summary- ><table- ><tr- ><td class="src clearfix"- ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:T:Monoid:1"- ></span- > <a href="#" title="Data.Monoid"- >Monoid</a- > a => <a href="#" title="Data.Monoid"- >Monoid</a- > (<a href="#" title="Bug1206"- >T</a- > a)</span- > <a href="#" class="selflink"- >#</a- ></td- ><td class="doc"- ><p- ><code- ><a href="#" title="Data.Monoid"- >mempty</a- ></code- > = 'T mempty'</p- ><p- >Docs for the <code- >Monoid</code- > instance of <code- >Monoid a => T a</code- ></p- ><h4 class="subheading details-toggle-control details-toggle" data-details-id="ch:Monoid_1:0"- >Examples</h4- ><details id="ch:Monoid_1:0"- ><summary class="hide-when-js-enabled"- >Expand</summary- ><pre class="screen"- ><code class="prompt"- >>>> </code- ><strong class="userinput"- ><code- >mempty :: T String-</code- ></strong- >T ""-</pre- ></details- ></td- ></tr- ><tr- ><td colspan="2"- ><details id="i:id:T:Monoid:1"- ><summary class="hide-when-js-enabled"- >Instance details</summary- ><p- >Defined in <a href="#"- >Bug1206</a- ></p- > <div class="subs methods"- ><p class="caption"- >Methods</p- ><p class="src"- ><a href="#"- >mempty</a- > :: <a href="#" title="Bug1206"- >T</a- > a <a href="#" class="selflink"- >#</a- ></p- ><p class="src"- ><a href="#"- >mappend</a- > :: <a href="#" title="Bug1206"- >T</a- > a -> <a href="#" title="Bug1206"- >T</a- > a -> <a href="#" title="Bug1206"- >T</a- > a <a href="#" class="selflink"- >#</a- ></p- ><p class="src"- ><a href="#"- >mconcat</a- > :: [<a href="#" title="Bug1206"- >T</a- > a] -> <a href="#" title="Bug1206"- >T</a- > a <a href="#" class="selflink"- >#</a- ></p- ></div- ></details- ></td- ></tr- ><tr- ><td class="src clearfix"- ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:T:Semigroup:2"- ></span- > <a href="#" title="Prelude"- >Semigroup</a- > (<a href="#" title="Bug1206"- >T</a- > <a href="#" title="Data.Int"- >Int</a- >)</span- > <a href="#" class="selflink"- >#</a- ></td- ><td class="doc"- ><p- ><code- ><a href="#" title="Data.Monoid"- ><></a- ></code- > = 'T (a + b)'</p- ><p- >Docs for the <code- >Semigroup</code- > instance of <code- >(T Int)</code- ></p- ><h4 class="subheading details-toggle-control details-toggle" data-details-id="ch:Semigroup_2:0"- >Examples</h4- ><details id="ch:Semigroup_2:0"- ><summary class="hide-when-js-enabled"- >Expand</summary- ><pre class="screen"- ><code class="prompt"- >>>> </code- ><strong class="userinput"- ><code- >T 2 <> T (3 :: Int)-</code- ></strong- >T 5-</pre- ></details- ></td- ></tr- ><tr- ><td colspan="2"- ><details id="i:id:T:Semigroup:2"- ><summary class="hide-when-js-enabled"- >Instance details</summary- ><p- >Defined in <a href="#"- >Bug1206</a- ></p- > <div class="subs methods"- ><p class="caption"- >Methods</p- ><p class="src"- ><a href="#"- >(<>)</a- > :: <a href="#" title="Bug1206"- >T</a- > <a href="#" title="Data.Int"- >Int</a- > -> <a href="#" title="Bug1206"- >T</a- > <a href="#" title="Data.Int"- >Int</a- > -> <a href="#" title="Bug1206"- >T</a- > <a href="#" title="Data.Int"- >Int</a- > <a href="#" class="selflink"- >#</a- ></p- ><p class="src"- ><a href="#"- >sconcat</a- > :: <a href="#" title="Data.List.NonEmpty"- >NonEmpty</a- > (<a href="#" title="Bug1206"- >T</a- > <a href="#" title="Data.Int"- >Int</a- >) -> <a href="#" title="Bug1206"- >T</a- > <a href="#" title="Data.Int"- >Int</a- > <a href="#" class="selflink"- >#</a- ></p- ><p class="src"- ><a href="#"- >stimes</a- > :: <a href="#" title="Prelude"- >Integral</a- > b => b -> <a href="#" title="Bug1206"- >T</a- > <a href="#" title="Data.Int"- >Int</a- > -> <a href="#" title="Bug1206"- >T</a- > <a href="#" title="Data.Int"- >Int</a- > <a href="#" class="selflink"- >#</a- ></p- ></div- ></details- ></td- ></tr- ><tr- ><td class="src clearfix"- ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:T:Semigroup:3"- ></span- > <a href="#" title="Prelude"- >Semigroup</a- > a => <a href="#" title="Prelude"- >Semigroup</a- > (<a href="#" title="Bug1206"- >T</a- > a)</span- > <a href="#" class="selflink"- >#</a- ></td- ><td class="doc"- ><p- ><code- ><a href="#" title="Data.Monoid"- ><></a- ></code- > = 'T (a <> b)'</p- ><p- >Docs for the <code- >Semigroup</code- > instance of <code- >Semigroup a => T a</code- ></p- ><h4 class="subheading details-toggle-control details-toggle" data-details-id="ch:Semigroup_3:0"- >Examples</h4- ><details id="ch:Semigroup_3:0"- ><summary class="hide-when-js-enabled"- >Expand</summary- ><pre class="screen"- ><code class="prompt"- >>>> </code- ><strong class="userinput"- ><code- >T (Product 1) <> T (Product 2)-</code- ></strong- >T (Product {getProduct = 2})-</pre- ></details- ></td- ></tr- ><tr- ><td colspan="2"- ><details id="i:id:T:Semigroup:3"- ><summary class="hide-when-js-enabled"- >Instance details</summary- ><p- >Defined in <a href="#"- >Bug1206</a- ></p- > <div class="subs methods"- ><p class="caption"- >Methods</p- ><p class="src"- ><a href="#"- >(<>)</a- > :: <a href="#" title="Bug1206"- >T</a- > a -> <a href="#" title="Bug1206"- >T</a- > a -> <a href="#" title="Bug1206"- >T</a- > a <a href="#" class="selflink"- >#</a- ></p- ><p class="src"- ><a href="#"- >sconcat</a- > :: <a href="#" title="Data.List.NonEmpty"- >NonEmpty</a- > (<a href="#" title="Bug1206"- >T</a- > a) -> <a href="#" title="Bug1206"- >T</a- > a <a href="#" class="selflink"- >#</a- ></p- ><p class="src"- ><a href="#"- >stimes</a- > :: <a href="#" title="Prelude"- >Integral</a- > b => b -> <a href="#" title="Bug1206"- >T</a- > a -> <a href="#" title="Bug1206"- >T</a- > a <a href="#" class="selflink"- >#</a- ></p- ></div- ></details- ></td- ></tr- ><tr- ><td class="src clearfix"- ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:T:Show:4"- ></span- > <a href="#" title="Text.Show"- >Show</a- > a => <a href="#" title="Text.Show"- >Show</a- > (<a href="#" title="Bug1206"- >T</a- > a)</span- > <a href="#" class="selflink"- >#</a- ></td- ><td class="doc empty"- > </td- ></tr- ><tr- ><td colspan="2"- ><details id="i:id:T:Show:4"- ><summary class="hide-when-js-enabled"- >Instance details</summary- ><p- >Defined in <a href="#"- >Bug1206</a- ></p- > <div class="subs methods"- ><p class="caption"- >Methods</p- ><p class="src"- ><a href="#"- >showsPrec</a- > :: <a href="#" title="Data.Int"- >Int</a- > -> <a href="#" title="Bug1206"- >T</a- > a -> <a href="#" title="Text.Show"- >ShowS</a- > <a href="#" class="selflink"- >#</a- ></p- ><p class="src"- ><a href="#"- >show</a- > :: <a href="#" title="Bug1206"- >T</a- > a -> <a href="#" title="Data.String"- >String</a- > <a href="#" class="selflink"- >#</a- ></p- ><p class="src"- ><a href="#"- >showList</a- > :: [<a href="#" title="Bug1206"- >T</a- > a] -> <a href="#" title="Text.Show"- >ShowS</a- > <a href="#" class="selflink"- >#</a- ></p- ></div- ></details- ></td- ></tr- ></table- ></details- ></div- ></div- ></div- ></div- ></body- ></html->
html-test/ref/Bug310.html view
@@ -56,14 +56,14 @@ ><li class="src short" ><span class="keyword" >type family</span- > (a :: <a href="#" title="GHC.TypeLits"- >Nat</a+ > (a :: <a href="#" title="Numeric.Natural"+ >Natural</a >) <a href="#" >+</a- > (b :: <a href="#" title="GHC.TypeLits"- >Nat</a- >) :: <a href="#" title="GHC.TypeLits"- >Nat</a+ > (b :: <a href="#" title="Numeric.Natural"+ >Natural</a+ >) :: <a href="#" title="Numeric.Natural"+ >Natural</a > <span class="keyword" >where ...</span ></li@@ -77,14 +77,14 @@ ><p class="src" ><span class="keyword" >type family</span- > (a :: <a href="#" title="GHC.TypeLits"- >Nat</a+ > (a :: <a href="#" title="Numeric.Natural"+ >Natural</a >) <a id="t:-43-" class="def" >+</a- > (b :: <a href="#" title="GHC.TypeLits"- >Nat</a- >) :: <a href="#" title="GHC.TypeLits"- >Nat</a+ > (b :: <a href="#" title="Numeric.Natural"+ >Natural</a+ >) :: <a href="#" title="Numeric.Natural"+ >Natural</a > <span class="keyword" >where ...</span > <span class="fixity"
html-test/ref/IgnoreExports.html view
@@ -58,8 +58,6 @@ >data</span > <a href="#" >Foo</a- > = <a href="#"- >Bar</a ></li ><li class="src short" ><a href="#"@@ -67,12 +65,6 @@ > :: <a href="#" title="Data.Int" >Int</a ></li- ><li class="src short"- ><a href="#"- >bar</a- > :: <a href="#" title="Data.Int"- >Int</a- ></li ></ul ></details ></div@@ -92,22 +84,6 @@ ><p >documentation for Foo</p ></div- ><div class="subs constructors"- ><p class="caption"- >Constructors</p- ><table- ><tr- ><td class="src"- ><a id="v:Bar" class="def"- >Bar</a- ></td- ><td class="doc"- ><p- >Documentation for Bar</p- ></td- ></tr- ></table- ></div ></div ><div class="top" ><p class="src"@@ -121,20 +97,6 @@ ><div class="doc" ><p >documentation for foo</p- ></div- ></div- ><div class="top"- ><p class="src"- ><a id="v:bar" class="def"- >bar</a- > :: <a href="#" title="Data.Int"- >Int</a- > <a href="#" class="selflink"- >#</a- ></p- ><div class="doc"- ><p- >documentation for bar</p ></div ></div ></div
html-test/ref/TypeFamilies.html view
@@ -228,37 +228,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:-62--60-:1"- ></span- > '<a href="#" title="TypeFamilies"- >XX</a- > <a href="#" title="TypeFamilies"- >><</a- > '<a href="#" title="TypeFamilies"- >XXX</a- ></span- > <a href="#" class="selflink"- >#</a- ></td- ><td class="doc empty"- > </td- ></tr- ><tr- ><td colspan="2"- ><details id="i:id:X:-62--60-:1"- ><summary class="hide-when-js-enabled"- >Instance details</summary- ><p- >Defined in <a href="#"- >TypeFamilies</a- ></p- ></details- ></td- ></tr- ><tr- ><td class="src clearfix"- ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Assoc:2"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Assoc:1" ></span > <a href="#" title="TypeFamilies" >Assoc</a@@ -275,7 +245,7 @@ ></tr ><tr ><td colspan="2"- ><details id="i:id:X:Assoc:2"+ ><details id="i:id:X:Assoc:1" ><summary class="hide-when-js-enabled" >Instance details</summary ><p@@ -312,7 +282,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Test:3"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Test:2" ></span > <a href="#" title="TypeFamilies" >Test</a@@ -329,7 +299,7 @@ ></tr ><tr ><td colspan="2"- ><details id="i:id:X:Test:3"+ ><details id="i:id:X:Test:2" ><summary class="hide-when-js-enabled" >Instance details</summary ><p@@ -342,68 +312,56 @@ ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Foo:4"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:-62--60-:3" ></span- > <span class="keyword"- >type</span- > <a href="#" title="TypeFamilies2"- >Foo</a+ > '<a href="#" title="TypeFamilies"+ >XX</a > <a href="#" title="TypeFamilies"- >X</a+ >><</a+ > '<a href="#" title="TypeFamilies"+ >XXX</a ></span > <a href="#" class="selflink" >#</a ></td- ><td class="doc"- ><p- >External instance</p- ></td+ ><td class="doc empty"+ > </td ></tr ><tr ><td colspan="2"- ><details id="i:id:X:Foo:4"+ ><details id="i:id:X:-62--60-:3" ><summary class="hide-when-js-enabled" >Instance details</summary ><p >Defined in <a href="#" >TypeFamilies</a ></p- > <div class="src"- ><span class="keyword"- >type</span- > <a href="#" title="TypeFamilies2"- >Foo</a- > <a href="#" title="TypeFamilies"- >X</a- > = <a href="#" title="TypeFamilies"- >Y</a- ></div ></details ></td ></tr ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:-60--62-:5"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Foo:4" ></span > <span class="keyword" >type</span- > '<a href="#" title="TypeFamilies"- >XXX</a+ > <a href="#" title="TypeFamilies2"+ >Foo</a > <a href="#" title="TypeFamilies"- ><></a- > '<a href="#" title="TypeFamilies"- >XX</a+ >X</a ></span > <a href="#" class="selflink" >#</a ></td- ><td class="doc empty"- > </td+ ><td class="doc"+ ><p+ >External instance</p+ ></td ></tr ><tr ><td colspan="2"- ><details id="i:id:X:-60--62-:5"+ ><details id="i:id:X:Foo:4" ><summary class="hide-when-js-enabled" >Instance details</summary ><p@@ -413,14 +371,12 @@ > <div class="src" ><span class="keyword" >type</span- > '<a href="#" title="TypeFamilies"- >XXX</a+ > <a href="#" title="TypeFamilies2"+ >Foo</a > <a href="#" title="TypeFamilies"- ><></a- > '<a href="#" title="TypeFamilies"- >XX</a- > = '<a href="#" title="TypeFamilies" >X</a+ > = <a href="#" title="TypeFamilies"+ >Y</a ></div ></details ></td@@ -428,7 +384,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:AssocD:6"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:AssocD:5" ></span > <span class="keyword" >data</span@@ -445,7 +401,7 @@ ></tr ><tr ><td colspan="2"- ><details id="i:id:X:AssocD:6"+ ><details id="i:id:X:AssocD:5" ><summary class="hide-when-js-enabled" >Instance details</summary ><p@@ -468,7 +424,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:AssocT:7"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:AssocT:6" ></span > <span class="keyword" >type</span@@ -485,7 +441,7 @@ ></tr ><tr ><td colspan="2"- ><details id="i:id:X:AssocT:7"+ ><details id="i:id:X:AssocT:6" ><summary class="hide-when-js-enabled" >Instance details</summary ><p@@ -512,7 +468,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Bat:8"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Bat:7" ></span > <span class="keyword" >data</span@@ -531,7 +487,7 @@ ></tr ><tr ><td colspan="2"- ><details id="i:id:X:Bat:8"+ ><details id="i:id:X:Bat:7" ><summary class="hide-when-js-enabled" >Instance details</summary ><p@@ -578,7 +534,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left"- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Foo:9"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Foo:8" ></span > <span class="keyword" >type</span@@ -597,7 +553,7 @@ ></tr ><tr ><td colspan="2"- ><details id="i:id:X:Foo:9"+ ><details id="i:id:X:Foo:8" ><summary class="hide-when-js-enabled" >Instance details</summary ><p@@ -613,6 +569,50 @@ >X</a > = <a href="#" title="TypeFamilies" >Y</a+ ></div+ ></details+ ></td+ ></tr+ ><tr+ ><td class="src clearfix"+ ><span class="inst-left"+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:-60--62-:9"+ ></span+ > <span class="keyword"+ >type</span+ > '<a href="#" title="TypeFamilies"+ >XXX</a+ > <a href="#" title="TypeFamilies"+ ><></a+ > '<a href="#" title="TypeFamilies"+ >XX</a+ ></span+ > <a href="#" class="selflink"+ >#</a+ ></td+ ><td class="doc empty"+ > </td+ ></tr+ ><tr+ ><td colspan="2"+ ><details id="i:id:X:-60--62-:9"+ ><summary class="hide-when-js-enabled"+ >Instance details</summary+ ><p+ >Defined in <a href="#"+ >TypeFamilies</a+ ></p+ > <div class="src"+ ><span class="keyword"+ >type</span+ > '<a href="#" title="TypeFamilies"+ >XXX</a+ > <a href="#" title="TypeFamilies"+ ><></a+ > '<a href="#" title="TypeFamilies"+ >XX</a+ > = '<a href="#" title="TypeFamilies"+ >X</a ></div ></details ></td
− html-test/src/Bug1206.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE Haskell2010 #-}-{- | Bug 1206--}--{-# language FlexibleInstances #-}--module Bug1206 where---- | A simple identity type-data T a = T a- deriving Show---- | '<>' = 'T (a + b)'------ Docs for the @Semigroup@ instance of @(T Int)@------ ==== __Examples__------ >>> T 2 <> T (3 :: Int)--- T 5-instance {-# overlapping #-} Semigroup (T Int) where- (<>) (T a) (T b) = T (a + b)---- | '<>' = 'T (a <> b)'------ Docs for the @Semigroup@ instance of @Semigroup a => T a@------ ==== __Examples__------ >>> T (Product 1) <> T (Product 2)--- T (Product {getProduct = 2})-instance {-# overlapping #-} Semigroup a => Semigroup (T a) where- (<>) (T a) (T b) = T (a <> b)---- | 'mempty' = 'T mempty'------ Docs for the @Monoid@ instance of @Monoid a => T a@------ ==== __Examples__------ >>> mempty :: T String--- T ""-instance Monoid a => Monoid (T a) where- mempty = T mempty
hypsrc-test/ref/src/Classes.html view
@@ -287,12 +287,12 @@ </span ><span id="line-13" ></span- ><span id="" ><span class="hs-keyword"- >instance</span- ><span- > </span- ><span class="annot"+ >instance</span+ ><span+ > </span+ ><span id=""+ ><span class="annot" ><a href="Classes.html#Foo" ><span class="hs-identifier hs-type" >Foo</span@@ -310,93 +310,93 @@ ></span ><span class="hs-special" >]</span- ><span- > </span- ><span class="hs-keyword"- >where</span- ><span- >-</span- ><span id="line-14" ></span- ><span- > </span- ><span id=""- ><span class="annot"- ><span class="annottext"- >bar :: [a] -> Int+ ><span+ > </span+ ><span class="hs-keyword"+ >where</span+ ><span+ > </span- ><a href="#"- ><span class="hs-identifier hs-var hs-var hs-var hs-var"- >bar</span- ></a- ></span- ></span- ><span- > </span- ><span class="hs-glyph"- >=</span- ><span- > </span- ><span class="annot"+ ><span id="line-14"+ ></span+ ><span+ > </span+ ><span id=""+ ><span class="annot" ><span class="annottext"- >[a] -> Int-forall (t :: * -> *) a. Foldable t => t a -> Int+ >bar :: [a] -> Int </span- ><span class="hs-identifier hs-var"- >length</span+ ><a href="#"+ ><span class="hs-identifier hs-var hs-var hs-var hs-var"+ >bar</span+ ></a ></span- ><span- >+ ></span+ ><span+ > </span+ ><span class="hs-glyph"+ >=</span+ ><span+ > </span+ ><span class="annot"+ ><span class="annottext"+ >[a] -> Int+forall (t :: * -> *) a. Foldable t => t a -> Int </span- ><span id="line-15"+ ><span class="hs-identifier hs-var"+ >length</span ></span- ><span- > </span- ><span id=""- ><span class="annot"- ><span class="annottext"- >baz :: Int -> ([a], [a])+ ><span+ > </span- ><a href="#"- ><span class="hs-identifier hs-var hs-var hs-var hs-var"- >baz</span- ></a- ></span- ></span- ><span- > </span- ><span class="annot"+ ><span id="line-15"+ ></span+ ><span+ > </span+ ><span id=""+ ><span class="annot" ><span class="annottext"- >Int+ >baz :: Int -> ([a], [a]) </span- ><span class="hs-identifier"- >_</span+ ><a href="#"+ ><span class="hs-identifier hs-var hs-var hs-var hs-var"+ >baz</span+ ></a ></span- ><span- > </span- ><span class="hs-glyph"- >=</span- ><span- > </span- ><span class="hs-special"- >(</span- ><span class="hs-special"- >[</span- ><span class="hs-special"- >]</span- ><span class="hs-special"- >,</span- ><span- > </span- ><span class="hs-special"- >[</span- ><span class="hs-special"- >]</span- ><span class="hs-special"- >)</span ></span ><span+ > </span+ ><span class="annot"+ ><span class="annottext"+ >Int+</span+ ><span class="hs-identifier"+ >_</span+ ></span+ ><span+ > </span+ ><span class="hs-glyph"+ >=</span+ ><span+ > </span+ ><span class="hs-special"+ >(</span+ ><span class="hs-special"+ >[</span+ ><span class="hs-special"+ >]</span+ ><span class="hs-special"+ >,</span+ ><span+ > </span+ ><span class="hs-special"+ >[</span+ ><span class="hs-special"+ >]</span+ ><span class="hs-special"+ >)</span+ ><span > </span ><span id="line-16"@@ -828,12 +828,12 @@ </span ><span id="line-28" ></span- ><span id="" ><span class="hs-keyword"- >instance</span- ><span- > </span- ><span id=""+ >instance</span+ ><span+ > </span+ ><span id=""+ ><span id="" ><span class="annot" ><a href="Classes.html#Foo%27" ><span class="hs-identifier hs-type"@@ -853,52 +853,52 @@ ><span class="hs-special" >]</span ></span- ><span- > </span- ><span class="hs-keyword"- >where</span- ><span- >-</span- ><span id="line-29" ></span- ><span- > </span- ><span id=""- ><span class="annot"- ><span class="annottext"- >quux :: ([a], [a]) -> [a]+ ><span+ > </span+ ><span class="hs-keyword"+ >where</span+ ><span+ > </span- ><a href="#"- ><span class="hs-identifier hs-var hs-var hs-var hs-var"- >quux</span- ></a- ></span- ></span- ><span- > </span- ><span class="hs-glyph"- >=</span- ><span- > </span- ><span class="annot"+ ><span id="line-29"+ ></span+ ><span+ > </span+ ><span id=""+ ><span class="annot" ><span class="annottext"- >([a] -> [a] -> [a]) -> ([a], [a]) -> [a]-forall a b c. (a -> b -> c) -> (a, b) -> c+ >quux :: ([a], [a]) -> [a] </span- ><span class="hs-identifier hs-var"- >uncurry</span+ ><a href="#"+ ><span class="hs-identifier hs-var hs-var hs-var hs-var"+ >quux</span+ ></a ></span- ><span- > </span- ><span class="annot"- ><span class="annottext"- >[a] -> [a] -> [a]+ ></span+ ><span+ > </span+ ><span class="hs-glyph"+ >=</span+ ><span+ > </span+ ><span class="annot"+ ><span class="annottext"+ >([a] -> [a] -> [a]) -> ([a], [a]) -> [a]+forall a b c. (a -> b -> c) -> (a, b) -> c+</span+ ><span class="hs-identifier hs-var"+ >uncurry</span+ ></span+ ><span+ > </span+ ><span class="annot"+ ><span class="annottext"+ >[a] -> [a] -> [a] forall a. [a] -> [a] -> [a] </span- ><span class="hs-operator hs-var"- >(++)</span- ></span+ ><span class="hs-operator hs-var"+ >(++)</span ></span ><span >@@ -948,23 +948,23 @@ ></span ><span > </span+ ><span id="plugh"+ ><span class="annot"+ ><a href="Classes.html#plugh"+ ><span class="hs-identifier hs-type"+ >plugh</span+ ></a+ ></span+ ></span+ ><span+ > </span+ ><span class="hs-glyph"+ >::</span+ ><span+ > </span ><span id="" ><span id=""- ><span id="plugh"- ><span class="annot"- ><a href="Classes.html#plugh"- ><span class="hs-identifier hs-type"- >plugh</span- ></a- ></span- ></span- ><span- > </span- ><span class="hs-glyph"- >::</span- ><span- > </span- ><span class="annot"+ ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" >p</span
hypsrc-test/ref/src/Quasiquoter.html view
@@ -126,14 +126,7 @@ ><span > </span ><span class="annot"- ><span class="annottext"- >QuasiQuoter :: (String -> Q Exp)--> (String -> Q Pat)--> (String -> Q Type)--> (String -> Q [Dec])--> QuasiQuoter-</span- ><span class="hs-identifier hs-type"+ ><span class="hs-identifier hs-type" >QuasiQuoter</span ></span ><span
hypsrc-test/ref/src/Records.html view
@@ -267,10 +267,7 @@ ><span > </span ><span class="annot"- ><span class="annottext"- >Point :: Int -> Int -> Point-</span- ><a href="Records.html#Point"+ ><a href="Records.html#Point" ><span class="hs-identifier hs-type" >Point</span ></a@@ -884,7 +881,7 @@ >Point -> Int </span ><a href="Records.html#x"- ><span class="hs-identifier hs-var hs-var"+ ><span class="hs-identifier hs-var" >x</span ></a ></span@@ -1007,7 +1004,7 @@ >Point -> Int </span ><a href="Records.html#y"- ><span class="hs-identifier hs-var hs-var"+ ><span class="hs-identifier hs-var" >y</span ></a ></span
latex-test/ref/ConstructorArgs/ConstructorArgs.tex view
@@ -3,8 +3,8 @@ \haddockbeginheader {\haddockverb\begin{verbatim} module ConstructorArgs (- Foo((:|), Rec, Baz, Boa, (:*), x, y), Boo(Foo, Foa, Fo, Fo'),- pattern Bo, pattern Bo'+ Foo((:|), Rec, Baz, Boa, (:*), x, y), Boo(Foo, Foa, Fo, Fo'), pattern Bo,+ pattern Bo' ) where\end{verbatim}} \haddockendheader