diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,36 @@ +## Changes in 2.23.0 + + * "Linuwial" is the new default theme (#721, #782, #949) + + * Fix style switcher (enabled by `--built-in-themes`) (#949) + + * Support inline markup in markdown-style links (#875) + + * The hyperlinker backend has been re-engineered to use HIE files + and display type annotations on expressions (#977) + + * The hyperlinker backend lexer is now more incremental, faster, and + more memory efficient (#977) + + * Add an "Instances" menu item to the HTML backend for controlling + settings related to expanding/collapsing instances (#1007) + + * Improved identifier links including value/type namespaces, and + hyperlinking of parenthesized/backticked identifiers + + * Substantial bugfixes for converting `TyThing` back into source + declarations (#1003, #1005, #1022, #1020) + + * `--show-interface` now outputs to stdout (instead of stderr) + + * Render associated type defaults and also improve rendering of + default method signatures + + * Many fixes to the LaTeX backend, mostly focused on not crashing + as well as generating LaTeX source that compiles + + * More flexible parsing of the module header + ## Changes in version 2.22.0 * Make `--package-version` optional for `--hoogle` (#899) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Haddock, a Haskell Documentation Tool [![Build Status](https://travis-ci.org/haskell/haddock.svg?branch=ghc-8.6)](https://travis-ci.org/haskell/haddock) +# Haddock, a Haskell Documentation Tool [![Build Status](https://travis-ci.org/haskell/haddock.svg?branch=ghc-head)](https://travis-ci.org/haskell/haddock) ## About haddock @@ -57,9 +57,9 @@ #### Using [`cabal new-build`](http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html) ```bash -cabal new-build -w ghc-8.6.1 +cabal new-build -w ghc-head # build & run the test suite -cabal new-test -w ghc-8.6.1 all +cabal new-test -w ghc-head all ``` #### Using Cabal sandboxes @@ -82,9 +82,9 @@ ```bash stack init -stack install +stack build # run the test suite -export HADDOCK_PATH="$HOME/.local/bin/haddock" +export HADDOCK_PATH="$(stack exec which haddock)" stack test ``` diff --git a/doc/invoking.rst b/doc/invoking.rst --- a/doc/invoking.rst +++ b/doc/invoking.rst @@ -27,8 +27,8 @@ message, please report it. You must also specify an option for the output format. Currently only -the :option:`--html` option for HTML and the :option:`--hoogle` option for -outputting Hoogle data are functional. +the :option:`--html` option for HTML, the :option:`--hoogle` option for +outputting Hoogle data, and the :option:`--latex` option are functional. The packaging tool `Cabal `__ @@ -124,6 +124,12 @@ Some JavaScript utilities used to implement some of the dynamic features like collapsible sections. +.. option:: --mathjax + + Specify a custom URL for a mathjax-compatible JS script. By default, + this is set to `MathJax + `_. + .. option:: --latex Generate documentation in LaTeX format. Several files will be @@ -159,7 +165,36 @@ Generate an index file for the `Hoogle `_ search engine. + One text file will be generated into the current directory (or the + specified directory if the :option:`-o` is given). Note that + the :option:`--package-name` is required. + Since the output is intended to be parsed by Hoogle, some conventions + need to be upheld: + + * Every entity should span exactly one line. :: + + newtype ReaderT r (m :: * -> *) a :: * -> (* -> *) -> * -> * + + The one exception to this rule is classes. The body of a class + is split up with one class member per line, an opening brace on + the line of the header, and a closing brace on a new line after + the class. :: + + class Foo a where { + foo :: a -> a -> Baz a; + type family Baz a; + type Baz a = [(a, a)]; + } + + * Entites that are exported only indirectly (for instance data + constructors visible via a ``ReaderT(..)`` export) have their names + wrapped in square brackets. :: + + [ReaderT] :: (r -> m a) -> ReaderT r m a + [runReaderT] :: ReaderT r m a -> r -> m a + + .. option:: --hyperlinked-source Generate hyperlinked source code (as HTML web page). All rendered @@ -295,7 +330,7 @@ reader can switch between themes with browsers that support alternate style sheets, or with the "Style" menu that gets added when the page is loaded. If no themes are specified, then just the - default built-in theme ("Ocean") is used. + default built-in theme ("Linuwial") is used. The path parameter can be one of: @@ -307,11 +342,11 @@ - A *CSS file*: The base name of the file becomes the name of the theme. - - The *name* of a built-in theme ("Ocean" or "Classic"). + - The *name* of a built-in theme ("Linuwial", "Ocean", or "Classic"). .. option:: --built-in-themes - Includes the built-in themes ("Ocean" and "Classic"). Can be + Includes the built-in themes ("Linuwial", "Ocean", and "Classic"). Can be combined with :option:`--theme`. Note that order matters: The first specified theme will be the default. @@ -341,6 +376,14 @@ The title should be a plain string (no markup please!). +.. option:: --package-name= + + Specify the name of the package being documented. + +.. option:: --package-version= + + Specify the version of the package being documented. + .. option:: -q --qual= @@ -368,6 +411,19 @@ - relative: x, B.y, C.z +.. option:: --since-qual= + + Specify how ``@since`` annotations are qualified. + + mode should be one of + + - ``always`` (default): always qualify ``@since`` annotations with + a package name and version + + - ``only-external``: only qualify ``@since`` annotations with a + package name and version when they do not come from the current + package + .. option:: -? --help @@ -378,6 +434,21 @@ Output version information and exit. +.. option:: --ghc-version + + Output the version of GHC which Haddock expects to find at :option:-B + and exit. + +.. option:: --print-ghc-path + + Output the path to the GHC (which Haddock computes based on :option:-B) + and exit. + +.. option:: --print-ghc-libdir + + Output the path to the GHC ``lib`` directory (which Haddock computes + based on :option:-B) and exit. + .. option:: -v --verbose @@ -415,6 +486,16 @@ Causes Haddock to behave as if module module has the ``hide`` attribute. (:ref:`module-attrs`). +.. option:: --show + + Causes Haddock to behave as if module module does not have the ``hide`` + attribute. (:ref:`module-attrs`). + +.. option:: --show-all + + Causes Haddock to behave as if no modules have the ``hide`` attribute. + (:ref:`module-attrs`). + .. option:: --show-extensions Causes Haddock to behave as if module module has the @@ -430,10 +511,21 @@ Turn off all warnings. +.. option:: --interface-version + + Prints out the version of the binary Haddock interface files that + this version of Haddock generates. + .. option:: --compatible-interface-versions Prints out space-separated versions of binary Haddock interface - files that this version is compatible with. + files that this version of Haddock is compatible with. + +.. option:: --bypass-interface-version-check + + **DANGEROUS** Causes Haddock to ignore the interface versions of + binary Haddock interface files. This can make Haddock crash during + deserialization of interface files. .. option:: --no-tmp-comp-dir diff --git a/doc/markup.rst b/doc/markup.rst --- a/doc/markup.rst +++ b/doc/markup.rst @@ -8,6 +8,8 @@ type declarations, and class declarations exported by each of the modules being processed. +.. _top-level-declaration + Documenting a Top-Level Declaration ----------------------------------- @@ -47,6 +49,8 @@ - A ``class`` declaration, +- An ``instance`` declaration, + - A ``data family`` or ``type family`` declaration, or - A ``data instance`` or ``type instance`` declaration. @@ -106,6 +110,8 @@ -- | This is the documentation for the 'g' method g :: Int -> a +Associated type and data families can also be annotated in this way. + Constructors and Record Fields ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -166,6 +172,32 @@ reason for this seemingly weird behaviour is the fact that ``someField`` is actually the same (partial) function. +Deriving clauses +~~~~~~~~~~~~~~~~ + +Most instances are top-level, so can be documented as in +:ref:`top-level-declaration`. The exception to this is instance that are +come from a ``deriving`` clause on a datatype declaration. These can +the documented like this: :: + + data D a = L a | M + deriving ( Eq -- ^ @since 4.5 + , Ord -- ^ default 'Ord' instance + ) + +This also scales to the various GHC extensions for deriving: :: + + newtype T a = T a + deriving Show -- ^ derivation of 'Show' + deriving stock ( Eq -- ^ stock derivation of 'Eq' + , Foldable -- ^ stock derivation of 'Foldable' + ) + deriving newtype Ord -- ^ newtype derivation of 'Ord' + deriving anyclass Read -- ^ unsafe derivation of 'Read' + deriving ( Eq1 -- ^ deriving 'Eq1' via 'Identity' + , Ord1 -- ^ deriving 'Ord1' via 'Identity' + ) via Identity + Function Arguments ~~~~~~~~~~~~~~~~~~ @@ -175,8 +207,8 @@ -> Float -- ^ The 'Float' argument -> IO () -- ^ The return value -Pattern synonyms and GADT-style data constructors also support this -style of documentation. +Pattern synonyms, GADT-style data constructors, and class methods also +support this style of documentation. .. _module-description: @@ -881,6 +913,16 @@ link pointing to the entity ``T`` exported from module ``M`` (without checking to see whether either ``M`` or ``M.T`` exist). +Since values and types live in different namespaces in Haskell, it is +possible for a reference such as ``'X'`` to be ambiguous. In such a case, +Haddock defaults to pointing to the type. The ambiguity can be overcome by explicitly specifying a namespace, by way of a ``v`` (for value) or ``t`` +(for type) immediately before the link: :: + + -- | An implicit reference to 'X', the type constructor + -- An explicit reference to v'X', the data constructor + -- An explicit reference to t'X', the type constructor + data X = X + To make life easier for documentation writers, a quoted identifier is only interpreted as such if the quotes surround a lexically valid Haskell identifier. This means, for example, that it normally isn't @@ -890,8 +932,9 @@ Nothing special is needed to hyperlink identifiers which contain apostrophes themselves: to hyperlink ``foo'`` one would simply type -``'foo''``. To hyperlink identifiers written in infix form, simply put -them in quotes as always: ``'`elem`'``. +``'foo''``. Hyperlinking operators works in exactly the same way. :: + + -- | A prefix operator @'(++)'@ and an infix identifier @'`elem`'@. Emphasis, Bold and Monospaced Text ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -39,8 +39,10 @@ import Haddock.InterfaceFile import Haddock.Options import Haddock.Utils +import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) import Control.Monad hiding (forM_) +import Data.Bifunctor (second) import Data.Foldable (forM_, foldl') import Data.Traversable (for) import Data.List (isPrefixOf) @@ -66,6 +68,8 @@ import Paths_haddock_api (getDataDir) import System.Directory (doesDirectoryExist) #endif +import System.Directory (getTemporaryDirectory) +import System.FilePath (()) import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity) @@ -76,7 +80,7 @@ import Panic (handleGhcException) import Module import FastString -import qualified DynamicLoading +import Outputable (defaultUserStyle) -------------------------------------------------------------------------------- -- * Exception handling @@ -161,18 +165,32 @@ Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags _ -> return flags + -- bypass the interface version check + let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags + + -- Create a temporary directory and redirect GHC output there (unless user + -- requested otherwise). + -- + -- Output dir needs to be set before calling 'depanal' since 'depanal' uses it + -- to compute output file names that are stored in the 'DynFlags' of the + -- resulting 'ModSummary's. + let withDir | Flag_NoTmpCompDir `elem` flags = id + | otherwise = withTempOutputDir + unless (Flag_NoWarnings `elem` flags) $ do hypSrcWarnings flags forM_ (warnings args) $ \warning -> do hPutStrLn stderr warning + when noChecks $ + hPutStrLn stderr noCheckWarning - ghc flags' $ do + ghc flags' $ withDir $ do dflags <- getDynFlags forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do - mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] + mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks forM_ mIfaceFile $ \(_, ifaceFile) -> do - putMsg dflags (renderJson (jsonInterfaceFile ifaceFile)) + logOutput dflags (defaultUserStyle dflags) (renderJson (jsonInterfaceFile ifaceFile)) if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files @@ -192,17 +210,30 @@ throwE "No input file(s)." -- Get packages supplied with --read-interface. - packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) + 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 [] +-- | Run the GHC action using a temporary output directory +withTempOutputDir :: Ghc a -> Ghc a +withTempOutputDir action = do + tmp <- liftIO getTemporaryDirectory + x <- liftIO getProcessID + let dir = tmp ".haddock-" ++ show x + modifySessionDynFlags (setOutputDir dir) + withTempDir dir action + -- | Create warnings about potential misuse of -optghc warnings :: [String] -> [String] warnings = map format . filter (isPrefixOf "-optghc") where format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"] +-- | Create a warning about bypassing the interface version check +noCheckWarning :: String +noCheckWarning = "Warning: `--bypass-interface-version-check' can cause " ++ + "Haddock to crash when reading Haddock interface files." withGhc :: [Flag] -> Ghc a -> IO a withGhc flags action = do @@ -212,15 +243,17 @@ let handleSrcErrors action' = flip handleSourceError action' $ \err -> do printException err liftIO exitFailure + needHieFiles = Flag_HyperlinkedSource `elem` flags - withGhc' libDir (ghcFlags flags) (\_ -> handleSrcErrors action) + withGhc' libDir needHieFiles (ghcFlags flags) (\_ -> handleSrcErrors action) readPackagesAndProcessModules :: [Flag] -> [String] -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do -- Get packages supplied with --read-interface. - packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) + 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 snd packages @@ -268,9 +301,9 @@ allIfaces = map toInstalledIface ifaces ++ installedIfaces allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] - pkgMod = ifaceMod (head ifaces) - pkgKey = moduleUnitId pkgMod - pkgStr = Just (unitIdString pkgKey) + pkgMod = fmap ifaceMod (listToMaybe ifaces) + pkgKey = fmap moduleUnitId pkgMod + pkgStr = fmap unitIdString pkgKey pkgNameVer = modulePackageInfo dflags flags pkgMod pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer) sincePkg = case sinceQual of @@ -289,16 +322,22 @@ pkgSrcMap = Map.mapKeys moduleUnitId extSrcMap pkgSrcMap' - | Flag_HyperlinkedSource `elem` flags = - Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap - | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl pkgSrcMap + | Flag_HyperlinkedSource `elem` flags + , Just k <- pkgKey + = Map.insert k hypSrcModuleNameUrlFormat pkgSrcMap + | Just srcNameUrl <- srcEntity + , Just k <- pkgKey + = Map.insert k srcNameUrl pkgSrcMap | otherwise = pkgSrcMap -- TODO: Get these from the interface files as with srcMap pkgSrcLMap' - | Flag_HyperlinkedSource `elem` flags = - Map.singleton pkgKey hypSrcModuleLineUrlFormat - | Just path <- srcLEntity = Map.singleton pkgKey path + | Flag_HyperlinkedSource `elem` flags + , Just k <- pkgKey + = Map.singleton k hypSrcModuleLineUrlFormat + | Just path <- srcLEntity + , Just k <- pkgKey + = Map.singleton k path | otherwise = Map.empty sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') @@ -375,7 +414,8 @@ visibleIfaces odir _ -> putStrLn . unlines $ [ "haddock: Unable to find a package providing module " - ++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle." + ++ maybe "" (moduleNameString . moduleName) pkgMod + ++ ", skipping Hoogle." , "" , " Perhaps try specifying the desired package explicitly" ++ " using the --package-name" @@ -404,13 +444,14 @@ readInterfaceFiles :: MonadIO m => NameCacheAccessor m -> [(DocPaths, FilePath)] + -> Bool -> m [(DocPaths, InterfaceFile)] -readInterfaceFiles name_cache_accessor pairs = do +readInterfaceFiles name_cache_accessor pairs bypass_version_check = do catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs where -- try to read an interface, warn if we can't tryReadIface (paths, file) = - readInterfaceFile name_cache_accessor file >>= \case + readInterfaceFile name_cache_accessor file bypass_version_check >>= \case Left err -> liftIO $ do putStrLn ("Warning: Cannot read " ++ file ++ ":") putStrLn (" " ++ err) @@ -426,14 +467,10 @@ -- | Start a GHC session with the -haddock flag set. Also turn off -- compilation and linking. Then run the given 'Ghc' action. -withGhc' :: String -> [String] -> (DynFlags -> Ghc a) -> IO a -withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do - dynflags <- getSessionDynFlags - dynflags' <- parseGhcFlags (gopt_set dynflags Opt_Haddock) { - hscTarget = HscNothing, - ghcMode = CompManager, - ghcLink = NoLink - } +withGhc' :: String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a +withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do + dynflags' <- parseGhcFlags =<< getSessionDynFlags + -- We disable pattern match warnings because than can be very -- expensive to check let dynflags'' = unsetPatternMatchWarnings $ @@ -443,10 +480,7 @@ -- that may need to be re-linked: Haddock doesn't do any -- dynamic or static linking at all! _ <- setSessionDynFlags dynflags'' - hscenv <- GHC.getSession - dynflags''' <- liftIO (DynamicLoading.initializePlugins hscenv dynflags'') - _ <- setSessionDynFlags dynflags''' - ghcActs dynflags''' + ghcActs dynflags'' where -- ignore sublists of flags that start with "+RTS" and end in "-RTS" @@ -464,11 +498,19 @@ parseGhcFlags dynflags = do -- TODO: handle warnings? - let flags' = filterRtsFlags flags - (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags') + let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock] + | otherwise = [Opt_Haddock] + dynflags' = (foldl' gopt_set dynflags extra_opts) + { hscTarget = HscNothing + , ghcMode = CompManager + , ghcLink = NoLink + } + flags' = filterRtsFlags flags + + (dynflags'', rest, _) <- parseDynamicFlags dynflags' (map noLoc flags') if not (null rest) then throwE ("Couldn't parse GHC options: " ++ unwords flags') - else return dynflags' + else return dynflags'' unsetPatternMatchWarnings :: DynFlags -> DynFlags unsetPatternMatchWarnings dflags = @@ -618,7 +660,7 @@ h <- openFile filename ReadMode hSetEncoding h utf8 str <- hGetContents h -- semi-closes the handle - return . Just $! parseParas dflags Nothing str + return . Just $! second (fmap rdrName) $ parseParas dflags Nothing str _ -> throwE "multiple -p/--prologue options" diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -17,14 +17,14 @@ ppHoogle ) where -import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..)) +import BasicTypes ( OverlapFlag(..), OverlapMode(..), SourceText(..) + , PromotionFlag(..) ) import InstEnv (ClsInst(..)) import Documentation.Haddock.Markup import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) -import HsBinds (emptyLHsBinds) import GHC import Outputable import NameSet @@ -36,7 +36,6 @@ import System.Directory import System.FilePath -import System.IO prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock" @@ -56,10 +55,7 @@ | not (null (versionBranch version)) ] ++ concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i] createDirectoryIfMissing True odir - h <- openFile (odir filename) WriteMode - hSetEncoding h utf8 - hPutStr h (unlines contents) - hClose h + writeUtf8File (odir filename) (unlines contents) ppModule :: DynFlags -> Interface -> [String] ppModule dflags iface = @@ -80,6 +76,7 @@ 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 a b) = HsFunTy x (g a) (g b) f (HsListTy x a) = HsListTy x (g a) f (HsTupleTy x a b) = HsTupleTy x a (map g b) @@ -266,9 +263,15 @@ -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] + resType = let c = HsTyVar NoExt NotPromoted (noLoc (tcdName dat)) + as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) + in apps (map noLoc (c : as)) + tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn + tyVarBndr2Type (UserTyVar _ n) = HsTyVar NoExt NotPromoted n + tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted n)) k + tyVarBndr2Type (XTyVarBndr _) = panic "haddock:ppCtor" + ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f where @@ -332,7 +335,7 @@ markupString = str, markupAppend = (++), markupIdentifier = box (TagInline "a") . str . out dflags, - markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd, + markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd), markupModule = box (TagInline "a") . str, markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), @@ -345,7 +348,7 @@ markupOrderedList = box (TagL 'o'), markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), markupCodeBlock = box TagPre, - markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel), + markupHyperlink = \(Hyperlink url mLabel) -> box (TagInline "a") (fromMaybe (str url) mLabel), markupAName = const $ str "", markupProperty = box TagPre . str, markupExample = box TagPre . str . unlines . map exampleToString, diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Haddock.Backends.Hyperlinker ( ppHyperlinkedSource , module Haddock.Backends.Hyperlinker.Types @@ -6,17 +7,26 @@ import Haddock.Types +import Haddock.Utils (writeUtf8File) import Haddock.Backends.Hyperlinker.Renderer +import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils - -import Text.XHtml hiding (()) +import Haddock.Backends.Xhtml.Utils ( renderToString ) import Data.Maybe import System.Directory import System.FilePath +import HieTypes ( HieFile(..), HieASTs(..) ) +import HieBin ( readHieFile, hie_file_result) +import Data.Map as M +import FastString ( mkFastString ) +import Module ( Module, moduleName ) +import NameCache ( initNameCache ) +import UniqSupply ( mkSplitUniqSupply ) + -- | Generate hyperlinked source for given interfaces. -- -- Note that list of interfaces should also contain interfaces normally hidden @@ -26,10 +36,10 @@ -> FilePath -- ^ Resource directory -> Maybe FilePath -- ^ Custom CSS file path -> Bool -- ^ Flag indicating whether to pretty-print HTML - -> SrcMap -- ^ Paths to sources + -> M.Map Module SrcPath -- ^ Paths to sources -> [Interface] -- ^ Interfaces for which we create source -> IO () -ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do +ppHyperlinkedSource outdir libdir mstyle pretty srcs' ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile @@ -38,17 +48,39 @@ mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces where srcdir = outdir hypSrcDir + srcs = (srcs', M.mapKeys moduleName srcs') -- | Generate hyperlinked source for particular interface. -ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface - -> IO () -ppHyperlinkedModuleSource srcdir pretty srcs iface = - case ifaceTokenizedSrc iface of - Just tokens -> writeFile path . html . render' $ tokens - Nothing -> return () +ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMaps -> Interface -> IO () +ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of + Just hfp -> do + -- Parse the GHC-produced HIE file + u <- mkSplitUniqSupply 'a' + HieFile { hie_hs_file = file + , hie_asts = HieASTs asts + , hie_types = types + , hie_hs_src = rawSrc + } <- (hie_file_result . fst) + <$> (readHieFile (initNameCache u []) hfp) + + -- Get the AST and tokens corresponding to the source file we want + let mast | M.size asts == 1 = snd <$> M.lookupMin asts + | otherwise = M.lookup (mkFastString file) asts + tokens = parse df file rawSrc + + -- Produce and write out the hyperlinked sources + case mast of + Just ast -> + let fullAst = recoverFullIfaceTypes df types ast + in writeUtf8File path . renderToString pretty . render' fullAst $ tokens + Nothing + | M.size asts == 0 -> return () + | otherwise -> error $ unwords [ "couldn't find ast for" + , file, show (M.keys asts) ] + Nothing -> return () where + df = ifaceDynFlags iface render' = render (Just srcCssFile) (Just highlightScript) srcs - html = if pretty then renderHtml else showHtml path = srcdir hypSrcModuleFile (ifaceMod iface) -- | Name of CSS file in output directory. @@ -62,3 +94,4 @@ -- | Path to default CSS file. defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" + diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs deleted file mode 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} - -module Haddock.Backends.Hyperlinker.Ast (enrich) where - - -import qualified Haddock.Syb as Syb -import Haddock.Backends.Hyperlinker.Types - -import qualified GHC -import qualified SrcLoc -import qualified Outputable as GHC - -import Control.Applicative -import Control.Monad (guard) -import Data.Data -import qualified Data.Map.Strict as Map -import Data.Maybe - -import Prelude hiding (span) - -everythingInRenamedSource :: (Alternative f, Data x) - => (forall a. Data a => a -> f r) -> x -> f r -everythingInRenamedSource f = Syb.everythingButType @GHC.Name (<|>) f - --- | Add more detailed information to token stream using GHC API. -enrich :: GHC.RenamedSource -> [Token] -> [RichToken] -enrich src = - map $ \token -> RichToken - { rtkToken = token - , rtkDetails = enrichToken token detailsMap - } - where - detailsMap = - mkDetailsMap (concatMap ($ src) - [ variables - , types - , decls - , binds - , imports - ]) - -type LTokenDetails = [(GHC.SrcSpan, TokenDetails)] - --- | A map containing association between source locations and "details" of --- this location. --- -type DetailsMap = Map.Map Position (Span, TokenDetails) - -mkDetailsMap :: [(GHC.SrcSpan, TokenDetails)] -> DetailsMap -mkDetailsMap xs = - Map.fromListWith select_details [ (start, (span, token_details)) - | (ghc_span, token_details) <- xs - , GHC.RealSrcSpan span <- [ghc_span] - , let start = SrcLoc.realSrcSpanStart span - ] - where - -- favour token details which appear earlier in the list - select_details _new old = old - -lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails -lookupBySpan span details = do - let pos = SrcLoc.realSrcSpanStart span - (_, (tok_span, tok_details)) <- Map.lookupLE pos details - guard (tok_span `SrcLoc.containsSpan` span) - return tok_details - -enrichToken :: Token -> DetailsMap -> Maybe TokenDetails -enrichToken (Token typ _ spn) dm - | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm -enrichToken _ _ = Nothing - --- | Obtain details map for variables ("normally" used identifiers). -variables :: GHC.RenamedSource -> LTokenDetails -variables = - everythingInRenamedSource (var `Syb.combine` rec) - where - var term = case cast term of - (Just ((GHC.L sspan (GHC.HsVar _ name)) :: GHC.LHsExpr GHC.GhcRn)) -> - pure (sspan, RtkVar (GHC.unLoc name)) - (Just (GHC.L _ (GHC.RecordCon _ (GHC.L sspan name) _))) -> - pure (sspan, RtkVar name) - _ -> empty - rec term = case cast term of - Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.GhcRn) _) -> - pure (sspan, RtkVar name) - _ -> empty - --- | Obtain details map for types. -types :: GHC.RenamedSource -> LTokenDetails -types = everythingInRenamedSource ty - where - ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)] - ty term = case cast term of - (Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) -> - pure (sspan, RtkType (GHC.unLoc name)) - (Just ((GHC.L sspan (GHC.HsOpTy _ l name r)) :: GHC.LHsType GHC.GhcRn)) -> - (sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r) - _ -> empty - --- | Obtain details map for identifier bindings. --- --- That includes both identifiers bound by pattern matching or declared using --- ordinary assignment (in top-level declarations, let-expressions and where --- clauses). - -binds :: GHC.RenamedSource -> LTokenDetails -binds = everythingInRenamedSource - (fun `Syb.combine` pat `Syb.combine` tvar) - where - fun term = case cast term of - (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) -> - pure (sspan, RtkBind name) - (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) args _ _))) -> - pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args - _ -> empty - patsyn_binds term = case cast term of - (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name) - _ -> empty - pat term = case cast term of - (Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) -> - pure (sspan, RtkBind (GHC.unLoc name)) - (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> - [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs - (Just (GHC.L _ (GHC.AsPat _ (GHC.L sspan name) _))) -> - pure (sspan, RtkBind name) - _ -> empty - rec term = case cast term of - (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.GhcRn) _)) -> - pure (sspan, RtkVar name) - _ -> empty - tvar term = case cast term of - (Just ((GHC.L sspan (GHC.UserTyVar _ name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) -> - pure (sspan, RtkBind (GHC.unLoc name)) - (Just (GHC.L _ (GHC.KindedTyVar _ (GHC.L sspan name) _))) -> - pure (sspan, RtkBind name) - _ -> empty - --- | Obtain details map for top-level declarations. -decls :: GHC.RenamedSource -> LTokenDetails -decls (group, _, _, _) = concatMap ($ group) - [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds - , everythingInRenamedSource fun . GHC.hs_valds - , everythingInRenamedSource fix . GHC.hs_fixds - , everythingInRenamedSource (con `Syb.combine` ins) - ] - where - typ (GHC.L _ t) = case t of - GHC.DataDecl { tcdLName = name } -> pure . decl $ name - GHC.SynDecl _ name _ _ _ -> pure . decl $ name - GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam - GHC.ClassDecl{..} -> - [decl tcdLName] - ++ concatMap sig tcdSigs - ++ concatMap tyfam tcdATs - GHC.XTyClDecl {} -> GHC.panic "haddock:decls" - fun term = case cast term of - (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) - | GHC.isExternalName name -> pure (sspan, RtkDecl name) - (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) _ _ _))) - | GHC.isExternalName name -> pure (sspan, RtkDecl name) - _ -> empty - con term = case cast term of - (Just (cdcl :: GHC.ConDecl GHC.GhcRn)) -> - map decl (GHC.getConNames cdcl) - ++ everythingInRenamedSource fld cdcl - Nothing -> empty - ins term = case cast term of - (Just ((GHC.DataFamInstD _ (GHC.DataFamInstDecl eqn)) - :: GHC.InstDecl GHC.GhcRn)) - -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn - (Just (GHC.TyFamInstD _ (GHC.TyFamInstDecl eqn))) -> - pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn - _ -> empty - fld term = case cast term of - Just (field :: GHC.ConDeclField GHC.GhcRn) - -> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field - Nothing -> empty - fix term = case cast term of - Just ((GHC.FixitySig _ names _) :: GHC.FixitySig GHC.GhcRn) - -> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names - Just ((GHC.XFixitySig {}) :: GHC.FixitySig GHC.GhcRn) - -> GHC.panic "haddock:decls" - Nothing -> empty - tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName] - tyfam (GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels" - sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names - sig (GHC.L _ (GHC.PatSynSig _ names _)) = map decl names - sig (GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names - sig _ = [] - decl (GHC.L sspan name) = (sspan, RtkDecl name) - tyref (GHC.L sspan name) = (sspan, RtkType name) - --- | Obtain details map for import declarations. --- --- This map also includes type and variable details for items in export and --- import lists. -imports :: GHC.RenamedSource -> LTokenDetails -imports src@(_, imps, _, _) = - everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps - where - ie term = case cast term of - (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v - (Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t - (Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t - (Just (GHC.IEThingWith _ t _ vs _fls)) -> - [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs - (Just (GHC.IEModuleContents _ m)) -> pure $ modu m - _ -> empty - typ (GHC.L sspan name) = (sspan, RtkType name) - var (GHC.L sspan name) = (sspan, RtkVar name) - modu (GHC.L sspan name) = (sspan, RtkModule name) - imp idecl - | not . GHC.ideclImplicit $ idecl = Just (modu (GHC.ideclName idecl)) - | otherwise = Nothing diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,213 +1,169 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Haddock.Backends.Hyperlinker.Parser (parse) where -import Data.Either ( isRight, isLeft ) -import Data.List ( foldl', isPrefixOf, isSuffixOf ) -import Data.Maybe ( maybeToList ) -import Data.Char ( isSpace ) -import qualified Text.Read as R +import Control.Applicative ( Alternative(..) ) +import Data.List ( isPrefixOf, isSuffixOf ) -import GHC ( DynFlags, addSourceToTokens ) -import SrcLoc +import qualified Data.ByteString as BS + +import BasicTypes ( IntegralLit(..) ) +import DynFlags +import ErrUtils ( emptyMessages ) import FastString ( mkFastString ) -import StringBuffer ( stringToStringBuffer ) -import Lexer ( Token(..) ) -import qualified Lexer as L +import Lexer ( P(..), ParseResult(..), PState(..), Token(..) + , mkPStatePure, lexer, mkParserFlags' ) +import Outputable ( showSDoc, panic ) +import SrcLoc +import StringBuffer ( StringBuffer, atEnd ) import Haddock.Backends.Hyperlinker.Types as T - +import Haddock.GhcUtils -- | Turn source code string into a stream of more descriptive tokens. -- --- Result should retain original file layout (including comments, whitespace, --- etc.), i.e. the following "law" should hold: --- --- prop> concat . map tkValue . parse = id --- --- (In reality, this only holds for input not containing '\r', '\t', '\f', '\v', --- characters, since GHC transforms those into ' ' and '\n') -parse :: DynFlags -> FilePath -> String -> [T.Token] -parse dflags fp = ghcToks . processCPP dflags fp . filterCRLF +-- Result should retain original file layout (including comments, +-- whitespace, and CPP). +parse + :: DynFlags -- ^ Flags for this module + -> FilePath -- ^ Path to the source of this module + -> BS.ByteString -- ^ Raw UTF-8 encoded source of this module + -> [T.Token] +parse dflags fpath bs = case unP (go False []) initState of + POk _ toks -> reverse toks + PFailed _ ss errMsg -> panic $ "Hyperlinker parse error at " ++ show ss ++ + ": " ++ showSDoc dflags errMsg where - -- Remove CRLFs from source - filterCRLF :: String -> String - filterCRLF ('\r':'\n':cs) = '\n' : filterCRLF cs - filterCRLF (c:cs) = c : filterCRLF cs - filterCRLF [] = [] --- | Parse the source into tokens using the GHC lexer. --- --- * CPP lines are removed and reinserted as line-comments --- * top-level file pragmas are parsed as block comments (see the --- 'ITblockComment' case of 'classify' for more details) --- -processCPP :: DynFlags -- ^ GHC's flags - -> FilePath -- ^ source file name (for position information) - -> String -- ^ source file contents - -> [(Located L.Token, String)] -processCPP dflags fpath s = addSrc . go start . splitCPP $ s - where + initState = mkPStatePure pflags buf start + buf = stringBufferFromByteString bs start = mkRealSrcLoc (mkFastString fpath) 1 1 - addSrc = addSourceToTokens start (stringToStringBuffer s) - - -- Transform a list of Haskell/CPP lines into a list of tokens - go :: RealSrcLoc -> [Either String String] -> [Located L.Token] - go _ [] = [] - go pos ls = - let (hLinesRight, ls') = span isRight ls - (cppLinesLeft, rest) = span isLeft ls' - - hSrc = concat [ hLine | Right hLine <- hLinesRight ] - cppSrc = concat [ cppLine | Left cppLine <- cppLinesLeft ] + pflags = mkParserFlags' (warningFlags dflags) + (extensionFlags dflags) + (thisPackage dflags) + (safeImportsOn dflags) + False -- lex Haddocks as comment tokens + True -- produce comment tokens + False -- produce position pragmas tokens - in case L.lexTokenStream (stringToStringBuffer hSrc) pos dflags of + go :: Bool -- ^ are we currently in a pragma? + -> [T.Token] -- ^ tokens accumulated so far (in reverse) + -> P [T.Token] + go inPrag toks = do + (b, _) <- getInput + if not (atEnd b) + then do + (newToks, inPrag') <- parseCppLine <|> parsePlainTok inPrag <|> unknownLine + go inPrag' (newToks ++ toks) + else + pure toks - -- Stuff that fails to lex gets turned into comments - L.PFailed _ _ss _msg -> - let (src_pos, failed) = mkToken ITunknown pos hSrc - (new_pos, cpp) = mkToken ITlineComment src_pos cppSrc - in failed : cpp : go new_pos rest + -- | Like 'Lexer.lexer', but slower, with a better API, and filtering out empty tokens + wrappedLexer :: P (RealLocated Lexer.Token) + wrappedLexer = Lexer.lexer False andThen + where andThen (L (RealSrcSpan s) t) + | srcSpanStartLine s /= srcSpanEndLine s || + srcSpanStartCol s /= srcSpanEndCol s + = pure (L s t) + andThen (L (RealSrcSpan s) ITeof) = pure (L s ITeof) + andThen _ = wrappedLexer - -- Successfully lexed - L.POk ss toks -> - let (new_pos, cpp) = mkToken ITlineComment (L.loc ss) cppSrc - in toks ++ [cpp] ++ go new_pos rest + -- | Try to parse a CPP line (can fail) + parseCppLine :: P ([T.Token], Bool) + parseCppLine = do + (b, l) <- getInput + case tryCppLine l b of + Just (cppBStr, l', b') + -> let cppTok = T.Token { tkType = TkCpp + , tkValue = cppBStr + , tkSpan = mkRealSrcSpan l l' } + in setInput (b', l') *> pure ([cppTok], False) + _ -> empty - -- Manually make a token from a 'String', advancing the cursor position - mkToken tok start' str = - let end = foldl' advanceSrcLoc start' str - in (end, L (RealSrcSpan $ mkRealSrcSpan start' end) (tok str)) + -- | Try to parse a regular old token (can fail) + parsePlainTok :: Bool -> P ([T.Token], Bool) -- return list is only ever 0-2 elements + parsePlainTok inPrag = do + (bInit, lInit) <- getInput + L sp tok <- Lexer.lexer False return + (bEnd, _) <- getInput + case sp of + UnhelpfulSpan _ -> pure ([], False) -- pretend the token never existed + RealSrcSpan rsp -> do + let typ = if inPrag then TkPragma else classify tok + RealSrcLoc lStart = srcSpanStart sp -- safe since @sp@ is real + (spaceBStr, bStart) = spanPosition lInit lStart bInit + inPragDef = inPragma inPrag tok + (bEnd', inPrag') <- case tok of --- | Split apart the initial file into Haskell source lines ('Left' entries) and --- CPP lines ('Right' entries). --- --- All characters in the input are present in the output: --- --- prop> concat . map (either id id) . splitCPP = id -splitCPP :: String -> [Either String String] -splitCPP "" = [] -splitCPP s | isCPPline s = Left l : splitCPP rest - | otherwise = Right l : splitCPP rest - where - ~(l, rest) = spanToNewline 0 s + -- Update internal line + file position if this is a LINE pragma + ITline_prag _ -> tryOrElse (bEnd, inPragDef) $ do + L _ (ITinteger (IL { il_value = line })) <- wrappedLexer + L _ (ITstring _ file) <- wrappedLexer + L spF ITclose_prag <- wrappedLexer + let newLoc = mkRealSrcLoc file (fromIntegral line - 1) (srcSpanEndCol spF) + (bEnd'', _) <- getInput + setInput (bEnd'', newLoc) --- | Heuristic to decide if a line is going to be a CPP line. This should be a --- cheap operation since it is going to be run on every line being processed. --- --- Right now it just checks if the first non-whitespace character in the first --- five characters of the line is a '#': --- --- >>> isCPPline "#define FOO 1" --- True --- --- >>> isCPPline "\t\t #ifdef GHC" --- True --- --- >>> isCPPline " #endif" --- False --- -isCPPline :: String -> Bool -isCPPline = isPrefixOf "#" . dropWhile (`elem` " \t") . take 5 + pure (bEnd'', False) + -- Update internal column position if this is a COLUMN pragma + ITcolumn_prag _ -> tryOrElse (bEnd, inPragDef) $ do + L _ (ITinteger (IL { il_value = col })) <- wrappedLexer + L spF ITclose_prag <- wrappedLexer --- | Split a "line" off the front of a string, hopefully without cutting tokens --- in half. I say "hopefully" because knowing what a token is requires lexing, --- yet lexing depends on this function. --- --- All characters in the input are present in the output: --- --- prop> curry (++) . spanToNewLine 0 = id -spanToNewline :: Int -- ^ open '{-' - -> String -- ^ input - -> (String, String) + let newLoc = mkRealSrcLoc (srcSpanFile spF) (srcSpanEndLine spF) (fromIntegral col) + (bEnd'', _) <- getInput + setInput (bEnd'', newLoc) --- Base case and space characters -spanToNewline _ "" = ("", "") -spanToNewline n ('\n':str) | n <= 0 = ("\n", str) -spanToNewline n ('\n':str) | n <= 0 = ("\n", str) -spanToNewline n ('\\':'\n':str) = - let (str', rest) = spanToNewline n str - in ('\\':'\n':str', rest) + pure (bEnd'', False) --- Block comments -spanToNewline n ('{':'-':str) = - let (str', rest) = spanToNewline (n+1) str - in ('{':'-':str', rest) -spanToNewline n ('-':'}':str) = - let (str', rest) = spanToNewline (n-1) str - in ('-':'}':str', rest) + _ -> pure (bEnd, inPragDef) --- When not in a block comment, try to lex a Haskell token -spanToNewline 0 str@(c:_) | ((lexed, str') : _) <- R.lex str, not (isSpace c) = - if all (== '-') lexed && length lexed >= 2 - -- A Haskell line comment - then case span (/= '\n') str' of - (str'', '\n':rest) -> (lexed ++ str'' ++ "\n", rest) - (_, _) -> (str, "") + let tokBStr = splitStringBuffer bStart bEnd' + plainTok = T.Token { tkType = typ + , tkValue = tokBStr + , tkSpan = rsp } + spaceTok = T.Token { tkType = TkSpace + , tkValue = spaceBStr + , tkSpan = mkRealSrcSpan lInit lStart } - -- An actual Haskell token - else let (str'', rest) = spanToNewline 0 str' - in (lexed ++ str'', rest) + pure (plainTok : [ spaceTok | not (BS.null spaceBStr) ], inPrag') --- In all other cases, advance one character at a time -spanToNewline n (c:str) = - let (str', rest) = spanToNewline n str - in (c:str', rest) + -- | Parse whatever remains of the line as an unknown token (can't fail) + unknownLine :: P ([T.Token], Bool) + unknownLine = do + (b, l) <- getInput + let (unkBStr, l', b') = spanLine l b + unkTok = T.Token { tkType = TkUnknown + , tkValue = unkBStr + , tkSpan = mkRealSrcSpan l l' } + setInput (b', l') + pure ([unkTok], False) --- | Turn a list of GHC's 'L.Token' (and their source 'String') into a list of --- Haddock's 'T.Token'. -ghcToks :: [(Located L.Token, String)] -> [T.Token] -ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False) - where - start = mkRealSrcLoc (mkFastString "lexing") 1 1 - - go :: (RealSrcLoc, [T.Token], Bool) - -- ^ current position, tokens accumulated, currently in pragma (or not) - - -> (Located L.Token, String) - -- ^ next token, its content - - -> (RealSrcLoc, [T.Token], Bool) - -- ^ new position, new tokens accumulated, currently in pragma (or not) +-- | Get the input +getInput :: P (StringBuffer, RealSrcLoc) +getInput = P $ \p @ PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc) - go (pos, toks, in_prag) (L l tok, raw) = - ( next_pos - , classifiedTok ++ maybeToList white ++ toks - , inPragma in_prag tok - ) - where - (next_pos, white) = mkWhitespace pos l - - classifiedTok = [ Token (classify' tok) raw rss - | RealSrcSpan rss <- [l] - , not (null raw) - ] - - classify' | in_prag = const TkPragma - | otherwise = classify +-- | Set the input +setInput :: (StringBuffer, RealSrcLoc) -> P () +setInput (buf, srcLoc) = P $ \p -> POk (p { buffer = buf, loc = srcLoc }) () --- | Find the correct amount of whitespace between tokens. -mkWhitespace :: RealSrcLoc -> SrcSpan -> (RealSrcLoc, Maybe T.Token) -mkWhitespace prev spn = - case spn of - UnhelpfulSpan _ -> (prev,Nothing) - RealSrcSpan s | null wsstring -> (end, Nothing) - | otherwise -> (end, Just (Token TkSpace wsstring wsspan)) - where - start = realSrcSpanStart s - end = realSrcSpanEnd s - wsspan = mkRealSrcSpan prev start - nls = srcLocLine start - srcLocLine prev - spaces = if nls == 0 then srcLocCol start - srcLocCol prev - else srcLocCol start - 1 - wsstring = replicate nls '\n' ++ replicate spaces ' ' +-- | Orphan instance that adds backtracking to 'P' +instance Alternative P where + empty = P $ \_ -> PFailed (const emptyMessages) noSrcSpan "Alterative.empty" + P x <|> P y = P $ \s -> case x s of { p@POk{} -> p + ; _ -> y s } +-- | Try a parser. If it fails, backtrack and return the pure value. +tryOrElse :: a -> P a -> P a +tryOrElse x p = p <|> pure x -- | Classify given tokens as appropriate Haskell token type. -classify :: L.Token -> TokenType +classify :: Lexer.Token -> TokenType classify tok = case tok of ITas -> TkKeyword @@ -378,15 +334,11 @@ ITLarrowtail {} -> TkGlyph ITRarrowtail {} -> TkGlyph + ITcomment_line_prag -> TkUnknown ITunknown {} -> TkUnknown ITeof -> TkUnknown - -- Line comments are only supposed to start with '--'. Starting with '#' - -- means that this was probably a CPP. - ITlineComment s - | isCPPline s -> TkCpp - | otherwise -> TkComment - + ITlineComment {} -> TkComment ITdocCommentNext {} -> TkComment ITdocCommentPrev {} -> TkComment ITdocCommentNamed {} -> TkComment @@ -403,9 +355,9 @@ | otherwise -> TkComment -- | Classify given tokens as beginning pragmas (or not). -inPragma :: Bool -- ^ currently in pragma - -> L.Token -- ^ current token - -> Bool -- ^ new information about whether we are in a pragma +inPragma :: Bool -- ^ currently in pragma + -> Lexer.Token -- ^ current token + -> Bool -- ^ new information about whether we are in a pragma inPragma _ ITclose_prag = False inPragma True _ = True inPragma False tok = diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,4 +1,8 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} module Haddock.Backends.Hyperlinker.Renderer (render) where @@ -6,15 +10,19 @@ import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils -import qualified GHC -import qualified Name as GHC -import qualified Unique as GHC +import qualified Data.ByteString as BS +import HieTypes +import Module ( ModuleName, moduleNameString ) +import Name ( getOccString, isInternalName, Name, nameModule, nameUnique ) +import SrcLoc +import Unique ( getKey ) +import Encoding ( utf8DecodeByteString ) + import System.FilePath.Posix (()) -import Data.List -import Data.Maybe import qualified Data.Map as Map +import qualified Data.Set as Set import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html @@ -22,22 +30,24 @@ type StyleClass = String - -render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken] - -> Html -render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens +-- | Produce the HTML corresponding to a hyperlinked Haskell source +render + :: Maybe FilePath -- ^ path to the CSS file + -> Maybe FilePath -- ^ path to the JS file + -> SrcMaps -- ^ Paths to sources + -> HieAST PrintedType -- ^ ASTs from @.hie@ files + -> [Token] -- ^ tokens to render + -> Html +render mcss mjs srcs ast tokens = header mcss mjs <> body srcs ast tokens -body :: SrcMap -> [RichToken] -> Html -body srcs tokens = Html.body . Html.pre $ hypsrc +body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html +body srcs ast tokens = Html.body . Html.pre $ hypsrc where - hypsrc = mconcat . map (richToken srcs) $ tokens - + hypsrc = renderWithAst srcs ast tokens header :: Maybe FilePath -> Maybe FilePath -> Html -header mcss mjs - | isNothing mcss && isNothing mjs = Html.noHtml -header mcss mjs = - Html.header $ css mcss <> js mjs +header Nothing Nothing = Html.noHtml +header mcss mjs = Html.header $ css mcss <> js mjs where css Nothing = Html.noHtml css (Just cssFile) = Html.thelink Html.noHtml ! @@ -51,26 +61,133 @@ , Html.src scriptFile ] + +splitTokens :: HieAST PrintedType -> [Token] -> ([Token],[Token],[Token]) +splitTokens ast toks = (before,during,after) + where + (before,rest) = span leftOf toks + (during,after) = span inAst rest + leftOf t = realSrcSpanEnd (tkSpan t) <= realSrcSpanStart nodeSp + inAst t = nodeSp `containsSpan` tkSpan t + nodeSp = nodeSpan ast + +-- | Turn a list of tokens into hyperlinked sources, threading in relevant link +-- information from the 'HieAST'. +renderWithAst :: SrcMaps -> HieAST PrintedType -> [Token] -> Html +renderWithAst srcs Node{..} toks = anchored $ case toks of + + [tok] | nodeSpan == tkSpan tok -> richToken srcs nodeInfo tok + + -- NB: the GHC lexer lexes backquoted identifiers and parenthesized operators + -- as multiple tokens. + -- + -- * @a `elem` b@ turns into @[a, `, elem, `, b]@ (excluding space tokens) + -- * @(+) 1 2@ turns into @[(, +, ), 1, 2]@ (excluding space tokens) + -- + -- However, the HIE ast considers @`elem`@ and @(+)@ to be single nodes. In + -- order to make sure these get hyperlinked properly, we intercept these + -- special sequences of tokens and merge them into just one identifier or + -- operator token. + [BacktickTok s1, tok @ Token{ tkType = TkIdentifier }, BacktickTok s2] + | realSrcSpanStart s1 == realSrcSpanStart nodeSpan + , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan + -> richToken srcs nodeInfo + (Token{ tkValue = "`" <> tkValue tok <> "`" + , tkType = TkOperator + , tkSpan = nodeSpan }) + [OpenParenTok s1, tok @ Token{ tkType = TkOperator }, CloseParenTok s2] + | realSrcSpanStart s1 == realSrcSpanStart nodeSpan + , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan + -> richToken srcs nodeInfo + (Token{ tkValue = "(" <> tkValue tok <> ")" + , tkType = TkOperator + , tkSpan = nodeSpan }) + + _ -> go nodeChildren toks + where + go _ [] = mempty + go [] xs = foldMap renderToken xs + go (cur:rest) xs = + foldMap renderToken before <> renderWithAst srcs cur during <> go rest after + where + (before,during,after) = splitTokens cur xs + anchored c = Map.foldrWithKey anchorOne c (nodeIdentifiers nodeInfo) + anchorOne n dets c = externalAnchor n d $ internalAnchor n d c + where d = identInfo dets + +renderToken :: Token -> Html +renderToken Token{..} + | BS.null tkValue = mempty + | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue' + | otherwise = tokenSpan ! [ multiclass style ] + where + tkValue' = filterCRLF $ utf8DecodeByteString tkValue + style = tokenStyle tkType + tokenSpan = Html.thespan (Html.toHtml tkValue') + + -- | Given information about the source position of definitions, render a token -richToken :: SrcMap -> RichToken -> Html -richToken srcs (RichToken Token{..} details) - | tkType == TkSpace = renderSpace (GHC.srcSpanStartLine tkSpan) tkValue - | otherwise = linked content +richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html +richToken srcs details Token{..} + | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue' + | otherwise = annotate details $ linked content where + tkValue' = filterCRLF $ utf8DecodeByteString tkValue content = tokenSpan ! [ multiclass style ] - tokenSpan = Html.thespan (Html.toHtml tkValue) - style = tokenStyle tkType ++ maybe [] richTokenStyle details + tokenSpan = Html.thespan (Html.toHtml tkValue') + style = tokenStyle tkType ++ concatMap (richTokenStyle (null (nodeType details))) contexts + contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details + + -- pick an arbitary identifier to hyperlink with + identDet = Map.lookupMin . nodeIdentifiers $ details + -- If we have name information, we can make links - linked = case details of - Just d -> externalAnchor d . internalAnchor d . hyperlink srcs d + linked = case identDet of + Just (n,_) -> hyperlink srcs n Nothing -> id -richTokenStyle :: TokenDetails -> [StyleClass] -richTokenStyle (RtkVar _) = ["hs-var"] -richTokenStyle (RtkType _) = ["hs-type"] -richTokenStyle _ = [] +-- | Remove CRLFs from source +filterCRLF :: String -> String +filterCRLF ('\r':'\n':cs) = '\n' : filterCRLF cs +filterCRLF (c:cs) = c : filterCRLF cs +filterCRLF [] = [] +annotate :: NodeInfo PrintedType -> Html -> Html +annotate ni content = + Html.thespan (annot <> content) ! [ Html.theclass "annot" ] + where + annot + | not (null annotation) = + Html.thespan (Html.toHtml annotation) ! [ Html.theclass "annottext" ] + | otherwise = mempty + annotation = typ ++ identTyps + typ = unlines (nodeType ni) + typedIdents = [ (n,t) | (n, identType -> Just t) <- Map.toList $ nodeIdentifiers ni ] + identTyps + | length typedIdents > 1 || null (nodeType ni) + = concatMap (\(n,t) -> printName n ++ " :: " ++ t ++ "\n") typedIdents + | otherwise = "" + + printName :: Either ModuleName Name -> String + printName = either moduleNameString getOccString + +richTokenStyle + :: Bool -- ^ are we lacking a type annotation? + -> ContextInfo -- ^ in what context did this token show up? + -> [StyleClass] +richTokenStyle True Use = ["hs-type"] +richTokenStyle False Use = ["hs-var"] +richTokenStyle _ RecField{} = ["hs-var"] +richTokenStyle _ PatternBind{} = ["hs-var"] +richTokenStyle _ MatchBind{} = ["hs-var"] +richTokenStyle _ TyVarBind{} = ["hs-type"] +richTokenStyle _ ValBind{} = ["hs-var"] +richTokenStyle _ TyDecl = ["hs-type"] +richTokenStyle _ ClassTyDecl{} = ["hs-type"] +richTokenStyle _ Decl{} = ["hs-var"] +richTokenStyle _ IEThing{} = [] -- could be either a value or type + tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"] tokenStyle TkKeyword = ["hs-keyword"] @@ -87,61 +204,70 @@ tokenStyle TkUnknown = [] multiclass :: [StyleClass] -> HtmlAttr -multiclass = Html.theclass . intercalate " " +multiclass = Html.theclass . unwords -externalAnchor :: TokenDetails -> Html -> Html -externalAnchor (RtkDecl name) content = - Html.anchor content ! [ Html.name $ externalAnchorIdent name ] -externalAnchor _ content = content +externalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html +externalAnchor (Right name) contexts content + | not (isInternalName name) + , any isBinding contexts + = Html.thespan content ! [ Html.identifier $ externalAnchorIdent name ] +externalAnchor _ _ content = content -internalAnchor :: TokenDetails -> Html -> Html -internalAnchor (RtkBind name) content = - Html.anchor content ! [ Html.name $ internalAnchorIdent name ] -internalAnchor _ content = content +isBinding :: ContextInfo -> Bool +isBinding (ValBind RegularBind _ _) = True +isBinding PatternBind{} = True +isBinding Decl{} = True +isBinding (RecField RecFieldDecl _) = True +isBinding TyVarBind{} = True +isBinding ClassTyDecl{} = True +isBinding _ = False -externalAnchorIdent :: GHC.Name -> String -externalAnchorIdent = hypSrcNameUrl +internalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html +internalAnchor (Right name) contexts content + | isInternalName name + , any isBinding contexts + = Html.thespan content ! [ Html.identifier $ internalAnchorIdent name ] +internalAnchor _ _ content = content -internalAnchorIdent :: GHC.Name -> String -internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique +externalAnchorIdent :: Name -> String +externalAnchorIdent = hypSrcNameUrl -hyperlink :: SrcMap -> TokenDetails -> Html -> Html -hyperlink srcs details = case rtkName details of - Left name -> - if GHC.isInternalName name - then internalHyperlink name - else externalNameHyperlink srcs name - Right name -> externalModHyperlink srcs name +internalAnchorIdent :: Name -> String +internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique -internalHyperlink :: GHC.Name -> Html -> Html -internalHyperlink name content = - Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] +-- | Generate the HTML hyperlink for an identifier +hyperlink :: SrcMaps -> Identifier -> Html -> Html +hyperlink (srcs, srcs') ident = case ident of + Right name | isInternalName name -> internalHyperlink name + | otherwise -> externalNameHyperlink name + Left name -> externalModHyperlink name -externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html -externalNameHyperlink srcs name content = case Map.lookup mdl srcs of - Just SrcLocal -> Html.anchor content ! - [ Html.href $ hypSrcModuleNameUrl mdl name ] - Just (SrcExternal path) -> Html.anchor content ! - [ Html.href $ path hypSrcModuleNameUrl mdl name ] - Nothing -> content where - mdl = GHC.nameModule name + internalHyperlink name content = + Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html -externalModHyperlink srcs name content = - let srcs' = Map.mapKeys GHC.moduleName srcs in - case Map.lookup name srcs' of - Just SrcLocal -> Html.anchor content ! - [ Html.href $ hypSrcModuleUrl' name ] - Just (SrcExternal path) -> Html.anchor content ! - [ Html.href $ path hypSrcModuleUrl' name ] - Nothing -> content + externalNameHyperlink name content = case Map.lookup mdl srcs of + Just SrcLocal -> Html.anchor content ! + [ Html.href $ hypSrcModuleNameUrl mdl name ] + Just (SrcExternal path) -> Html.anchor content ! + [ Html.href $ spliceURL Nothing (Just mdl) (Just name) Nothing (".." path) ] + Nothing -> content + where + mdl = nameModule name + externalModHyperlink moduleName content = + case Map.lookup moduleName srcs' of + Just SrcLocal -> Html.anchor content ! + [ Html.href $ hypSrcModuleUrl' moduleName ] + Just (SrcExternal path) -> Html.anchor content ! + [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing (".." path) ] + Nothing -> content + renderSpace :: Int -> String -> Html -renderSpace _ [] = Html.noHtml -renderSpace line ('\n':rest) = mconcat - [ Html.thespan . Html.toHtml $ "\n" +renderSpace !_ "" = Html.noHtml +renderSpace !line ('\n':rest) = mconcat + [ Html.thespan (Html.toHtml '\n') , lineAnchor (line + 1) , renderSpace (line + 1) rest ] @@ -151,4 +277,4 @@ lineAnchor :: Int -> Html -lineAnchor line = Html.anchor Html.noHtml ! [ Html.name $ hypSrcLineUrl line ] +lineAnchor line = Html.thespan Html.noHtml ! [ Html.identifier $ hypSrcLineUrl line ] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -1,17 +1,24 @@ +{-# LANGUAGE PatternSynonyms, OverloadedStrings #-} module Haddock.Backends.Hyperlinker.Types where - import qualified GHC +import Data.ByteString ( ByteString ) + import Data.Map (Map) data Token = Token { tkType :: TokenType - , tkValue :: String + , tkValue :: ByteString -- ^ UTF-8 encoded , tkSpan :: {-# UNPACK #-} !Span } deriving (Show) +pattern BacktickTok, OpenParenTok, CloseParenTok :: Span -> Token +pattern BacktickTok sp = Token TkSpecial "`" sp +pattern OpenParenTok sp = Token TkSpecial "(" sp +pattern CloseParenTok sp = Token TkSpecial ")" sp + type Position = GHC.RealSrcLoc type Span = GHC.RealSrcSpan @@ -31,29 +38,6 @@ | TkUnknown deriving (Show, Eq) - -data RichToken = RichToken - { rtkToken :: Token - , rtkDetails :: Maybe TokenDetails - } - -data TokenDetails - = RtkVar GHC.Name - | RtkType GHC.Name - | RtkBind GHC.Name - | RtkDecl GHC.Name - | RtkModule GHC.ModuleName - deriving (Eq) - - -rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName -rtkName (RtkVar name) = Left name -rtkName (RtkType name) = Left name -rtkName (RtkBind name) = Left name -rtkName (RtkDecl name) = Left name -rtkName (RtkModule name) = Right name - - -- | Path for making cross-package hyperlinks in generated sources. -- -- Used in 'SrcMap' to determine whether module originates in current package @@ -63,5 +47,5 @@ | SrcLocal -- | Mapping from modules to cross-package source paths. -type SrcMap = Map GHC.Module SrcPath +type SrcMaps = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Haddock.Backends.Hyperlinker.Utils ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile' , hypSrcModuleUrl, hypSrcModuleUrl' @@ -6,21 +7,35 @@ , hypSrcModuleNameUrl, hypSrcModuleLineUrl , hypSrcModuleUrlFormat , hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat - ) where + , spliceURL, spliceURL' + -- * HIE file processing + , PrintedType + , recoverFullIfaceTypes + ) where +import Haddock.Utils import Haddock.Backends.Xhtml.Utils import GHC -import FastString -import System.FilePath.Posix (()) +import HieTypes ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat ) +import IfaceType +import Name ( getOccFS, getOccString ) +import Outputable ( showSDoc ) +import Var ( VarBndr(..) ) +import System.FilePath.Posix ((), (<.>)) +import qualified Data.Array as A + + +{-# INLINE hypSrcDir #-} hypSrcDir :: FilePath hypSrcDir = "src" +{-# INLINE hypSrcModuleFile #-} hypSrcModuleFile :: Module -> FilePath -hypSrcModuleFile = hypSrcModuleFile' . moduleName +hypSrcModuleFile m = moduleNameString (moduleName m) <.> "html" hypSrcModuleFile' :: ModuleName -> FilePath hypSrcModuleFile' mdl = spliceURL' @@ -32,20 +47,19 @@ hypSrcModuleUrl' :: ModuleName -> String hypSrcModuleUrl' = hypSrcModuleFile' +{-# INLINE hypSrcNameUrl #-} hypSrcNameUrl :: Name -> String -hypSrcNameUrl name = spliceURL - Nothing Nothing (Just name) Nothing nameFormat +hypSrcNameUrl = escapeStr . getOccString +{-# INLINE hypSrcLineUrl #-} hypSrcLineUrl :: Int -> String -hypSrcLineUrl line = spliceURL - Nothing Nothing Nothing (Just spn) lineFormat - where - loc = mkSrcLoc nilFS line 1 - spn = mkSrcSpan loc loc +hypSrcLineUrl line = "line-" ++ show line +{-# INLINE hypSrcModuleNameUrl #-} hypSrcModuleNameUrl :: Module -> Name -> String hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name +{-# INLINE hypSrcModuleLineUrl #-} hypSrcModuleLineUrl :: Module -> Int -> String hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line @@ -66,3 +80,65 @@ lineFormat :: String lineFormat = "line-%{LINE}" + + +-- * HIE file procesddsing + +-- This belongs in GHC's HieUtils... + +-- | Pretty-printed type, ready to be turned into HTML by @xhtml@ +type PrintedType = String + +-- | Expand the flattened HIE AST into one where the types printed out and +-- ready for end-users to look at. +-- +-- Using just primitives found in GHC's HIE utilities, we could write this as +-- follows: +-- +-- > 'recoverFullIfaceTypes' dflags hieTypes hieAst +-- > = 'fmap' (\ti -> 'showSDoc' df . +-- > 'pprIfaceType' $ +-- > 'recoverFullType' ti hieTypes) +-- > hieAst +-- +-- However, this is very inefficient (both in time and space) because the +-- mutliple calls to 'recoverFullType' don't share intermediate results. This +-- function fixes that. +recoverFullIfaceTypes + :: DynFlags + -> A.Array TypeIndex HieTypeFlat -- ^ flat types + -> HieAST TypeIndex -- ^ flattened AST + -> HieAST PrintedType -- ^ full AST +recoverFullIfaceTypes df flattened ast = fmap (printed A.!) ast + where + + -- Splitting this out into its own array is also important: we don't want + -- to pretty print the same type many times + printed :: A.Array TypeIndex PrintedType + printed = fmap (showSDoc df . pprIfaceType) unflattened + + -- The recursion in 'unflattened' is crucial - it's what gives us sharing + -- between the IfaceType's produced + unflattened :: A.Array TypeIndex IfaceType + unflattened = fmap (\flatTy -> go (fmap (unflattened A.!) flatTy)) flattened + + -- Unfold an 'HieType' whose subterms have already been unfolded + go :: HieType IfaceType -> IfaceType + go (HTyVarTy n) = IfaceTyVar (getOccFS n) + go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b) + go (HLitTy l) = IfaceLitTy l + go (HForAllTy ((n,k),af) t) = let b = (getOccFS n, k) + in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t + go (HFunTy a b) = IfaceFunTy a b + go (HQualTy con b) = IfaceDFunTy con b + go (HCastTy a) = a + go HCoercionTy = IfaceTyVar "" + go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) + + -- This isn't fully faithful - we can't produce the 'Inferred' case + hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs + hieToIfaceArgs (HieArgs args) = go' args + where + go' [] = IA_Nil + go' ((True ,x):xs) = IA_Arg x Required $ go' xs + go' ((False,x):xs) = IA_Arg x Specified $ go' xs diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1,5 +1,7 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.LaTeX @@ -22,6 +24,7 @@ import Pretty hiding (Doc, quote) import qualified Pretty +import BasicTypes ( PromotionFlag(..) ) import GHC import OccName import Name ( nameOccName ) @@ -100,6 +103,10 @@ type LaTeX = Pretty.Doc +-- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100 +-- often overflows the line). +latex2String :: LaTeX -> String +latex2String = fullRender PageMode 90 1 txtPrinter "" ppLaTeXTop :: String @@ -135,7 +142,7 @@ filename = odir (fromMaybe "haddock" packageStr <.> "tex") - writeFile filename (show tex) + writeUtf8File filename (show tex) ppLaTeXModule :: String -> FilePath -> Interface -> IO () @@ -153,7 +160,7 @@ text "\\haddockbeginheader", verb $ vcat [ text "module" <+> text mdl_str <+> lparen, - text " " <> fsep (punctuate (text ", ") $ + text " " <> fsep (punctuate (char ',') $ map exportListItem $ filter forSummary exports), text " ) where" @@ -168,7 +175,7 @@ body = processExports exports -- - writeFile (odir moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex) + writeUtf8File (odir moduleLaTeXFile mdl) (show tex) -- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX @@ -243,8 +250,8 @@ -- | Given a declaration, extract out the names being declared declNames :: LHsDecl DocNameI - -> ( LaTeX -- ^ to print before each name in an export list - , [DocName] -- ^ names being declared + -> ( LaTeX -- to print before each name in an export list + , [DocName] -- names being declared ) declNames (L _ decl) = case decl of TyClD _ d -> (empty, [tcdName d]) @@ -284,7 +291,7 @@ -> LaTeX ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of - TyClD _ d@FamDecl {} -> ppFamDecl doc instances d unicode + TyClD _ d@FamDecl {} -> ppFamDecl False doc instances d unicode TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now @@ -292,7 +299,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 (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode ForD _ d -> ppFor (doc, fnArgsDoc) d unicode InstD _ _ -> empty @@ -304,7 +311,7 @@ ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = - ppFunSig doc [name] (hsSigType typ) unicode + ppFunSig Nothing doc [name] (hsSigType typ) unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -314,13 +321,14 @@ ------------------------------------------------------------------------------- -- | Pretty-print a data\/type family declaration -ppFamDecl :: Documentation DocName -- ^ this decl's docs +ppFamDecl :: Bool -- ^ is the family associated? + -> Documentation DocName -- ^ this decl's docs -> [DocInstance DocNameI] -- ^ relevant instances -> TyClDecl DocNameI -- ^ family to print -> Bool -- ^ unicode -> LaTeX -ppFamDecl doc instances decl unicode = - declWithDoc (ppFamHeader (tcdFam decl) unicode <+> whereBit) +ppFamDecl associated doc instances decl unicode = + declWithDoc (ppFamHeader (tcdFam decl) unicode associated <+> whereBit) (if null body then Nothing else Just (vcat body)) $$ instancesBit where @@ -332,6 +340,7 @@ familyEqns | FamilyDecl { fdInfo = ClosedTypeFamily (Just eqns) } <- tcdFam decl + , not (null eqns) = Just (text "\\haddockbeginargs" $$ vcat [ decltt (ppFamDeclEqn eqn) <+> nl | L _ eqn <- eqns ] $$ text "\\end{tabulary}\\par") @@ -342,7 +351,7 @@ ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n , feqn_rhs = rhs , feqn_pats = ts } }) - = hsep [ ppAppNameTypes n (map unLoc ts) unicode + = hsep [ ppAppNameTypeArgs n ts unicode , equals , ppType unicode (unLoc rhs) ] @@ -353,22 +362,26 @@ -- | Print the LHS of a type\/data family declaration. ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print - -> Bool -- ^ unicode - -> LaTeX -ppFamHeader (XFamilyDecl _) _ = panic "haddock;ppFamHeader" + -> Bool -- ^ unicode + -> Bool -- ^ is the family associated? + -> LaTeX +ppFamHeader (XFamilyDecl _) _ _ = panic "haddock;ppFamHeader" ppFamHeader (FamilyDecl { fdLName = L _ name , fdTyVars = tvs , fdInfo = info , fdResultSig = L _ result , fdInjectivityAnn = injectivity }) - unicode = - leader <+> keyword "family" <+> famName <+> famSig <+> injAnn + unicode associated = + famly leader <+> famName <+> famSig <+> injAnn where leader = case info of OpenTypeFamily -> keyword "type" ClosedTypeFamily _ -> keyword "type" DataFamily -> keyword "data" + famly | associated = id + | otherwise = (<+> keyword "family") + famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs) famSig = case result of @@ -411,17 +424,23 @@ ------------------------------------------------------------------------------- -ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI - -> Bool -> LaTeX -ppFunSig doc docnames (L _ typ) unicode = +ppFunSig + :: Maybe LaTeX -- ^ a prefix to put right before the signature + -> DocForDecl DocName -- ^ documentation + -> [DocName] -- ^ pattern names in the pattern signature + -> LHsType DocNameI -- ^ type of the pattern synonym + -> Bool -- ^ unicode + -> LaTeX +ppFunSig leader doc docnames (L _ typ) unicode = ppTypeOrFunSig typ doc - ( ppTypeSig names typ False - , hsep . punctuate comma $ map ppSymName names + ( lead $ ppTypeSig names typ False + , lead $ hsep . punctuate comma $ map ppSymName names , dcolon unicode ) unicode where names = map getName docnames + lead = maybe id (<+>) leader -- | Pretty-print a pattern synonym ppLPatSig :: DocForDecl DocName -- ^ documentation @@ -430,23 +449,15 @@ -> Bool -- ^ unicode -> LaTeX ppLPatSig doc docnames ty unicode - = ppTypeOrFunSig typ doc - ( keyword "pattern" <+> ppTypeSig names typ False - , keyword "pattern" <+> (hsep . punctuate comma $ map ppSymName names) - , dcolon unicode - ) - unicode - where - typ = unLoc (hsSigType ty) - names = map getName docnames + = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigType ty) unicode -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed. ppTypeOrFunSig :: HsType DocNameI -> DocForDecl DocName -- ^ documentation - -> ( LaTeX -- ^ first-line (no-argument docs only) - , LaTeX -- ^ first-line (argument docs only) - , LaTeX -- ^ type prefix (argument docs only) + -> ( LaTeX -- first-line (no-argument docs only) + , LaTeX -- first-line (argument docs only) + , LaTeX -- type prefix (argument docs only) ) -> Bool -- ^ unicode -> LaTeX @@ -458,7 +469,7 @@ text "\\end{tabulary}\\par" $$ fromMaybe empty (documentationToLaTeX doc) --- This splits up a type signature along `->` and adds docs (when they exist) +-- | This splits up a type signature along @->@ and adds docs (when they exist) -- to the arguments. The output is a list of (leader/seperator, argument and -- its doc) ppSubSigLike :: Bool -- ^ unicode @@ -476,12 +487,13 @@ do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] do_args _n leader (HsForAllTy _ tvs ltype) = [ ( decltt leader - , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) + , decltt (ppForAllPart unicode tvs) <+> ppLType unicode ltype ) ] do_args n leader (HsQualTy _ lctxt ltype) - = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl) - : do_largs n (darrow unicode) ltype + = ( decltt leader + , decltt (ppLContextNoArrow lctxt unicode) <+> nl + ) : do_largs n (darrow unicode) ltype do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) = [ (decltt ldr, latex <+> nl) @@ -500,9 +512,9 @@ -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode -- mode since `->` and `::` are rendered as single characters. - gadtComma = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "," - gadtEnd = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "\\}" - gadtOpen = text "\\{" + gadtComma = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char ',' + gadtEnd = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char '}' + gadtOpen = char '{' ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX @@ -512,8 +524,9 @@ <+> ppType unicode ty -ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX] -ppTyVars = map (ppSymName . getName . hsLTyVarName) +-- | Pretty-print type variables. +ppTyVars :: Bool -> [LHsTyVarBndr DocNameI] -> [LaTeX] +ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc) tyvarNames :: LHsQTyVars DocNameI -> [Name] @@ -524,10 +537,9 @@ declWithDoc decl doc = text "\\begin{haddockdesc}" $$ text "\\item[\\begin{tabular}{@{}l}" $$ - text (latexMonoFilter (show decl)) $$ - text "\\end{tabular}]" <> - (if isNothing doc then empty else text "\\haddockbegindoc") $$ - maybe empty id doc $$ + text (latexMonoFilter (latex2String decl)) $$ + text "\\end{tabular}]" $$ + maybe empty (\x -> text "{\\haddockbegindoc" $$ x <> text "}") doc $$ text "\\end{haddockdesc}" @@ -538,9 +550,9 @@ multiDecl decls = text "\\begin{haddockdesc}" $$ vcat [ - text "\\item[" $$ - text (latexMonoFilter (show decl)) $$ - text "]" + text "\\item[\\begin{tabular}{@{}l}" $$ + text (latexMonoFilter (latex2String decl)) $$ + text "\\end{tabular}]" | decl <- decls ] $$ text "\\end{haddockdesc}" @@ -584,6 +596,7 @@ hsep (map (ppDocName . unLoc) vars2) +-- TODO: associated type defaults, docs on default methods ppClassDecl :: [DocInstance DocNameI] -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Bool -> LaTeX @@ -604,18 +617,28 @@ body_ | null lsigs, null ats, null at_defs = Nothing | null ats, null at_defs = Just methodTable ---- | otherwise = atTable $$ methodTable - | otherwise = error "LaTeX.ppClassDecl" + | otherwise = Just (atTable $$ methodTable) + atTable = + text "\\haddockpremethods{}" <> emph (text "Associated Types") $$ + vcat [ ppFamDecl True (fst doc) [] (FamDecl noExt decl) True + | L _ decl <- ats + , let name = unL . fdLName $ decl + doc = lookupAnySubdoc name subdocs + ] + + methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$ - vcat [ ppFunSig doc names (hsSigWcType typ) unicode - | L _ (TypeSig _ lnames typ) <- lsigs - , let doc = lookupAnySubdoc (head names) subdocs - names = map unLoc lnames ] - -- FIXME: is taking just the first name ok? Is it possible that - -- there are different subdocs for different names in a single - -- type signature? + vcat [ ppFunSig leader doc names (hsSigType typ) unicode + | L _ (ClassOpSig _ is_def lnames typ) <- lsigs + , let doc | is_def = noDocForDecl + | otherwise = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames + leader = if is_def then Just (keyword "default") else Nothing + ] + -- N.B. taking just the first name is ok. Signatures with multiple + -- names are expanded so that each name gets its own signature. instancesBit = ppDocInstances unicode instances @@ -634,6 +657,7 @@ isUndocdInstance :: DocInstance a -> Maybe (InstHead a) isUndocdInstance (i,Nothing,_,_) = Just i +isUndocdInstance (i,Just (MetaDoc _ DocEmpty),_,_) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside @@ -716,17 +740,23 @@ -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Bool -> LaTeX -ppConstrHdr forall tvs ctxt unicode - = (if null tvs then empty else ppForall) - <+> - (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") +ppConstrHdr + :: Bool -- ^ print explicit foralls + -> [LHsTyVarBndr DocNameI] -- ^ type variables + -> HsContext DocNameI -- ^ context + -> Bool -- ^ unicode + -> LaTeX +ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt where - ppForall = case forall of - True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " - False -> empty + ppForall + | null tvs || not forall_ = empty + | otherwise = ppForAllPart unicode tvs + ppCtxt + | null ctxt = empty + | otherwise = ppContextNoArrow ctxt unicode <+> darrow unicode <> space + -- | Pretty-print a constructor ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -- ^ all decl docs -> Bool -- ^ unicode @@ -753,11 +783,10 @@ -- First line of the constructor (no doc, no fields, single-line) decl = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars - context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False + } -> let context = unLoc (fromMaybe (noLoc []) cxt) header_ = ppConstrHdr forall_ tyVars context unicode in case det of -- Prefix constructor, e.g. 'Just a' @@ -905,6 +934,11 @@ ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) +ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Bool -> LaTeX +ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) unicode + = ppTypeApp n args ppDocName (ppLHsTypeArg unicode) +ppAppNameTypeArgs n args unicode + = ppDocName n <+> hsep (map (ppLHsTypeArg unicode) args) -- | Print an application of a DocName and a list of Names ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX @@ -923,7 +957,6 @@ ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) - ------------------------------------------------------------------------------- -- * Contexts ------------------------------------------------------------------------------- @@ -953,7 +986,7 @@ pp_hs_context :: [HsType DocNameI] -> Bool -> LaTeX pp_hs_context [] _ = empty -pp_hs_context [p] unicode = ppType unicode p +pp_hs_context [p] unicode = ppCtxType unicode p pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) @@ -974,7 +1007,7 @@ sumParens :: [LaTeX] -> LaTeX -sumParens = ubxparens . hsep . punctuate (text " | ") +sumParens = ubxparens . hsep . punctuate (text " |") ------------------------------------------------------------------------------- @@ -988,16 +1021,22 @@ ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) - -ppType, ppParendType, ppFunLhType :: Bool -> HsType DocNameI -> LaTeX +ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode -ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode +ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode +ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode +ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX +ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty +ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <> + ppLParendType unicode ki +ppLHsTypeArg _ (HsArgPar _) = text "" + ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) = - parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind + parens (ppDocName name <+> dcolon unicode <+> ppLKind unicode kind) ppHsTyVarBndr _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr" ppLKind :: Bool -> LHsKind DocNameI -> LaTeX @@ -1010,13 +1049,17 @@ -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell +ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> LaTeX +ppForAllPart unicode tvs = hsep (forallSymbol unicode : ppTyVars unicode tvs) <> dot + + ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX ppr_mono_ty (HsForAllTy _ tvs ty) unicode - = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot + = sep [ ppForAllPart unicode tvs , ppr_mono_lty ty unicode ] ppr_mono_ty (HsQualTy _ ctxt ty) unicode = sep [ ppLContext ctxt unicode @@ -1027,27 +1070,30 @@ ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name -ppr_mono_ty (HsTyVar _ Promoted (L _ name)) _ = char '\'' <> ppDocName name +ppr_mono_ty (HsTyVar _ IsPromoted (L _ name)) _ = char '\'' <> ppDocName name ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) -ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind) +ppr_mono_ty (HsKindSig _ ty kind) u = ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) -ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty ty u) +ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u ppr_mono_ty (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty (HsRecTy {}) _ = text "{..}" ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty (HsExplicitListTy _ Promoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys +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 ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode = hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode] +ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode + = hsep [ppr_mono_lty fun_ty unicode, atSign unicode <> ppr_mono_lty arg_ki unicode] + ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode = ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode where - ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op - occName = nameOccName . getName . unLoc $ op + ppr_op | isSymOcc (getOccName op) = ppLDocName op + | otherwise = char '`' <> ppLDocName op <> char '`' ppr_mono_ty (HsParTy _ ty) unicode = parens (ppr_mono_lty ty unicode) @@ -1056,7 +1102,7 @@ ppr_mono_ty (HsDocTy _ ty _) unicode = ppr_mono_lty ty unicode -ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = text "\\_" +ppr_mono_ty (HsWildCardTy _) _ = char '_' ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) @@ -1076,16 +1122,13 @@ ppBinder :: OccName -> LaTeX ppBinder n - | isInfixName n = parens $ ppOccName n - | otherwise = ppOccName n + | isSymOcc n = parens $ ppOccName n + | otherwise = ppOccName n ppBinderInfix :: OccName -> LaTeX ppBinderInfix n - | isInfixName n = ppOccName n - | otherwise = cat [ char '`', ppOccName n, char '`' ] - -isInfixName :: OccName -> Bool -isInfixName n = isVarSym n || isConSym n + | isSymOcc n = ppOccName n + | otherwise = cat [ char '`', ppOccName n, char '`' ] ppSymName :: Name -> LaTeX ppSymName name @@ -1093,28 +1136,16 @@ | otherwise = ppName name -ppVerbOccName :: OccName -> LaTeX -ppVerbOccName = text . latexFilter . occNameString - ppIPName :: HsIPName -> LaTeX -ppIPName ip = text $ unpackFS $ hsIPNameFS ip +ppIPName = text . ('?':) . unpackFS . hsIPNameFS ppOccName :: OccName -> LaTeX ppOccName = text . occNameString -ppVerbDocName :: DocName -> LaTeX -ppVerbDocName = ppVerbOccName . nameOccName . getName - - -ppVerbRdrName :: RdrName -> LaTeX -ppVerbRdrName = ppVerbOccName . rdrNameOcc - - ppDocName :: DocName -> LaTeX ppDocName = ppOccName . nameOccName . getName - ppLDocName :: Located DocName -> LaTeX ppLDocName (L _ d) = ppDocName d @@ -1152,9 +1183,10 @@ latexMonoMunge :: Char -> String -> String -latexMonoMunge ' ' s = '\\' : ' ' : s +latexMonoMunge ' ' (' ':s) = "\\ \\ " ++ s +latexMonoMunge ' ' ('\\':' ':s) = "\\ \\ " ++ s latexMonoMunge '\n' s = '\\' : '\\' : s -latexMonoMunge c s = latexMunge c s +latexMonoMunge c s = latexMunge c s ------------------------------------------------------------------------------- @@ -1162,34 +1194,40 @@ ------------------------------------------------------------------------------- -parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX) -parLatexMarkup ppId = Markup { - markupParagraph = \p v -> p v <> text "\\par" $$ text "", - markupEmpty = \_ -> empty, - markupString = \s v -> text (fixString v s), - markupAppend = \l r v -> l v <> r v, - markupIdentifier = markupId ppId, - markupIdentifierUnchecked = markupId (ppVerbOccName . snd), - markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), - markupWarning = \p v -> emph (p v), - markupEmphasis = \p v -> emph (p v), - markupBold = \p v -> bold (p v), - markupMonospaced = \p _ -> tt (p Mono), - markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", - markupPic = \p _ -> markupPic p, - markupMathInline = \p _ -> markupMathInline p, - markupMathDisplay = \p _ -> markupMathDisplay p, - markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", - markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), - markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", - markupHyperlink = \l _ -> markupLink l, - markupAName = \_ _ -> empty, - markupProperty = \p _ -> quote $ verb $ text p, - markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e, - markupHeader = \(Header l h) p -> header l (h p), - markupTable = \(Table h b) p -> table h b p +latexMarkup :: HasOccName a => DocMarkup (Wrap a) (StringContext -> LaTeX -> LaTeX) +latexMarkup = Markup + { markupParagraph = \p v -> blockElem (p v (text "\\par")) + , markupEmpty = \_ -> id + , markupString = \s v -> inlineElem (text (fixString v s)) + , markupAppend = \l r v -> l v . r v + , markupIdentifier = \i v -> inlineElem (markupId v (fmap occName i)) + , markupIdentifierUnchecked = \i v -> inlineElem (markupId v (fmap snd i)) + , markupModule = \m _ -> inlineElem (let (mdl,_ref) = break (=='#') m in (tt (text mdl))) + , markupWarning = \p v -> p v + , markupEmphasis = \p v -> inlineElem (emph (p v empty)) + , markupBold = \p v -> inlineElem (bold (p v empty)) + , markupMonospaced = \p v -> inlineElem (markupMonospace p v) + , markupUnorderedList = \p v -> blockElem (itemizedList (map (\p' -> p' v empty) p)) + , markupPic = \p _ -> inlineElem (markupPic p) + , markupMathInline = \p _ -> inlineElem (markupMathInline p) + , markupMathDisplay = \p _ -> blockElem (markupMathDisplay p) + , markupOrderedList = \p v -> blockElem (enumeratedList (map (\p' -> p' v empty) p)) + , markupDefList = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l)) + , markupCodeBlock = \p _ -> blockElem (quote (verb (p Verb empty))) + , markupHyperlink = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l)) + , markupAName = \_ _ -> id -- TODO + , markupProperty = \p _ -> blockElem (quote (verb (text p))) + , markupExample = \e _ -> blockElem (quote (verb (text $ unlines $ map exampleToString e))) + , markupHeader = \(Header l h) p -> blockElem (header l (h p empty)) + , markupTable = \(Table h b) p -> blockElem (table h b p) } where + blockElem :: LaTeX -> LaTeX -> LaTeX + blockElem = ($$) + + inlineElem :: LaTeX -> LaTeX -> LaTeX + inlineElem = (<>) + header 1 d = text "\\section*" <> braces d header 2 d = text "\\subsection*" <> braces d header l d @@ -1202,8 +1240,11 @@ fixString Verb s = s fixString Mono s = latexMonoFilter s - markupLink (Hyperlink url mLabel) = case mLabel of - Just label -> text "\\href" <> braces (text url) <> braces (text label) + markupMonospace p Verb = p Verb empty + markupMonospace p _ = tt (p Mono empty) + + markupLink url mLabel = case mLabel of + Just label -> text "\\href" <> braces (text url) <> braces label Nothing -> text "\\url" <> braces (text url) -- Is there a better way of doing this? Just a space is an aribtrary choice. @@ -1218,35 +1259,28 @@ markupMathDisplay mathjax = text "\\[" <> text mathjax <> text "\\]" - markupId ppId_ id v = + markupId v wrappedOcc = case v of - Verb -> theid - Mono -> theid - Plain -> text "\\haddockid" <> braces theid - where theid = ppId_ id - - -latexMarkup :: DocMarkup DocName (StringContext -> LaTeX) -latexMarkup = parLatexMarkup ppVerbDocName - - -rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX) -rdrLatexMarkup = parLatexMarkup ppVerbRdrName - + Verb -> text i + Mono -> text "\\haddockid" <> braces (text . latexMonoFilter $ i) + Plain -> text "\\haddockid" <> braces (text . latexFilter $ i) + where i = showWrapped occNameString wrappedOcc docToLaTeX :: Doc DocName -> LaTeX -docToLaTeX doc = markup latexMarkup doc Plain - +docToLaTeX doc = markup latexMarkup doc Plain empty documentationToLaTeX :: Documentation DocName -> Maybe LaTeX documentationToLaTeX = fmap docToLaTeX . fmap _doc . combineDocumentation rdrDocToLaTeX :: Doc RdrName -> LaTeX -rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain +rdrDocToLaTeX doc = markup latexMarkup doc Plain empty -data StringContext = Plain | Verb | Mono +data StringContext + = Plain -- ^ all special characters have to be escape + | Mono -- ^ on top of special characters, escape space chraacters + | Verb -- ^ don't escape anything latexStripTrailingWhitespace :: Doc a -> Doc a @@ -1271,23 +1305,23 @@ itemizedList :: [LaTeX] -> LaTeX itemizedList items = - text "\\begin{itemize}" $$ + text "\\vbox{\\begin{itemize}" $$ vcat (map (text "\\item" $$) items) $$ - text "\\end{itemize}" + text "\\end{itemize}}" enumeratedList :: [LaTeX] -> LaTeX enumeratedList items = - text "\\begin{enumerate}" $$ + text "\\vbox{\\begin{enumerate}" $$ vcat (map (text "\\item " $$) items) $$ - text "\\end{enumerate}" + text "\\end{enumerate}}" descriptionList :: [(LaTeX,LaTeX)] -> LaTeX descriptionList items = - text "\\begin{description}" $$ - vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$ - text "\\end{description}" + text "\\vbox{\\begin{description}" $$ + vcat (map (\(a,b) -> text "\\item" <> brackets a <> text "\\hfill \\par" $$ b) items) $$ + text "\\end{description}}" tt :: LaTeX -> LaTeX @@ -1295,8 +1329,8 @@ decltt :: LaTeX -> LaTeX -decltt ltx = text "\\haddockdecltt" <> braces ltx - +decltt ltx = text "\\haddockdecltt" <> braces (text filtered) + where filtered = latexMonoFilter (latex2String ltx) emph :: LaTeX -> LaTeX emph ltx = text "\\emph" <> braces ltx @@ -1304,6 +1338,12 @@ bold :: LaTeX -> LaTeX bold ltx = text "\\textbf" <> braces ltx +-- TODO: @verbatim@ is too much since +-- +-- * Haddock supports markup _inside_ of codeblocks. Right now, the LaTeX +-- representing that markup gets printed verbatim +-- * Verbatim environments are not supported everywhere (example: not nested +-- inside a @tabulary@ environment) verb :: LaTeX -> LaTeX verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}" -- NB. swallow a trailing \n in the verbatim text by appending the @@ -1315,12 +1355,13 @@ quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" -dcolon, arrow, darrow, forallSymbol, starSymbol :: Bool -> LaTeX +dcolon, arrow, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX dcolon unicode = text (if unicode then "∷" else "::") arrow unicode = text (if unicode then "→" else "->") darrow unicode = text (if unicode then "⇒" else "=>") forallSymbol unicode = text (if unicode then "∀" else "forall") starSymbol unicode = text (if unicode then "★" else "*") +atSign unicode = text (if unicode then "@" else "@") dot :: LaTeX dot = char '.' @@ -1335,7 +1376,7 @@ ubxparens :: LaTeX -> LaTeX -ubxparens h = text "(#" <> h <> text "#)" +ubxparens h = text "(#" <+> h <+> text "#)" nl :: LaTeX diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -33,12 +33,13 @@ import Haddock.Utils import Haddock.Utils.Json import Text.XHtml hiding ( name, title, p, quote ) +import qualified Text.XHtml as XHtml import Haddock.GhcUtils import Control.Monad ( when, unless ) import qualified Data.ByteString.Builder as Builder import Data.Char ( toUpper, isSpace ) -import Data.List ( sortBy, isPrefixOf, intercalate, intersperse ) +import Data.List ( sortBy, isPrefixOf, intersperse ) import Data.Maybe import System.Directory import System.FilePath hiding ( () ) @@ -120,17 +121,26 @@ headHtml :: String -> Themes -> Maybe String -> Html headHtml docTitle themes mathjax_url = - header << [ - meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], - thetitle << docTitle, - styleSheet themes, - thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml, - script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml, - script ! [src mjUrl, thetype "text/javascript"] << noHtml + 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 themes + , thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml + , thelink ! [ rel "stylesheet", thetype "text/css", href fontUrl] << 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 ] where - mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url - + fontUrl = "https://fonts.googleapis.com/css?family=PT+Sans:400,400i,700" + mjUrl = fromMaybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" mathjax_url + mjConf = unwords [ "MathJax.Hub.Config({" + , "tex2jax: {" + , "processClass: \"mathjax\"," + , "ignoreClass: \".*\"" + , "}" + , "});" ] srcButton :: SourceURLs -> Maybe Interface -> Maybe Html srcButton (Just src_base_url, _, _, _) Nothing = @@ -177,13 +187,13 @@ pageContent = body << [ divPackageHeader << [ + nonEmptySectionName << doctitle, unordList (catMaybes [ srcButton maybe_source_url iface, wikiButton maybe_wiki_url (ifaceMod <$> iface), contentsButton maybe_contents_url, indexButton maybe_index_url]) - ! [theclass "links", identifier "page-menu"], - nonEmptySectionName << doctitle + ! [theclass "links", identifier "page-menu"] ], divContent << pageContent, divFooter << paragraph << ( @@ -283,7 +293,7 @@ ppModuleTree pkg qual tree ] createDirectoryIfMissing True odir - writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html) ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html @@ -321,6 +331,7 @@ cBtn = case (ts, leaf) of (_:_, Just _) -> thespan ! collapseControl p "" << spaceHtml + ([] , Just _) -> thespan ! [theclass "noexpander"] << spaceHtml (_, _ ) -> noHtml -- We only need an explicit collapser button when the module name -- is also a leaf, and so is a link to a module page. Indeed, the @@ -377,7 +388,7 @@ | Just item_html <- processExport True links_info unicode pkg qual item = [ Object [ "display_html" .= String (showHtmlFragment item_html) - , "name" .= String (intercalate " " (map nameString names)) + , "name" .= String (unwords (map getOccString names)) , "module" .= String (moduleString mdl) , "link" .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names))) ] @@ -386,18 +397,15 @@ where names = exportName item ++ exportSubs item - exportSubs :: ExportItem name -> [IdP name] + exportSubs :: ExportItem DocNameI -> [IdP DocNameI] exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs exportSubs _ = [] - exportName :: ExportItem name -> [IdP name] + exportName :: ExportItem DocNameI -> [IdP DocNameI] exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl) exportName ExportNoDecl { expItemName } = [expItemName] exportName _ = [] - nameString :: NamedThing name => name -> String - nameString = occNameString . nameOccName . getName - nameLink :: NamedThing name => Module -> name -> String nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName @@ -425,9 +433,9 @@ mapM_ (do_sub_index index) initialChars -- Let's add a single large index as well for those who don't know exactly what they're looking for: let mergedhtml = indexPage False Nothing index - writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) + writeUtf8File (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) - writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html) + writeUtf8File (joinPath [odir, indexHtmlFile]) (renderToString debug html) where indexPage showLetters ch items = @@ -468,7 +476,7 @@ do_sub_index this_ix c = unless (null index_part) $ - writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) + writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) where html = indexPage True (Just c) index_part index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c] @@ -562,7 +570,7 @@ ] createDirectoryIfMissing True odir - writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) + writeUtf8File (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) signatureDocURL :: String signatureDocURL = "https://wiki.haskell.org/Module_signature" @@ -629,9 +637,9 @@ | null sections && not orphan = noHtml | otherwise = contentsDiv where - contentsDiv = divTableOfContents << ( - sectionName << "Contents" +++ - unordList (sections ++ orphanSection)) + contentsDiv = divTableOfContents << (divContentsList << ( + (sectionName << "Contents") ! [ strAttr "onclick" "window.scrollTo(0,0)" ] +++ + unordList (sections ++ orphanSection))) (sections, _leftovers{-should be []-}) = process 0 exports orphanSection diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -1,6 +1,8 @@ {-# LANGUAGE TransformListComp #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Html.Decl @@ -32,7 +34,9 @@ import Data.Maybe import Text.XHtml hiding ( name, title, p, quote ) +import BasicTypes (PromotionFlag(..), isPromoted) import GHC hiding (LexicalFixity(..)) +import qualified GHC import GHC.Exts import Name import BooleanFormula @@ -72,14 +76,14 @@ [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = - ppFunSig summary links loc doc (map unLoc lnames) lty fixities + ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities splice unicode pkg qual -ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual = - ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) +ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual = + ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ) splice unicode pkg qual HideEmptyContexts where pp_typ = ppLType unicode qual HideEmptyContexts typ @@ -122,16 +126,16 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode pkg qual emptyCtxts | summary = pref1 - | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName pkg qual doc + | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curname pkg qual doc | otherwise = topDeclElem links loc splice docnames pref2 +++ subArguments pkg qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts) - +++ docSection curName pkg qual doc + +++ docSection curname pkg qual doc where - curName = getName <$> listToMaybe docnames + curname = getName <$> listToMaybe docnames --- This splits up a type signature along `->` and adds docs (when they exist) to --- the arguments. +-- | This splits up a type signature along @->@ and adds docs (when they exist) +-- to the arguments. -- -- If one passes in a list of the available subdocs, any top-level `HsRecTy` -- found will be expanded out into their fields. @@ -149,9 +153,7 @@ do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] do_args n leader (HsForAllTy _ tvs ltype) - = do_largs n leader' ltype - where - leader' = leader <+> ppForAll tvs unicode qual + = do_largs n (leader <+> ppForAllPart unicode qual tvs) ltype do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt) @@ -185,15 +187,6 @@ gadtOpen = toHtml "{" - -ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html -ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of - [] -> noHtml - ts -> forallSymbol unicode <+> hsep ts +++ dot - where ppKTv n k = parens $ - ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k - ppFixities :: [(DocName, Fixity)] -> Qualification -> Html ppFixities [] _ = noHtml ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge @@ -226,7 +219,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 doc [name] (hsSigType typ) fixities splice unicode pkg qual + = ppFunSig summary links loc noHtml doc [name] (hsSigType typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -258,10 +251,6 @@ htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms -ppTyName :: Name -> Html -ppTyName = ppName Prefix - - ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan -> [DocName] -> HsType DocNameI -> Html @@ -290,10 +279,11 @@ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFamDecl summary associated links instances fixities loc doc decl splice unicode pkg qual | summary = ppFamHeader True associated decl unicode qual - | otherwise = header_ +++ docSection Nothing pkg qual doc +++ instancesBit + | otherwise = header_ +++ docSection curname pkg qual doc +++ instancesBit where docname = unLoc $ fdLName decl + curname = Just $ getName docname header_ = topDeclElem links loc splice [docname] $ ppFamHeader summary associated decl unicode qual <+> ppFixities fixities qual @@ -311,7 +301,7 @@ ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n , feqn_rhs = rhs , feqn_pats = ts } }) - = ( ppAppNameTypes n (map unLoc ts) unicode qual + = ( ppAppNameTypeArgs n ts unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing , [] @@ -414,6 +404,11 @@ ppAppNameTypes n ts unicode qual = ppTypeApp n ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts) +ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Unicode -> Qualification -> Html +ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) u q + = ppTypeApp n args (\p -> ppDocName q p True) (ppLHsTypeArg u q HideEmptyContexts) +ppAppNameTypeArgs n args u q + = (ppDocName q Prefix True n) <+> hsep (map (ppLHsTypeArg u q HideEmptyContexts) args) -- | General printing of type applications ppTypeApp :: DocName -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html @@ -426,7 +421,6 @@ ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts) - ------------------------------------------------------------------------------- -- * Contexts ------------------------------------------------------------------------------- @@ -503,7 +497,7 @@ -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names (hsSigType typ) + [ ppFunSig summary links loc noHtml doc names (hsSigType typ) [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -524,13 +518,16 @@ -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs - decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars - , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname@(L _ nm) + , tcdTyVars = ltyvars, tcdFDs = lfds, tcdSigs = lsigs + , tcdATs = ats, tcdATDefs = atsDefs }) splice unicode pkg qual | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual - | otherwise = classheader +++ docSection Nothing pkg qual d + | otherwise = classheader +++ docSection curname pkg qual d +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where + curname = Just $ getName nm + sigs = map unLoc lsigs classheader @@ -540,28 +537,68 @@ -- Only the fixity relevant to the class header fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual - nm = tcdName decl - hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds - -- ToDo: add assocatied typ defaults - atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode pkg qual - | at <- ats - , let n = unL . fdLName $ unL at - doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs - subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] + -- Associated types + atBit = subAssociatedTypes + [ ppAssocType summary links doc at subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defTys) + | at <- ats + , let name = unL . fdLName $ unL at + doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defTys = ppDefaultAssocTy name <$> lookupDAT name + ] - methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ) - subfixs splice unicode pkg qual - | L _ (ClassOpSig _ _ lnames typ) <- lsigs - , name <- map unLoc lnames - , let doc = lookupAnySubdoc name subdocs - subfixs = [ f | f@(n',_) <- fixities - , name == n' ] - ] - -- N.B. taking just the first name is ok. Signatures with multiple names - -- are expanded so that each name gets its own signature. + -- Default associated types + ppDefaultAssocTy n (vs,t,d') = ppTySyn summary links [] loc d' synDecl + splice unicode pkg qual + where + synDecl = SynDecl { tcdSExt = noExt + , tcdLName = noLoc n + , tcdTyVars = vs + , tcdFixity = GHC.Prefix + , tcdRhs = t } + lookupDAT name = Map.lookup (getName name) defaultAssocTys + defaultAssocTys = Map.fromList + [ (getName name, (vs, typ, doc)) + | L _ (FamEqn { feqn_rhs = typ + , feqn_tycon = L _ name + , feqn_pats = vs }) <- atsDefs + , let doc = noDocForDecl -- TODO: get docs for associated type defaults + ] + + -- Methods + methodBit = subMethods + [ ppFunSig summary links loc noHtml doc [name] (hsSigType typ) + subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defSigs) + | ClassOpSig _ False lnames typ <- sigs + , name <- map unLoc lnames + , let doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defSigs = ppDefaultFunSig name <$> lookupDM name + ] + -- N.B. taking just the first name is ok. Signatures with multiple names + -- are expanded so that each name gets its own signature. + + -- Default methods + ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default") + d' [n] (hsSigType t) [] splice unicode pkg qual + + lookupDM name = Map.lookup (getOccString name) defaultMethods + defaultMethods = Map.fromList + [ (nameStr, (typ, doc)) + | ClassOpSig _ True lnames typ <- sigs + , name <- map unLoc lnames + , let doc = noDocForDecl -- TODO: get docs for method defaults + nameStr = getOccString name + ] + + -- Minimal complete definition minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == @@ -570,7 +607,7 @@ -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns] + [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -585,6 +622,7 @@ where wrap | p = parens | otherwise = id ppMinimal p (Parens x) = ppMinimal p (unLoc x) + -- Instances instancesBit = ppInstances links (OriginClass nm) instances splice unicode pkg qual @@ -690,7 +728,7 @@ [ "o:" | orphan ] ++ [ qual origin , ":" ++ getOccString origin - , ":" ++ (occNameString . getOccName . ihdClsName) ihd + , ":" ++ getOccString (ihdClsName ihd) , ":" ++ show no ] where @@ -759,10 +797,11 @@ splice unicode pkg qual | summary = ppShortDataDecl summary False dataDecl pats unicode qual - | otherwise = header_ +++ docSection Nothing pkg qual doc +++ constrBit +++ patternBit +++ instancesBit + | otherwise = header_ +++ docSection curname pkg qual doc +++ constrBit +++ patternBit +++ instancesBit where docname = tcdName dataDecl + curname = Just $ getName docname cons = dd_cons (tcdDataDefn dataDecl) isH98 = case unLoc (head cons) of ConDeclH98 {} -> True @@ -810,24 +849,23 @@ ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars - context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False + } -> let context = unLoc (fromMaybe (noLoc []) cxt) header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' PrefixCon args -> - ( header_ +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args) + ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args) , noHtml , noHtml ) -- Record constructor, e.g. 'Identity { runIdentity :: a }' RecCon (L _ fields) -> - ( header_ +++ ppOcc <+> char '{' + ( header_ <+> ppOcc <+> char '{' , shortSubDecls dataInst [ ppShortField summary unicode qual field | L _ field <- fields ] @@ -836,7 +874,7 @@ -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 -> - ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1 + ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts arg1 , ppOccInfix , ppLParendType unicode qual HideEmptyContexts arg2 ] @@ -884,28 +922,27 @@ decl = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars - context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False + } -> let context = unLoc (fromMaybe (noLoc []) cxt) header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' PrefixCon args - | hasArgDocs -> header_ +++ ppOcc <+> fixity - | otherwise -> hsep [ header_ +++ ppOcc + | hasArgDocs -> header_ <+> ppOcc <+> fixity + | otherwise -> hsep [ header_ <+> ppOcc , hsep (map (ppLParendType unicode qual HideEmptyContexts) args) , fixity ] -- Record constructor, e.g. 'Identity { runIdentity :: a }' - RecCon _ -> header_ +++ ppOcc <+> fixity + RecCon _ -> header_ <+> ppOcc <+> fixity -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 - | hasArgDocs -> header_ +++ ppOcc <+> fixity - | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1 + | hasArgDocs -> header_ <+> ppOcc <+> fixity + | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts arg1 , ppOccInfix , ppLParendType unicode qual HideEmptyContexts arg2 , fixity @@ -958,17 +995,17 @@ -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -- ^ print explicit foralls - -> [Name] -- ^ type variables - -> HsContext DocNameI -- ^ context - -> Unicode -> Qualification -> Html +ppConstrHdr + :: Bool -- ^ print explicit foralls + -> [LHsTyVarBndr DocNameI] -- ^ type variables + -> HsContext DocNameI -- ^ context + -> Unicode -> Qualification + -> Html ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt where ppForall | null tvs || not forall_ = noHtml - | otherwise = forallSymbol unicode - <+> hsep (map (ppName Prefix) tvs) - <+> toHtml ". " + | otherwise = ppForAllPart unicode qual tvs ppCtxt | null ctxt = noHtml @@ -1096,6 +1133,11 @@ 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 +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 <> + ppLParendType unicode qual emptyCtxts ki +ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml "" ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) = ppDocName qual Raw False name @@ -1156,8 +1198,9 @@ ppr_mono_ty (HsBangTy _ b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty -ppr_mono_ty (HsTyVar _ _ (L _ name)) _ q _ = - ppDocName q Prefix True name +ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _ + | isPromoted prom = promoQuote (ppDocName q Prefix True name) + | otherwise = ppDocName q Prefix True name ppr_mono_ty (HsStarTy _ isUni) u _ _ = toHtml (if u || isUni then "★" else "*") ppr_mono_ty (HsFunTy _ ty1 ty2) u q e = @@ -1169,7 +1212,7 @@ ppr_mono_ty (HsSumTy _ tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys) ppr_mono_ty (HsKindSig _ ty kind) u q e = - parens (ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind) + ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts @@ -1179,7 +1222,7 @@ -- placeholder in the signature, which is followed by the field -- declarations. ppr_mono_ty (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty (HsExplicitListTy _ Promoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +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 @@ -1187,6 +1230,10 @@ = hsep [ ppr_mono_lty fun_ty unicode qual HideEmptyContexts , ppr_mono_lty arg_ty unicode qual HideEmptyContexts ] +ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode qual _ + = hsep [ppr_mono_lty fun_ty unicode qual HideEmptyContexts + , atSign unicode <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts] + ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _ = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts where @@ -1204,10 +1251,9 @@ ppr_mono_ty (HsDocTy _ ty _) unicode qual emptyCtxts = ppr_mono_lty ty unicode qual emptyCtxts -ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_' +ppr_mono_ty (HsWildCardTy _) _ _ _ = char '_' ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s) - diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -62,15 +62,15 @@ markupHyperlink = \(Hyperlink url mLabel) -> if insertAnchors then anchor ! [href url] - << fromMaybe url mLabel - else toHtml $ fromMaybe url mLabel, + << fromMaybe (toHtml url) mLabel + else fromMaybe (toHtml url) mLabel, markupAName = \aname -> if insertAnchors then namedAnchor aname << "" else noHtml, markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), - markupMathInline = \mathjax -> toHtml ("\\(" ++ mathjax ++ "\\)"), - markupMathDisplay = \mathjax -> toHtml ("\\[" ++ mathjax ++ "\\]"), + markupMathInline = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\(" ++ mathjax ++ "\\)"), + markupMathDisplay = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\[" ++ mathjax ++ "\\]"), markupProperty = pre . toHtml, markupExample = examplesToHtml, markupHeader = \(Header l t) -> makeHeader l t, @@ -171,12 +171,12 @@ -- extract/append the underlying 'Doc' and convert it to 'Html'. For -- 'CollapsingHeader', we attach extra info to the generated 'Html' -- that allows us to expand/collapse the content. -hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html +hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (Wrap (ModuleName, OccName)) id -> Html hackMarkup fmt' currPkg h' = let (html, ms) = hackMarkup' fmt' h' in html +++ renderMeta fmt' currPkg (metaConcat ms) where - hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id + hackMarkup' :: DocMarkup id Html -> Hack (Wrap (ModuleName, OccName)) id -> (Html, [Meta]) hackMarkup' fmt h = case h of UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) @@ -206,7 +206,7 @@ -- | Goes through 'hackMarkup' to generate the 'Html' rather than -- skipping straight to 'markup': this allows us to employ XHtml -- specific hacks to the tree first. -markupHacked :: DocMarkup id Html +markupHacked :: DocMarkup (Wrap id) Html -> Maybe Package -- this package -> Maybe String -> MDoc id @@ -220,7 +220,7 @@ -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docToHtml n pkg qual = markupHacked fmt pkg n . cleanup - where fmt = parHtmlMarkup qual True (ppDocName qual Raw) + where fmt = parHtmlMarkup qual True (ppWrappedDocName qual Raw) -- | Same as 'docToHtml' but it doesn't insert the 'anchor' element -- in links. This is used to generate the Contents box elements. @@ -228,16 +228,16 @@ -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup - where fmt = parHtmlMarkup qual False (ppDocName qual Raw) + where fmt = parHtmlMarkup qual False (ppWrappedDocName qual Raw) origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup - where fmt = parHtmlMarkup qual True (const $ ppName Raw) + where fmt = parHtmlMarkup qual True (const (ppWrappedName Raw)) rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup - where fmt = parHtmlMarkup qual True (const ppRdrName) + where fmt = parHtmlMarkup qual True (const (ppRdrName . unwrap)) docElement :: (Html -> Html) -> Html -> Html @@ -273,7 +273,7 @@ unParagraph (DocParagraph d) = d unParagraph doc = doc - fmtUnParagraphLists :: DocMarkup a (Doc a) + fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a) fmtUnParagraphLists = idMarkup { markupUnorderedList = DocUnorderedList . map unParagraph, markupOrderedList = DocOrderedList . map unParagraph diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -15,7 +15,7 @@ divPackageHeader, divContent, divModuleHeader, divFooter, divTableOfContents, divDescription, divSynopsis, divInterface, - divIndex, divAlphabet, divModuleList, + divIndex, divAlphabet, divModuleList, divContentsList, sectionName, nonEmptySectionName, @@ -35,6 +35,7 @@ subInstances, subOrphanInstances, subInstHead, subInstDetails, subFamInstDetails, subMethods, + subDefaults, subMinimal, topDeclElem, declElem, @@ -74,13 +75,13 @@ -- If it would have otherwise been empty, then give it the class ".empty". nonEmptySectionName :: Html -> Html nonEmptySectionName c - | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml - | otherwise = paragraph ! [theclass "caption"] $ c + | isNoHtml c = thespan ! [theclass "caption empty"] $ spaceHtml + | otherwise = thespan ! [theclass "caption"] $ c divPackageHeader, divContent, divModuleHeader, divFooter, divTableOfContents, divDescription, divSynopsis, divInterface, - divIndex, divAlphabet, divModuleList + divIndex, divAlphabet, divModuleList, divContentsList :: Html -> Html divPackageHeader = sectionDiv "package-header" @@ -88,6 +89,7 @@ divModuleHeader = sectionDiv "module-header" divFooter = sectionDiv "footer" divTableOfContents = sectionDiv "table-of-contents" +divContentsList = sectionDiv "contents-list" divDescription = sectionDiv "description" divSynopsis = sectionDiv "synopsis" divInterface = sectionDiv "interface" @@ -195,17 +197,18 @@ subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual --- | Generate sub table for instance declarations, with source +-- | Generate collapsible sub table for instance declarations, with source subInstances :: Maybe Package -> Qualification -> String -- ^ Class name, used for anchor generation -> LinksInfo -> Bool -> [(SubDecl, Maybe Module, Located DocName)] -> Html subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable where - wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents)) + wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents)) instTable = subTableSrc pkg qual lnks splice subSection = thediv ! [theclass "subs instances"] - summary = thesummary << "Instances" + hdr = h4 ! collapseControl id_ "instances" << "Instances" + summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Instances details" id_ = makeAnchorId $ "i:" ++ nm @@ -256,6 +259,9 @@ subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock + +subDefaults :: [Html] -> Html +subDefaults = divSubDecls "default" "" . subBlock subMinimal :: Html -> Html subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -13,7 +13,8 @@ module Haddock.Backends.Xhtml.Names ( ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, ppBinder, ppBinderInfix, ppBinder', - ppModule, ppModuleRef, ppIPName, linkId, Notation(..) + ppModule, ppModuleRef, ppIPName, linkId, Notation(..), + ppWrappedDocName, ppWrappedName, ) where @@ -24,7 +25,7 @@ import Text.XHtml hiding ( name, p, quote ) import qualified Data.Map as M -import qualified Data.List as List +import Data.List ( stripPrefix ) import GHC hiding (LexicalFixity(..)) import Name @@ -49,9 +50,11 @@ ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS -ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html -ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName - +ppUncheckedLink :: Qualification -> Wrap (ModuleName, OccName) -> Html +ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml + where + (mdl, occ) = unwrap x + occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName -- The Bool indicates if it is to be rendered in infix notation ppLDocName :: Qualification -> Notation -> Located DocName -> Html @@ -68,6 +71,19 @@ ppQualifyName qual notation name (nameModule name) | otherwise -> ppName notation name + +ppWrappedDocName :: Qualification -> Notation -> Bool -> Wrap DocName -> Html +ppWrappedDocName qual notation insertAnchors docName = case docName of + Unadorned n -> ppDocName qual notation insertAnchors n + Parenthesized n -> ppDocName qual Prefix insertAnchors n + Backticked n -> ppDocName qual Infix insertAnchors n + +ppWrappedName :: Notation -> Wrap Name -> Html +ppWrappedName notation docName = case docName of + Unadorned n -> ppName notation n + Parenthesized n -> ppName Prefix n + Backticked n -> ppName Infix n + -- | Render a name depending on the selected qualification mode ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html ppQualifyName qual notation name mdl = @@ -79,7 +95,7 @@ then ppName notation name else ppFullQualName notation mdl name RelativeQual localmdl -> - case List.stripPrefix (moduleString localmdl) (moduleString mdl) of + case stripPrefix (moduleString localmdl) (moduleString mdl) of -- local, A.x -> x Just [] -> ppName notation name -- sub-module, A.B.x -> B.x diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -58,7 +58,7 @@ standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir) --- | Default themes that are part of Haddock; added with --default-themes +-- | Default themes that are part of Haddock; added with @--built-in-themes@ -- The first theme in this list is considered the standard theme. -- Themes are "discovered" by scanning the html sub-dir of the libDir, -- and looking for directories with the extension .theme or .std-theme. diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -22,6 +22,7 @@ braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList, arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, + atSign, hsep, vcat, @@ -183,15 +184,15 @@ ubxparens :: Html -> Html -ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" +ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" -dcolon, arrow, darrow, forallSymbol :: Bool -> Html +dcolon, arrow, darrow, forallSymbol, atSign :: Bool -> Html dcolon unicode = toHtml (if unicode then "∷" else "::") arrow unicode = toHtml (if unicode then "→" else "->") darrow unicode = toHtml (if unicode then "⇒" else "=>") forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" - +atSign unicode = toHtml (if unicode then "@" else "@") dot :: Html dot = toHtml "." diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -12,12 +12,16 @@ -- Conversion between TyThing and HsDecl. This functionality may be moved into -- GHC at some point. ----------------------------------------------------------------------------- -module Haddock.Convert where --- Some other functions turned out to be useful for converting --- instance heads, which aren't TyThings, so just export everything. +module Haddock.Convert ( + tyThingToLHsDecl, + synifyInstHead, + synifyFamInst, + PrintRuntimeReps(..), +) where import Bag ( emptyBag ) -import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..) ) +import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..) + , PromotionFlag(..), DefMethSpec(..) ) import Class import CoAxiom import ConLike @@ -36,9 +40,10 @@ import Type import TyCoRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, liftedTypeKindTyConName, unitTy ) -import PrelNames ( hasKey, eqTyConKey, eqTyConName, ipClassKey - , tYPETyConKey, liftedRepDataConKey ) +import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName + , unitTy, promotedNilDataCon, promotedConsDataCon ) +import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey + , liftedRepDataConKey ) import Unique ( getUnique ) import Util ( chkAppend, compareLength, dropList, filterByList, filterOut , splitAtList ) @@ -47,12 +52,22 @@ import Haddock.Types import Haddock.Interface.Specialize +import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars ) +import Data.Maybe ( catMaybes, maybeToList ) +-- | Whether or not to default 'RuntimeRep' variables to 'LiftedRep'. Check +-- out Note [Defaulting RuntimeRep variables] in IfaceType.hs for the +-- motivation. +data PrintRuntimeReps = ShowRuntimeRep | HideRuntimeRep deriving Show + -- the main function here! yay! -tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl GhcRn)) -tyThingToLHsDecl t = case t of +tyThingToLHsDecl + :: PrintRuntimeReps + -> TyThing + -> Either ErrMsg ([ErrMsg], (HsDecl GhcRn)) +tyThingToLHsDecl prr t = case t of -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. -- Including built-in functions like seq. -- foreign-imported functions could be represented with ForD @@ -61,40 +76,60 @@ -- in a future code version we could turn idVarDetails = foreign-call -- into a ForD instead of a SigD if we wanted. Haddock doesn't -- need to care. - AnId i -> allOK $ SigD noExt (synifyIdSig ImplicitizeForAll i) + AnId i -> allOK $ SigD noExt (synifyIdSig prr ImplicitizeForAll [] i) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ATyCon tc | Just cl <- tyConClass_maybe tc -- classes are just a little tedious - -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a) - extractFamilyDecl (FamDecl _ d) = return $ noLoc d + -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (FamilyDecl a) + extractFamilyDecl (FamDecl _ d) = return d extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" - atTyClDecls = [synifyTyCon Nothing at_tc | ATI at_tc _ <- classATItems cl] - atFamDecls = map extractFamilyDecl (rights atTyClDecls) - tyClErrors = lefts atTyClDecls - famDeclErrors = lefts atFamDecls - in withErrs (tyClErrors ++ famDeclErrors) . TyClD noExt $ ClassDecl + extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltEqn GhcRn + extractFamDefDecl fd rhs = FamEqn + { feqn_ext = noExt + , feqn_tycon = fdLName fd + , feqn_bndrs = Nothing + -- TODO: this must change eventually + , feqn_pats = fdTyVars fd + , feqn_fixity = fdFixity fd + , feqn_rhs = synifyType WithinType [] rhs } + + extractAtItem + :: ClassATItem + -> Either ErrMsg (LFamilyDecl GhcRn, Maybe (LTyFamDefltEqn GhcRn)) + 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) + + atTyClDecls = map extractAtItem (classATItems cl) + (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls) + vs = tyConVisibleTyVars (classTyCon cl) + + in withErrs (lefts atTyClDecls) . TyClD noExt $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl - , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl)) - , tcdFixity = Prefix + , tcdTyVars = synifyTyVars vs + , tcdFixity = synifyFixity cl , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl , tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : - map (noLoc . synifyTcIdSig DeleteTopLevelQuantification) - (classMethods cl) + [ noLoc tcdSig + | clsOp <- classOpItems cl + , tcdSig <- synifyTcIdSig vs clsOp ] , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature -- class associated-types are a subset of TyCon: - , tcdATs = rights atFamDecls - , tcdATDefs = [] --ignore associated type defaults + , tcdATs = atFamDecls + , tcdATDefs = catMaybes atDefFamDecls , tcdDocs = [] --we don't have any docs at this point , tcdCExt = placeHolderNamesTc } | otherwise - -> synifyTyCon Nothing tc >>= allOK . TyClD noExt + -> synifyTyCon prr Nothing tc >>= allOK . TyClD noExt -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) @@ -102,7 +137,7 @@ -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD noExt (TypeSig noExt [synifyName dc] - (synifySigWcType ImplicitizeForAll (dataConUserType dc))) + (synifySigWcType ImplicitizeForAll [] (dataConUserType dc))) AConLike (PatSynCon ps) -> allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) @@ -114,16 +149,17 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc args_types_only = filterOutInvisibleTypes tc args - typats = map (synifyType WithinType) args_types_only + typats = map (synifyType WithinType []) args_types_only annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) args_types_only typats - hs_rhs = synifyType WithinType rhs - in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs - , hsib_closed = True } + hs_rhs = synifyType WithinType [] rhs + in HsIB { hsib_ext = map tyVarName tkvs , hsib_body = FamEqn { feqn_ext = noExt , feqn_tycon = name - , feqn_pats = annot_typats - , feqn_fixity = Prefix + , feqn_bndrs = Nothing + -- TODO: this must change eventually + , feqn_pats = map HsValArg annot_typats + , feqn_fixity = synifyFixity name , feqn_rhs = hs_rhs } } where fam_tvs = tyConVisibleTyVars tc @@ -138,42 +174,51 @@ | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error - = synifyTyCon (Just ax) tc >>= return . TyClD noExt + = synifyTyCon ShowRuntimeRep (Just ax) tc >>= return . TyClD noExt | otherwise = Left "synifyAxiom: closed/open family confusion" --- | Turn type constructors into type class declarations -synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl GhcRn) -synifyTyCon _coax tc +-- | Turn type constructors into data declarations, type families, or type synonyms +synifyTyCon + :: PrintRuntimeReps + -> Maybe (CoAxiom br) -- ^ RHS of type synonym + -> TyCon -- ^ type constructor to convert + -> Either ErrMsg (TyClDecl GhcRn) +synifyTyCon prr _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ DataDecl { tcdLName = synifyName tc - , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: - let mk_hs_tv realKind fakeTyVar - = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar)) - (synifyKindSig realKind) - in HsQTvs { hsq_ext = + , tcdTyVars = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = [] -- No kind polymorphism , hsq_dependent = emptyNameSet } - , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) - alphaTyVars --a, b, c... which are unfortunately all kind * + , hsq_explicit = zipWith mk_hs_tv + tyVarKinds + alphaTyVars --a, b, c... which are unfortunately all kind * } - , tcdFixity = Prefix + , tcdFixity = synifyFixity tc , tcdDataDefn = HsDataDefn { dd_ext = noExt , dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = noLoc [] , dd_cType = Nothing - , dd_kindSig = Just (synifyKindSig (tyConKind tc)) + , dd_kindSig = synifyDataTyConReturnKind tc -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = noLoc [] } , tcdDExt = DataDeclRn False placeHolderNamesTc } + where + -- tyConTyVars doesn't work on fun/prim, but we can make them up: + mk_hs_tv realKind fakeTyVar + | isLiftedTypeKind realKind = noLoc $ UserTyVar noExt (noLoc (getName fakeTyVar)) + | otherwise = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar)) (synifyKindSig realKind) -synifyTyCon _coax tc + conKind = defaultType prr (tyConKind tc) + tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind + +synifyTyCon _prr _coax tc | Just flav <- famTyConFlav_maybe tc = case flav of -- Type families @@ -197,7 +242,7 @@ , fdInfo = i , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConVisibleTyVars tc) - , fdFixity = Prefix + , fdFixity = synifyFixity tc , fdResultSig = synifyFamilyResultSig resultVar (tyConResKind tc) , fdInjectivityAnn = @@ -205,13 +250,13 @@ (tyConInjectivityInfo tc) } -synifyTyCon coax tc +synifyTyCon _prr coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdSExt = emptyNameSet , tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) - , tcdFixity = Prefix - , tcdRhs = synifyType WithinType ty } + , tcdFixity = synifyFixity tc + , tcdRhs = synifyType WithinType [] ty } | otherwise = -- (closed) newtype and data let @@ -239,7 +284,7 @@ -- That seems like an acceptable compromise (they'll just be documented -- in prefix position), since, otherwise, the logic (at best) gets much more -- complicated. (would use dataConIsInfix.) - use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc) + use_gadt_syntax = isGadtSyntaxTyCon tc consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. @@ -253,31 +298,31 @@ , dd_derivs = alg_deriv } in case lefts consRaw of [] -> return $ - DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix + DataDecl { tcdLName = name, tcdTyVars = tyvars + , tcdFixity = synifyFixity name , tcdDataDefn = defn , tcdDExt = DataDeclRn False placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs --- In this module, every TyCon being considered has come from an interface +-- | In this module, every TyCon being considered has come from an interface -- file. This means that when considering a data type constructor such as: -- --- data Foo (w :: *) (m :: * -> *) (a :: *) +-- > data Foo (w :: *) (m :: * -> *) (a :: *) -- -- Then its tyConKind will be (* -> (* -> *) -> * -> *). But beware! We are -- also rendering the type variables of Foo, so if we synify the tyConKind of -- Foo in full, we will end up displaying this in Haddock: -- --- data Foo (w :: *) (m :: * -> *) (a :: *) --- :: * -> (* -> *) -> * -> * +-- > data Foo (w :: *) (m :: * -> *) (a :: *) +-- > :: * -> (* -> *) -> * -> * -- --- Which is entirely wrong (#548). We only want to display the *return* kind, +-- Which is entirely wrong (#548). We only want to display the /return/ kind, -- which this function obtains. synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn) synifyDataTyConReturnKind tc - = case splitFunTys (tyConKind tc) of - (_, ret_kind) - | isLiftedTypeKind ret_kind -> Nothing -- Don't bother displaying :: * - | otherwise -> Just (synifyKindSig ret_kind) + | isLiftedTypeKind ret_kind = Nothing -- Don't bother displaying :: * + | otherwise = Just (synifyKindSig ret_kind) + where ret_kind = tyConResKind tc synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity -> Maybe (LInjectivityAnn GhcRn) @@ -288,8 +333,9 @@ in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn -synifyFamilyResultSig Nothing kind = - noLoc $ KindSig noExt (synifyKindSig kind) +synifyFamilyResultSig Nothing kind + | isLiftedTypeKind kind = noLoc $ NoSig noExt + | otherwise = noLoc $ KindSig noExt (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = noLoc $ TyVarSig noExt (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind)) @@ -307,14 +353,16 @@ use_named_field_syntax = not (null field_tys) name = synifyName dc -- con_qvars means a different thing depending on gadt-syntax - (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc + (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc + user_tvs = dataConUserTyVars dc -- Used for GADT data constructors -- skip any EqTheta, use 'orig'inal syntax - ctx = synifyCtx theta + ctx | null theta = Nothing + | otherwise = Just $ synifyCtx theta linear_tys = zipWith (\ty bang -> - let tySyn = synifyType WithinType ty + let tySyn = synifyType WithinType [] ty in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn bang' -> noLoc $ HsBangTy noExt bang' tySyn) @@ -338,33 +386,55 @@ then return $ noLoc $ ConDeclGADT { con_g_ext = noExt , con_names = [name] - , con_forall = noLoc True - , con_qvars = synifyTyVars (univ_tvs ++ ex_tvs) - , con_mb_cxt = Just ctx - , con_args = hat - , con_res_ty = synifyType WithinType res_ty - , con_doc = Nothing } + , con_forall = noLoc $ not $ null user_tvs + , con_qvars = synifyTyVars user_tvs + , con_mb_cxt = ctx + , con_args = hat + , con_res_ty = synifyType WithinType [] res_ty + , con_doc = Nothing } else return $ noLoc $ ConDeclH98 { con_ext = noExt , con_name = name - , con_forall = noLoc True + , con_forall = noLoc False , con_ex_tvs = map synifyTyVar ex_tvs - , con_mb_cxt = Just ctx + , con_mb_cxt = ctx , con_args = hat , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name synifyName n = L (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. +synifyFixity :: NamedThing n => n -> LexicalFixity +synifyFixity n | isSymOcc (getOccName n) = Infix + | otherwise = Prefix -synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyIdSig s i = TypeSig noExt [synifyName i] (synifySigWcType s (varType i)) +synifyIdSig + :: PrintRuntimeReps -- ^ are we printing tyvars of kind 'RuntimeRep'? + -> SynifyTypeState -- ^ what to do with a 'forall' + -> [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 noExt [synifyName i] (synifySigWcType s vs t) + where + t = defaultType prr (varType i) -synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyTcIdSig s i = ClassOpSig noExt False [synifyName i] (synifySigType s (varType i)) +-- | Turn a 'ClassOpItem' into a list of signatures. The list returned is going +-- to contain the synified 'ClassOpSig' as well (when appropriate) a default +-- 'ClassOpSig'. +synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn] +synifyTcIdSig vs (i, dm) = + [ ClassOpSig noExt False [synifyName i] (mainSig (varType i)) ] ++ + [ ClassOpSig noExt True [noLoc 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 = noLoc . map (synifyType WithinType []) synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn @@ -373,13 +443,20 @@ , hsq_explicit = map synifyTyVar ktvs } synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn -synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar noExt (noLoc name)) - | otherwise = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind)) +synifyTyVar = synifyTyVar' emptyVarSet + +-- | Like 'synifyTyVar', but accepts a set of variables for which to omit kind +-- signatures (even if they don't have the lifted type kind). +synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr GhcRn +synifyTyVar' no_kinds tv + | isLiftedTypeKind kind || tv `elemVarSet` no_kinds + = noLoc (UserTyVar noExt (noLoc name)) + | otherwise = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv + -- | Annotate (with HsKingSig) a type if the first parameter is True -- and if the type contains a free variable. -- This is used to synify type patterns for poly-kinded tyvars in @@ -391,7 +468,7 @@ annotHsType True ty hs_ty | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty = let ki = typeKind ty - hs_ki = synifyType WithinType ki + hs_ki = synifyType WithinType [] ki in noLoc (HsKindSig noExt hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty @@ -414,7 +491,8 @@ -- quite understand what's going on. | ImplicitizeForAll -- ^ beginning of a function definition, in which, to make it look - -- less ugly, those rank-1 foralls are made implicit. + -- less ugly, those rank-1 foralls (without kind annotations) are made + -- implicit. | DeleteTopLevelQuantification -- ^ because in class methods the context is added to the type -- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@) @@ -423,22 +501,33 @@ -- the defining class gets to quantify all its functions for free! -synifySigType :: SynifyTypeState -> Type -> LHsSigType GhcRn +synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn -- The empty binders is a bit suspicious; -- what if the type has free variables? -synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty) +synifySigType s vs ty = mkEmptyImplicitBndrs (synifyType s vs ty) -synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType GhcRn +synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) -synifySigWcType s ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s ty)) +synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s vs ty)) synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType) synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) -synifyType :: SynifyTypeState -> Type -> LHsType GhcRn -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv) -synifyType _ (TyConApp tc tys) +-- | Depending on the first argument, try to default all type variables of kind +-- 'RuntimeRep' to 'LiftedType'. +defaultType :: PrintRuntimeReps -> Type -> Type +defaultType ShowRuntimeRep = id +defaultType HideRuntimeRep = defaultRuntimeRepVars + +-- | Convert a core type into an 'HsType'. +synifyType + :: SynifyTypeState -- ^ what to do with a 'forall' + -> [TyVar] -- ^ free variables in the type to convert + -> Type -- ^ the type to convert + -> LHsType GhcRn +synifyType _ _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv) +synifyType _ vs (TyConApp tc tys) = maybe_sig res_ty where res_ty :: LHsType GhcRn @@ -456,39 +545,55 @@ BoxedTuple -> HsBoxedTuple ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) - (map (synifyType WithinType) vis_tys) + (map (synifyType WithinType vs) vis_tys) + | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType vs) vis_tys) + | Just dc <- isPromotedDataCon_maybe tc + , isTupleDataCon dc + , dataConSourceArity dc == length vis_tys + = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType vs) vis_tys) -- ditto for lists - | getName tc == listTyConName, [ty] <- tys = - noLoc $ HsListTy noExt (synifyType WithinType ty) + | getName tc == listTyConName, [ty] <- vis_tys = + noLoc $ HsListTy noExt (synifyType WithinType vs ty) + | tc == promotedNilDataCon, [] <- vis_tys + = noLoc $ HsExplicitListTy noExt 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 noExt IsPromoted (hTy : tTy') + | otherwise + -> noLoc $ HsOpTy noExt hTy (noLoc $ getName tc) tTy -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name - = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType ty) + = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType vs ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys = noLoc $ HsOpTy noExt - (synifyType WithinType ty1) + (synifyType WithinType vs ty1) (noLoc eqTyConName) - (synifyType WithinType ty2) + (synifyType WithinType vs ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) , ty1:ty2:tys_rest <- vis_tys = mk_app_tys (HsOpTy noExt - (synifyType WithinType ty1) + (synifyType WithinType vs ty1) (noLoc $ getName tc) - (synifyType WithinType ty2)) + (synifyType WithinType vs ty2)) tys_rest -- Most TyCons: | otherwise - = mk_app_tys (HsTyVar noExt NotPromoted $ noLoc (getName tc)) + = mk_app_tys (HsTyVar noExt prom $ noLoc (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 noExt t1 t2) (noLoc ty_app) - (map (synifyType WithinType) $ + (map (synifyType WithinType vs) $ filterOut isCoercionTy ty_args) vis_tys = filterOutInvisibleTypes tc tys @@ -499,7 +604,7 @@ maybe_sig ty' | needs_kind_sig = let full_kind = typeKind (mkTyConApp tc tys) - full_kind' = synifyType WithinType full_kind + full_kind' = synifyType WithinType vs full_kind in noLoc $ HsKindSig noExt ty' full_kind' | otherwise = ty' @@ -517,76 +622,174 @@ in not (subVarSet result_vars dropped_vars) -synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 -synifyType _ (AppTy t1 t2) = let - s1 = synifyType WithinType t1 - s2 = synifyType WithinType t2 +synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1 +synifyType _ vs (AppTy t1 t2) = let + s1 = synifyType WithinType vs t1 + s2 = synifyType WithinType vs t2 in noLoc $ HsAppTy noExt s1 s2 -synifyType _ (FunTy t1 t2) = let - s1 = synifyType WithinType t1 - s2 = synifyType WithinType t2 - in noLoc $ HsFunTy noExt s1 s2 -synifyType s forallty@(ForAllTy _tv _ty) = - let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms forallty +synifyType s vs funty@(FunTy t1 t2) + | isPredTy t1 = synifyForAllType s vs funty + | otherwise = let s1 = synifyType WithinType vs t1 + s2 = synifyType WithinType vs t2 + in noLoc $ HsFunTy noExt s1 s2 +synifyType s vs forallty@(ForAllTy _tv _ty) = synifyForAllType s vs forallty + +synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t +synifyType s vs (CastTy t _) = synifyType s vs t +synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" + +-- | Process a 'Type' which starts with a forall or a constraint into +-- an 'HsType' +synifyForAllType + :: SynifyTypeState -- ^ what to do with the 'forall' + -> [TyVar] -- ^ free variables in the type to convert + -> Type -- ^ the forall type to convert + -> LHsType GhcRn +synifyForAllType s vs ty = + let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx - , hst_xqual = noExt - , hst_body = synifyType WithinType tau } + , hst_xqual = noExt + , hst_body = synifyType WithinType (tvs' ++ vs) tau } + + sTy = HsForAllTy { hst_bndrs = sTvs + , hst_xforall = noExt + , hst_body = noLoc sPhi } + + sTvs = map synifyTyVar tvs + + -- Figure out what the type variable order would be inferred in the + -- absence of an explicit forall + tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau]) + in case s of - DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau - WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs - , hst_xforall = noExt - , hst_body = noLoc sPhi } - ImplicitizeForAll -> noLoc sPhi + DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (tvs' ++ vs) tau -synifyType _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t -synifyType s (CastTy t _) = synifyType s t -synifyType _ (CoercionTy {}) = error "synifyType:Coercion" + -- Put a forall in if there are any type variables + WithinType + | not (null tvs) -> noLoc sTy + | otherwise -> noLoc sPhi + ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau + + +-- | Put a forall in if there are any type variables which require +-- explicit kind annotations or if the inferred type variable order +-- would be different. +implicitForAll + :: [TyCon] -- ^ type constructors that determine their args kinds + -> [TyVar] -- ^ free variables in the type to convert + -> [TyVar] -- ^ type variable binders in the forall + -> ThetaType -- ^ constraints right after the forall + -> ([TyVar] -> Type -> LHsType GhcRn) -- ^ how to convert the inner type + -> Type -- ^ inner type + -> LHsType GhcRn +implicitForAll tycons vs tvs ctx synInner tau + | any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy + | tvs' /= tvs = noLoc sTy + | otherwise = noLoc sPhi + where + sRho = synInner (tvs' ++ vs) tau + sPhi | null ctx = unLoc sRho + | otherwise + = HsQualTy { hst_ctxt = synifyCtx ctx + , hst_xqual = noExt + , hst_body = synInner (tvs' ++ vs) tau } + sTy = HsForAllTy { hst_bndrs = sTvs + , hst_xforall = noExt + , hst_body = noLoc sPhi } + + no_kinds_needed = noKindTyVars tycons tau + sTvs = map (synifyTyVar' no_kinds_needed) tvs + + -- Figure out what the type variable order would be inferred in the + -- absence of an explicit forall + tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau]) + + + +-- | Find the set of type variables whose kind signatures can be properly +-- inferred just from their uses in the type signature. This means the type +-- variable to has at least one fully applied use @f x1 x2 ... xn@ where: +-- +-- * @f@ has a function kind where the arguments have the same kinds +-- as @x1 x2 ... xn@. +-- +-- * @f@ has a function kind whose final return has lifted type kind +-- +noKindTyVars + :: [TyCon] -- ^ type constructors that determine their args kinds + -> Type -- ^ type to inspect + -> VarSet -- ^ set of variables whose kinds can be inferred from uses in the type +noKindTyVars _ (TyVarTy var) + | isLiftedTypeKind (tyVarKind var) = unitVarSet var +noKindTyVars ts ty + | (f, xs) <- splitAppTys ty + , not (null xs) + = let args = map (noKindTyVars ts) xs + func = case f of + TyVarTy var | (xsKinds, outKind) <- splitFunTys (tyVarKind var) + , xsKinds `eqTypes` map typeKind xs + , isLiftedTypeKind outKind + -> unitVarSet var + TyConApp t ks | t `elem` ts + , all noFreeVarsOfType ks + -> mkVarSet [ v | TyVarTy v <- xs ] + _ -> noKindTyVars ts f + in unionVarSets (func : args) +noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t +noKindTyVars ts (FunTy t1 t2) = noKindTyVars ts t1 `unionVarSet` noKindTyVars ts t2 +noKindTyVars ts (CastTy t _) = noKindTyVars ts t +noKindTyVars _ _ = emptyVarSet + synifyPatSynType :: PatSyn -> LHsType GhcRn -synifyPatSynType ps = let - (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps - req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy] - -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>", - -- i.e., an explicit empty context, which is what we need. This is not - -- possible by taking theta = [], as that will print no context at all - | otherwise = req_theta - sForAll [] s = s - sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs - , hst_xforall = noExt - , hst_body = noLoc s } - sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta - , hst_xqual = noExt - , hst_body = noLoc s } - sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty - in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau +synifyPatSynType ps = + let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps + ts = maybeToList (tyConAppTyCon_maybe res_ty) + -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>", + -- i.e., an explicit empty context, which is what we need. This is not + -- possible by taking theta = [], as that will print no context at all + req_theta' | null req_theta + , not (null prov_theta && null ex_tvs) + = [unitTy] + | otherwise = req_theta + + in implicitForAll ts [] (univ_tvs ++ ex_tvs) req_theta' + (\vs -> implicitForAll ts vs [] prov_theta (synifyType WithinType)) + (mkFunTys arg_tys res_ty) + synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s synifyKindSig :: Kind -> LHsKind GhcRn -synifyKindSig k = synifyType WithinType k +synifyKindSig k = synifyType WithinType [] k +stripKindSig :: LHsType GhcRn -> LHsType GhcRn +stripKindSig (L _ (HsKindSig _ t _)) = t +stripKindSig t = t + synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn -synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead +synifyInstHead (vs, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls , ihdTypes = map unLoc annot_ts , ihdInstType = ClassInst - { clsiCtx = map (unLoc . synifyType WithinType) preds + { clsiCtx = map (unLoc . synifyType WithinType []) preds , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon) , clsiSigs = map synifyClsIdSig $ classMethods cls , clsiAssocTys = do - (Right (FamDecl _ fam)) <- map (synifyTyCon Nothing) $ classATs cls + (Right (FamDecl _ fam)) <- map (synifyTyCon HideRuntimeRep Nothing) + (classATs cls) pure $ mkPseudoFamilyDecl fam } } where cls_tycon = classTyCon cls ts = filterOutInvisibleTypes cls_tycon types - ts' = map (synifyType WithinType) ts + ts' = map (synifyType WithinType vs) ts annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon) - synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification + synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs -- Convert a family instance, this could be a type family or data family synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn) @@ -600,9 +803,9 @@ where ityp SynFamilyInst | opaque = return $ TypeInst Nothing ityp SynFamilyInst = - return . TypeInst . Just . unLoc $ synifyType WithinType fam_rhs + return . TypeInst . Just . unLoc $ synifyType WithinType [] fam_rhs ityp (DataFamilyInst c) = - DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c + DataInst <$> synifyTyCon HideRuntimeRep (Just $ famInstAxiom fi) c fam_tc = famInstTyCon fi fam_flavor = fi_flavor fi fam_lhs = fi_tys fi @@ -622,7 +825,7 @@ = fam_lhs ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs - synifyTypes = map (synifyType WithinType) + synifyTypes = map (synifyType WithinType []) ts' = synifyTypes ts annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc) @@ -652,8 +855,8 @@ tcSplitForAllTysPreserveSynonyms :: Type -> ([TyVar], Type) tcSplitForAllTysPreserveSynonyms ty = split ty ty [] where - split _ (ForAllTy (TvBndr tv _) ty') tvs = split ty' ty' (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) + split _ (ForAllTy (Bndr tv _) ty') tvs = split ty' ty' (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) -- | See Note [Invariant: Never expand type synonyms] tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -18,37 +19,44 @@ import Control.Arrow +import Data.Char ( isSpace ) + import Haddock.Types( DocNameI ) import Exception -import Outputable +import FV +import Outputable ( Outputable, panic, showPpr ) import Name import NameSet -import Lexeme import Module import HscTypes import GHC import Class import DynFlags +import SrcLoc ( advanceSrcLoc ) +import Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind, + isInvisibleArgFlag ) +import VarSet ( VarSet, emptyVarSet ) +import VarEnv ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) +import TyCoRep ( Type(..), isRuntimeRepVar ) +import TysWiredIn( liftedRepDataConTyCon ) -import HsTypes (HsType(..)) +import StringBuffer ( StringBuffer ) +import qualified StringBuffer as S +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BS + moduleString :: Module -> String moduleString = moduleNameString . moduleName isNameSym :: Name -> Bool isNameSym = isSymOcc . nameOccName - -isVarSym :: OccName -> Bool -isVarSym = isLexVarSym . occNameFS - -isConSym :: OccName -> Bool -isConSym = isLexConSym . occNameFS - - -getMainDeclBinder :: HsDecl name -> [IdP name] +getMainDeclBinder :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => + HsDecl p -> [IdP p] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of @@ -141,12 +149,6 @@ isValD (ValD _ _) = True isValD _ = False - -declATs :: HsDecl a -> [IdP a] -declATs (TyClD _ d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d -declATs _ = [] - - pretty :: Outputable a => DynFlags -> a -> String pretty = showPpr @@ -237,6 +239,8 @@ data Precedence = PREC_TOP -- ^ precedence of 'type' production in GHC's parser + | PREC_SIG -- ^ explicit type signature + | PREC_CTX -- ^ Used for single contexts, eg. ctx => type -- (as opposed to (ctx1, ctx2) => type) @@ -263,22 +267,27 @@ 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 _ (HsKindSig x ty kind) = HsKindSig x (reparenLType ty) (reparenLType kind) go _ (HsListTy x ty) = HsListTy x (reparenLType ty) go _ (HsRecTy x flds) = HsRecTy x (map (fmap 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) + go p (HsKindSig x ty kind) + = paren p PREC_SIG $ HsKindSig x (goL PREC_SIG ty) (goL PREC_SIG kind) go p (HsIParamTy x n ty) - = paren p PREC_CTX $ HsIParamTy x n (reparenLType ty) + = paren p PREC_SIG $ HsIParamTy x n (reparenLType ty) go p (HsForAllTy x tvs ty) = paren p PREC_CTX $ HsForAllTy x (map (fmap reparenTyVar) tvs) (reparenLType ty) go p (HsQualTy x ctxt ty) - = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType 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) go p (HsFunTy x ty1 ty2) = paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2) go p (HsAppTy x fun_ty arg_ty) = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty) + go p (HsAppKindTy x fun_ty arg_ki) + = 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 @@ -426,13 +435,230 @@ ------------------------------------------------------------------------------- -setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags +setObjectDir, setHiDir, setHieDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags setObjectDir f d = d{ objectDir = Just f} setHiDir f d = d{ hiDir = Just f} +setHieDir f d = d{ hieDir = Just f} setStubDir f d = d{ stubDir = Just f , includePaths = addGlobalInclude (includePaths d) [f] } -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file -- \#included from the .hc file when compiling with -fvia-C. -setOutputDir f = setObjectDir f . setHiDir f . setStubDir f +setOutputDir f = setObjectDir f . setHiDir f . setHieDir f . setStubDir f + +------------------------------------------------------------------------------- +-- * 'StringBuffer' and 'ByteString' +------------------------------------------------------------------------------- +-- We get away with a bunch of these functions because 'StringBuffer' and +-- 'ByteString' have almost exactly the same structure. + +-- | Convert a UTF-8 encoded 'ByteString' into a 'StringBuffer. This really +-- relies on the internals of both 'ByteString' and 'StringBuffer'. +-- +-- /O(n)/ (but optimized into a @memcpy@ by @bytestring@ under the hood) +stringBufferFromByteString :: ByteString -> StringBuffer +stringBufferFromByteString bs = + let BS.PS fp off len = bs <> BS.pack [0,0,0] + in S.StringBuffer { S.buf = fp, S.len = len - 3, S.cur = off } + +-- | Take the first @n@ /bytes/ of the 'StringBuffer' and put them in a +-- 'ByteString'. +-- +-- /O(1)/ +takeStringBuffer :: Int -> StringBuffer -> ByteString +takeStringBuffer !n !(S.StringBuffer fp _ cur) = BS.PS fp cur n + +-- | Return the prefix of the first 'StringBuffer' that /isn't/ in the second +-- 'StringBuffer'. **The behavior is undefined if the 'StringBuffers' use +-- separate buffers.** +-- +-- /O(1)/ +splitStringBuffer :: StringBuffer -> StringBuffer -> ByteString +splitStringBuffer buf1 buf2 = takeStringBuffer n buf1 + where n = S.byteDiff buf1 buf2 + +-- | Split the 'StringBuffer' at the next newline (or the end of the buffer). +-- Also: initial position is passed in and the updated position is returned. +-- +-- /O(n)/ (but /O(1)/ space) +spanLine :: RealSrcLoc -> StringBuffer -> (ByteString, RealSrcLoc, StringBuffer) +spanLine !loc !buf = go loc buf + where + + go !l !b + | not (S.atEnd b) + = case S.nextChar b of + ('\n', b') -> (splitStringBuffer buf b', advanceSrcLoc l '\n', b') + (c, b') -> go (advanceSrcLoc l c) b' + | otherwise + = (splitStringBuffer buf b, advanceSrcLoc l '\n', b) + +-- | Given a start position and a buffer with that start position, split the +-- buffer at an end position. +-- +-- /O(n)/ (but /O(1)/ space) +spanPosition :: RealSrcLoc -- ^ start of buffeer + -> RealSrcLoc -- ^ position until which to take + -> StringBuffer -- ^ buffer from which to take + -> (ByteString, StringBuffer) +spanPosition !start !end !buf = go start buf + where + + go !l !b + | l < end + , not (S.atEnd b) + , (c, b') <- S.nextChar b + = go (advanceSrcLoc l c) b' + | otherwise + = (splitStringBuffer buf b, b) + +-- | Try to parse a line of CPP from the from of the buffer. A \"line\" of CPP +-- consists of +-- +-- * at most 10 whitespace characters, including at least one newline +-- * a @#@ character +-- * keep parsing lines until you find a line not ending in @\\@. +-- +-- This is chock full of heuristics about what a line of CPP is. +-- +-- /O(n)/ (but /O(1)/ space) +tryCppLine :: RealSrcLoc -> StringBuffer -> Maybe (ByteString, RealSrcLoc, StringBuffer) +tryCppLine !loc !buf = spanSpace (S.prevChar buf '\n' == '\n') loc buf + where + + -- Keep consuming space characters until we hit either a @#@ or something + -- else. If we hit a @#@, start parsing CPP + spanSpace !seenNl !l !b + | S.atEnd b + = Nothing + | otherwise + = case S.nextChar b of + ('#' , b') | not (S.atEnd b') + , ('-', b'') <- S.nextChar b' + , ('}', _) <- S.nextChar b'' + -> Nothing -- Edge case exception for @#-}@ + | seenNl + -> Just (spanCppLine (advanceSrcLoc l '#') b') -- parse CPP + | otherwise + -> Nothing -- We didn't see a newline, so this can't be CPP! + + (c , b') | isSpace c -> spanSpace (seenNl || c == '\n') + (advanceSrcLoc l c) b' + | otherwise -> Nothing + + -- Consume a CPP line to its "end" (basically the first line that ends not + -- with a @\@ character) + spanCppLine !l !b + | S.atEnd b + = (splitStringBuffer buf b, l, b) + | otherwise + = case S.nextChar b of + ('\\', b') | not (S.atEnd b') + , ('\n', b'') <- S.nextChar b' + -> spanCppLine (advanceSrcLoc (advanceSrcLoc l '\\') '\n') b'' + + ('\n', b') -> (splitStringBuffer buf b', advanceSrcLoc l '\n', b') + + (c , b') -> spanCppLine (advanceSrcLoc l c) b' + +------------------------------------------------------------------------------- +-- * Free variables of a 'Type' +------------------------------------------------------------------------------- + +-- | Get free type variables in a 'Type' in their order of appearance. +-- See [Ordering of implicit variables]. +orderedFVs + :: VarSet -- ^ free variables to ignore + -> [Type] -- ^ types to traverse (in order) looking for free variables + -> [TyVar] -- ^ free type variables, in the order they appear in +orderedFVs vs tys = + reverse . fst $ tyCoFVsOfTypes' tys (const True) vs ([], emptyVarSet) + + +-- See the "Free variables of types and coercions" section in 'TyCoRep', or +-- check out Note [Free variables of types]. The functions in this section +-- don't output type variables in the order they first appear in in the 'Type'. +-- +-- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type +-- of 'const :: a -> b -> a': +-- +-- >>> import Name +-- >>> import TyCoRep +-- >>> import TysPrim +-- >>> import Var +-- >>> a = TyVarTy alphaTyVar +-- >>> b = TyVarTy betaTyVar +-- >>> constTy = mkFunTys [a, b] a +-- >>> map (getOccString . tyVarName) (tyCoVarsOfTypeList constTy) +-- ["b","a"] +-- +-- However, we want to reuse the very optimized traversal machinery there, so +-- so we make our own `tyCoFVsOfType'`, `tyCoFVsBndr'`, and `tyCoVarsOfTypes'`. +-- All these do differently is traverse in a different order and ignore +-- coercion variables. + +-- | Just like 'tyCoFVsOfType', but traverses type variables in reverse order +-- of appearance. +tyCoFVsOfType' :: Type -> FV +tyCoFVsOfType' (TyVarTy v) a b c = (FV.unitFV v `unionFV` tyCoFVsOfType' (tyVarKind v)) a b c +tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c +tyCoFVsOfType' (LitTy {}) a b c = emptyFV a b c +tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c +tyCoFVsOfType' (FunTy arg res) a b c = (tyCoFVsOfType' res `unionFV` tyCoFVsOfType' arg) a b c +tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty) a b c +tyCoFVsOfType' (CastTy ty _) a b c = (tyCoFVsOfType' ty) a b c +tyCoFVsOfType' (CoercionTy _ ) a b c = emptyFV a b c + +-- | Just like 'tyCoFVsOfTypes', but traverses type variables in reverse order +-- of appearance. +tyCoFVsOfTypes' :: [Type] -> FV +tyCoFVsOfTypes' (ty:tys) fv_cand in_scope acc = (tyCoFVsOfTypes' tys `unionFV` tyCoFVsOfType' ty) fv_cand in_scope acc +tyCoFVsOfTypes' [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +-- | Just like 'tyCoFVsBndr', but traverses type variables in reverse order of +-- appearance. +tyCoFVsBndr' :: TyVarBinder -> FV -> FV +tyCoFVsBndr' (Bndr tv _) fvs = FV.delFV tv fvs `unionFV` tyCoFVsOfType' (tyVarKind tv) + + +------------------------------------------------------------------------------- +-- * Defaulting RuntimeRep variables +------------------------------------------------------------------------------- + +-- | Traverses the type, defaulting type variables of kind 'RuntimeRep' to +-- 'LiftedType'. See 'defaultRuntimeRepVars' in IfaceType.hs the original such +-- function working over `IfaceType`'s. +defaultRuntimeRepVars :: Type -> Type +defaultRuntimeRepVars = go emptyVarEnv + where + go :: TyVarEnv () -> Type -> Type + go subs (ForAllTy (Bndr var flg) ty) + | isRuntimeRepVar var + , isInvisibleArgFlag flg + = let subs' = extendVarEnv subs var () + in go subs' ty + | otherwise + = ForAllTy (Bndr (updateTyVarKind (go subs) var) flg) + (go subs ty) + + go subs (TyVarTy tv) + | tv `elemVarEnv` subs + = TyConApp liftedRepDataConTyCon [] + | otherwise + = TyVarTy (updateTyVarKind (go subs) tv) + + go subs (TyConApp tc tc_args) + = TyConApp tc (map (go subs) tc_args) + + go subs (FunTy arg res) + = FunTy (go subs arg) (go subs res) + + go subs (AppTy t u) + = AppTy (go subs t) (go subs u) + + go subs (CastTy x co) + = CastTy (go subs x) co + + go _ ty@(LitTy {}) = ty + go _ ty@(CoercionTy {}) = ty diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -43,27 +43,24 @@ import Haddock.Utils import Control.Monad +import Control.Exception (evaluate) import Data.List import qualified Data.Map as Map import qualified Data.Set as Set -import Distribution.Verbosity -import System.Directory -import System.FilePath import Text.Printf import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) import Digraph import DynFlags hiding (verbosity) -import Exception import GHC hiding (verbosity) import HscTypes import FastString (unpackFS) -import MonadUtils (liftIO) import TcRnTypes (tcg_rdr_env) import Name (nameIsFromExternalPackage, nameOccName) import OccName (isTcOcc) import RdrName (unQualOK, gre_name, globalRdrEnvElts) import ErrUtils (withTiming) +import DynamicLoading (initializePlugins) #if defined(mingw32_HOST_OS) import System.IO @@ -91,7 +88,7 @@ out verbosity verbose "Creating interfaces..." let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces , iface <- ifInstalledIfaces ext ] - (interfaces, ms) <- createIfaces0 verbosity modules flags instIfaceMap + (interfaces, ms) <- createIfaces verbosity modules flags instIfaceMap let exportedNames = Set.unions $ map (Set.fromList . ifaceExports) $ @@ -124,39 +121,15 @@ -------------------------------------------------------------------------------- -createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet) -createIfaces0 verbosity modules flags instIfaceMap = - -- Output dir needs to be set before calling depanal since depanal uses it to - -- compute output file names that are stored in the DynFlags of the - -- resulting ModSummaries. - (if useTempDir then withTempOutputDir else id) $ do - modGraph <- depAnalysis - createIfaces verbosity flags instIfaceMap modGraph - - where - useTempDir :: Bool - useTempDir = Flag_NoTmpCompDir `notElem` flags - - - withTempOutputDir :: Ghc a -> Ghc a - withTempOutputDir action = do - tmp <- liftIO getTemporaryDirectory - x <- liftIO getProcessID - let dir = tmp ".haddock-" ++ show x - modifySessionDynFlags (setOutputDir dir) - withTempDir dir action - - - depAnalysis :: Ghc ModuleGraph - depAnalysis = do - targets <- mapM (\f -> guessTarget f Nothing) modules - setTargets targets - depanal [] False - +createIfaces :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet) +createIfaces verbosity modules flags instIfaceMap = do + -- Ask GHC to tell us what the module graph is + targets <- mapM (\filePath -> guessTarget filePath Nothing) modules + setTargets targets + modGraph <- depanal [] False -createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc ([Interface], ModuleSet) -createIfaces verbosity flags instIfaceMap mods = do - let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing + -- Visit modules in that order + let sortedMods = flattenSCCs $ topSortModuleGraph False modGraph Nothing out verbosity normal "Haddock coverage:" (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods return (reverse ifaces, ms) @@ -177,8 +150,14 @@ processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet)) processModule verbosity modsum flags modMap instIfaceMap = do out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." - tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum + -- Since GHC 8.6, plugins are initialized on a per module basis + hsc_env' <- getSession + dynflags' <- liftIO (initializePlugins hsc_env' (GHC.ms_hspp_opts modsum)) + let modsum' = modsum { ms_hspp_opts = dynflags' } + + tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum' + if not $ isBootSummary modsum then do out verbosity verbose "Creating interface..." (interface, msgs) <- {-# SCC createIterface #-} @@ -264,12 +243,3 @@ keep_old env n = Map.insertWith (\_ old -> old) n mdl env keep_new env n = Map.insert n mdl env - --------------------------------------------------------------------------------- --- * Utils --------------------------------------------------------------------------------- - - -withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a -withTempDir dir = gbracket_ (liftIO $ createDirectory dir) - (liftIO $ removeDirectoryRecursive dir) diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, MagicHash, BangPatterns #-} +{-# LANGUAGE MagicHash, BangPatterns #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -19,6 +19,7 @@ import Haddock.Convert import Haddock.GhcUtils +import Control.Applicative ((<|>)) import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) @@ -31,7 +32,6 @@ import CoreSyn (isOrphan) import ErrUtils import FamInstEnv -import FastString import GHC import InstEnv import Module ( ModuleSet, moduleSetElts ) @@ -39,13 +39,11 @@ import Name import NameEnv import Outputable (text, sep, (<+>)) -import PrelNames import SrcLoc import TyCon import TyCoRep -import TysPrim( funTyCon ) +import TysPrim( funTyConName ) import Var hiding (varName) -#define FSLIT(x) (mkFastString# (x#)) type ExportedNames = Set.Set Name type Modules = Set.Set Module @@ -63,16 +61,24 @@ ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ] attach index iface = do - newItems <- mapM (attachToExportItem index expInfo iface ifaceMap instIfaceMap) + + let getInstDoc = findInstDoc iface ifaceMap instIfaceMap + getFixity = findFixity iface ifaceMap instIfaceMap + + newItems <- mapM (attachToExportItem index expInfo getInstDoc getFixity) (ifaceExportItems iface) - let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface) + let orphanInstances = attachOrphanInstances expInfo getInstDoc (ifaceInstances iface) return $ iface { ifaceExportItems = newItems , ifaceOrphanInstances = orphanInstances } -attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn] -attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = - [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n), Nothing) +attachOrphanInstances + :: ExportInfo + -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance + -> [ClsInst] -- ^ a list of orphan instances + -> [DocInstance GhcRn] +attachOrphanInstances expInfo getInstDoc cls_instances = + [ (synifyInstHead i, getInstDoc n, (L (getSrcSpan n) n), Nothing) | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys @@ -80,40 +86,40 @@ attachToExportItem - :: NameEnv ([ClsInst], [FamInst]) + :: NameEnv ([ClsInst], [FamInst]) -- ^ all instances (that we know of) -> ExportInfo - -> Interface - -> IfaceMap - -> InstIfaceMap + -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance + -> (Name -> Maybe Fixity) -- ^ how to lookup a fixity -> ExportItem GhcRn -> Ghc (ExportItem GhcRn) -attachToExportItem index expInfo iface ifaceMap instIfaceMap export = +attachToExportItem index expInfo getInstDoc getFixity export = case attachFixities export of e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do insts <- let mb_instances = lookupNameEnv index (tcdName d) cls_instances = maybeToList mb_instances >>= fst fam_instances = maybeToList mb_instances >>= snd - fam_insts = [ ( synifyFamInst i opaque - , doc - , spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) + fam_insts = [ ( synFamInst + , getInstDoc n + , spanNameE n synFamInst (L eSpan (tcdName d)) , nameModule_maybe n ) | i <- sortBy (comparing instFam) fam_instances , let n = getName i - , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap , not $ isNameHidden expInfo (fi_fam i) , not $ any (isTypeHidden expInfo) (fi_tys i) , let opaque = isTypeHidden expInfo (fi_rhs i) + , let synFamInst = synifyFamInst i opaque ] - cls_insts = [ ( synifyInstHead i - , instLookup instDocMap n iface ifaceMap instIfaceMap - , spanName n (synifyInstHead i) (L eSpan (tcdName d)) + cls_insts = [ ( synClsInst + , getInstDoc n + , spanName n synClsInst (L eSpan (tcdName d)) , nameModule_maybe n ) | let is = [ (instanceSig i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys + , let synClsInst = synifyInstHead i ] -- fam_insts but with failing type fams filtered out cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ] @@ -133,7 +139,7 @@ nubByName fst $ expItemFixities e ++ [ (n',f) | n <- getMainDeclBinder d , n' <- n : (map fst subDocs ++ patsyn_names) - , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] + , f <- maybeToList (getFixity n') ] } where patsyn_names = concatMap (getMainDeclBinder . fst) patsyns @@ -152,17 +158,21 @@ let L l r = spanName s ok linst in L l (Right r) +-- | Lookup the doc associated with a certain instance +findInstDoc :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe (MDoc Name) +findInstDoc iface ifaceMap instIfaceMap = \name -> + (Map.lookup name . ifaceDocMap $ iface) <|> + (Map.lookup name . ifaceDocMap =<< Map.lookup (nameModule name) ifaceMap) <|> + (Map.lookup name . instDocMap =<< Map.lookup (nameModule name) instIfaceMap) -instLookup :: (InstalledInterface -> Map.Map Name a) -> Name - -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a -instLookup f name iface ifaceMap instIfaceMap = - case Map.lookup name (f $ toInstalledIface iface) of - res@(Just _) -> res - Nothing -> do - let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap - iface' <- Map.lookup (nameModule name) ifaceMaps - Map.lookup name (f iface') +-- | Lookup the fixity associated with a certain name +findFixity :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe Fixity +findFixity iface ifaceMap instIfaceMap = \name -> + (Map.lookup name . ifaceFixMap $ iface) <|> + (Map.lookup name . ifaceFixMap =<< Map.lookup (nameModule name) ifaceMap) <|> + (Map.lookup name . instFixMap =<< Map.lookup (nameModule name) instIfaceMap) + -------------------------------------------------------------------------------- -- Collecting and sorting instances -------------------------------------------------------------------------------- @@ -210,13 +220,6 @@ instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t } = (map argCount ts, n, map simplify ts, argCount t, simplify t) - -funTyConName :: Name -funTyConName = mkWiredInName gHC_PRIM - (mkOccNameFS tcName FSLIT("(->)")) - funTyConKey - (ATyCon funTyCon) -- Relevant TyCon - BuiltInSyntax -------------------------------------------------------------------------------- -- Filtering hidden instances diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -20,27 +20,21 @@ module Haddock.Interface.Create (createInterface) where import Documentation.Haddock.Doc (metaDocAppend) -import Documentation.Haddock.Utf8 as Utf8 import Haddock.Types import Haddock.Options import Haddock.GhcUtils import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn -import Haddock.Backends.Hyperlinker.Types -import Haddock.Backends.Hyperlinker.Ast as Hyperlinker -import Haddock.Backends.Hyperlinker.Parser as Hyperlinker import Data.Bifunctor import Data.Bitraversable -import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Map (Map) import Data.List import Data.Maybe import Data.Ord import Control.Applicative -import Control.Exception (evaluate) import Control.Monad import Data.Traversable @@ -59,9 +53,8 @@ import RdrName import TcRnTypes import FastString ( unpackFS, fastStringToByteString) -import BasicTypes ( StringLiteral(..), SourceText(..) ) +import BasicTypes ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) import qualified Outputable as O -import HsDecls ( getConArgs ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -85,7 +78,7 @@ !instances = modInfoInstances mi !fam_instances = md_fam_insts md !exportedNames = modInfoExportsWithSelectors mi - (pkgNameFS, _) = modulePackageInfo dflags flags mdl + (pkgNameFS, _) = modulePackageInfo dflags flags (Just mdl) pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS (TcGblEnv { tcg_rdr_env = gre @@ -117,7 +110,7 @@ let declsWithDocs = topDecls group_ - exports0 = fmap (reverse . map (first unLoc)) mayExports + exports0 = fmap (map (first unLoc)) mayExports exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 @@ -132,8 +125,8 @@ fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom sem_mdl) - $ map getName instances - ++ map getName fam_instances + $ map getName fam_instances + ++ map getName instances -- Locations of all TH splices splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ] @@ -170,8 +163,6 @@ modWarn <- liftErrMsg (moduleWarning dflags gre warnings) - tokenizedSrc <- mkMaybeTokenizedSrc dflags flags tm - return $! Interface { ifaceMod = mdl , ifaceIsSig = is_sig @@ -197,7 +188,8 @@ , ifaceRnOrphanInstances = [] -- Filled in `renameInterface` , ifaceHaddockCoverage = coverage , ifaceWarningMap = warningMap - , ifaceTokenizedSrc = tokenizedSrc + , ifaceHieFile = Just $ ml_hie_file $ ms_location ms + , ifaceDynFlags = dflags } @@ -899,7 +891,7 @@ Nothing -> do liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] return Nothing - Just x -> case tyThingToLHsDecl x of + 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') @@ -1077,8 +1069,8 @@ TyClD _ d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) in if isDataConName name - then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) - else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) + then SigD noExt <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) + else SigD noExt <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) TyClD _ FamDecl {} | isValName name , Just (famInst:_) <- M.lookup name declMap @@ -1113,10 +1105,11 @@ in case matches of [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0) _ -> error "internal: extractDecl (ClsInstD)" - _ -> error "internal: extractDecl" - + _ -> O.pprPanic "extractDecl" $ + O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":" + O.$$ O.nest 4 (O.ppr decl) -extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn +extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn extractPatternSyn nm t tvs cons = case filter matches cons of [] -> error "extractPatternSyn: constructor pattern not found" @@ -1144,9 +1137,13 @@ data_ty con | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn + mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty + mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki + mkAppTyArg f (HsArgPar _) = HsParTy noExt f -extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] +extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn extractRecSel _ _ _ [] = error "extractRecSel: selector not found" @@ -1162,7 +1159,11 @@ data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn + mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty + mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki + mkAppTyArg f (HsArgPar _) = HsParTy noExt f -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] @@ -1191,34 +1192,6 @@ seqList :: [a] -> () seqList [] = () seqList (x : xs) = x `seq` seqList xs - -mkMaybeTokenizedSrc :: DynFlags -> [Flag] -> TypecheckedModule - -> ErrMsgGhc (Maybe [RichToken]) -mkMaybeTokenizedSrc dflags flags tm - | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of - Just src -> do - tokens <- liftGhcToErrMsgGhc (liftIO (mkTokenizedSrc dflags summary src)) - return $ Just tokens - Nothing -> do - liftErrMsg . tell . pure $ concat - [ "Warning: Cannot hyperlink module \"" - , moduleNameString . ms_mod_name $ summary - , "\" because renamed source is not available" - ] - return Nothing - | otherwise = return Nothing - where - summary = pm_mod_summary . tm_parsed_module $ tm - -mkTokenizedSrc :: DynFlags -> ModSummary -> RenamedSource -> IO [RichToken] -mkTokenizedSrc dflags ms src = do - -- make sure to read the whole file at once otherwise - -- we run out of file descriptors (see #495) - rawSrc <- BS.readFile (msHsFilePath ms) >>= evaluate - let tokens = Hyperlinker.parse dflags filepath (Utf8.decodeUtf8 rawSrc) - return $ Hyperlinker.enrich src tokens - where - filepath = msHsFilePath ms -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString) diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -62,7 +62,10 @@ ] jsonDoc :: Doc Name -> JsonDoc -jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc)) +jsonDoc doc = jsonString (show (bimap showModName showName doc)) + where + showModName = showWrapped (moduleNameString . fst) + showName = showWrapped nameStableString jsonModule :: Module -> JsonDoc jsonModule = JSString . moduleStableString diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -19,9 +19,9 @@ , processModuleHeader ) where -import Avail import Control.Arrow import Control.Monad +import Data.Functor (($>)) import Data.List import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) @@ -34,8 +34,8 @@ import Name import Outputable ( showPpr, showSDoc ) import RdrName +import RdrHsSyn (setRdrNameSpace) import EnumSet -import RnEnv (dataTcOccs) processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) @@ -89,24 +89,38 @@ -- fallbacks in case we can't locate the identifiers. -- -- See the comments in the source for implementation commentary. -rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name) +rename :: DynFlags -> GlobalRdrEnv -> Doc NsRdrName -> ErrMsgM (Doc Name) rename dflags gre = rn where rn d = case d of DocAppend a b -> DocAppend <$> rn a <*> rn b DocParagraph doc -> DocParagraph <$> rn doc - DocIdentifier x -> do + DocIdentifier i -> do + let NsRdrName ns x = unwrap i + occ = rdrNameOcc x + isValueName = isDataOcc occ || isVarOcc occ + + let valueNsChoices | isValueName = [x] + | otherwise = [] -- is this ever possible? + typeNsChoices | isValueName = [setRdrNameSpace x tcName] + | otherwise = [x] + -- Generate the choices for the possible kind of thing this - -- is. - let choices = dataTcOccs x + -- is. We narrow down the possibilities with the namespace (if + -- there is one). + let choices = case ns of + Value -> valueNsChoices + Type -> typeNsChoices + None -> valueNsChoices ++ typeNsChoices -- Lookup any GlobalRdrElts that match the choices. case concatMap (\c -> lookupGRE_RdrName c gre) choices of -- We found no names in the env so we start guessing. [] -> case choices of - -- This shouldn't happen as 'dataTcOccs' always returns at least its input. - [] -> pure (DocMonospaced (DocString (showPpr dflags x))) + -- The only way this can happen is if a value namespace was + -- specified on something that cannot be a value. + [] -> invalidValue dflags i -- There was nothing in the environment so we need to -- pick some default from what's available to us. We @@ -116,14 +130,14 @@ -- type constructor names (such as in #253). So now we -- only get type constructor links if they are actually -- in scope. - a:_ -> outOfScope dflags a + a:_ -> outOfScope dflags ns (i $> a) -- There is only one name in the environment that matches so -- use it. - [a] -> pure (DocIdentifier (gre_name a)) + [a] -> pure (DocIdentifier (i $> gre_name a)) -- There are multiple names available. - gres -> ambiguous dflags x gres + gres -> ambiguous dflags i gres DocWarning doc -> DocWarning <$> rn doc DocEmphasis doc -> DocEmphasis <$> rn doc @@ -135,7 +149,7 @@ DocCodeBlock doc -> DocCodeBlock <$> rn doc DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x) DocModule str -> pure (DocModule str) - DocHyperlink l -> pure (DocHyperlink l) + DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l DocPic str -> pure (DocPic str) DocMathInline str -> pure (DocMathInline str) DocMathDisplay str -> pure (DocMathDisplay str) @@ -155,20 +169,25 @@ -- users shouldn't rely on this doing the right thing. See tickets -- #253 and #375 on the confusion this causes depending on which -- default we pick in 'rename'. -outOfScope :: DynFlags -> RdrName -> ErrMsgM (Doc a) -outOfScope dflags x = - case x of - Unqual occ -> warnAndMonospace occ - Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ)) - Orig _ occ -> warnAndMonospace occ - Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope +outOfScope :: DynFlags -> Namespace -> Wrap RdrName -> ErrMsgM (Doc a) +outOfScope dflags ns x = + case unwrap x of + Unqual occ -> warnAndMonospace (x $> occ) + Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ))) + Orig _ occ -> warnAndMonospace (x $> occ) + Exact name -> warnAndMonospace (x $> name) -- Shouldn't happen since x is out of scope where + prefix = case ns of + Value -> "the value " + Type -> "the type " + None -> "" + warnAndMonospace a = do - tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" ++ - " If you qualify the identifier, haddock can try to link it\n" ++ - " it anyway."] - pure (monospaced a) - monospaced a = DocMonospaced (DocString (showPpr dflags a)) + let a' = showWrapped (showPpr dflags) a + tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++ + " If you qualify the identifier, haddock can try to link it anyway."] + pure (monospaced a') + monospaced = DocMonospaced . DocString -- | Handle ambiguous identifiers. -- @@ -176,26 +195,39 @@ -- -- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class. ambiguous :: DynFlags - -> RdrName + -> Wrap NsRdrName -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above. -> ErrMsgM (Doc Name) ambiguous dflags x gres = do - let noChildren = map availName (gresToAvailInfo gres) - dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren - msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++ - concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ + let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres + msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++ + concatMap (\n -> " * " ++ defnLoc n ++ "\n") gres ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ - " by hiding some imports.\n" ++ - " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt + " by specifying the type/value namespace explicitly.\n" ++ + " Defaulting to the one defined " ++ defnLoc dflt -- TODO: Once we have a syntax for namespace qualification (#667) we may also -- want to emit a warning when an identifier is a data constructor for a type -- 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 noChildren > 1) $ tell [msg] - pure (DocIdentifier dflt) + when (length (gresToAvailInfo gres) > 1) $ tell [msg] + pure (DocIdentifier (x $> gre_name dflt)) where - isLocalName (nameSrcLoc -> RealSrcLoc {}) = True - isLocalName _ = False - x_str = '\'' : showPpr dflags x ++ "'" - defnLoc = showSDoc dflags . pprNameDefnLoc + defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name + +-- | Handle value-namespaced names that cannot be for values. +-- +-- Emits a warning that the value-namespace is invalid on a non-value identifier. +invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a) +invalidValue dflags x = do + tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++ + " namespaced as such. Did you mean to specify a type namespace\n" ++ + " instead?"] + pure (DocMonospaced (DocString (showNsRdrName dflags x))) + +-- | Printable representation of a wrapped and namespaced name +showNsRdrName :: DynFlags -> Wrap NsRdrName -> String +showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident + where + ident = showWrapped (showPpr dflags . rdrName) + prefix = renderNs . namespace . unwrap diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -11,12 +12,12 @@ ----------------------------------------------------------------------------- module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where -import Control.Monad (mplus) +import Control.Applicative (Alternative (..)) +import Control.Monad (ap) import Data.Char import DynFlags import Haddock.Parser import Haddock.Types -import RdrName -- ----------------------------------------------------------------------------- -- Parsing module headers @@ -24,37 +25,47 @@ -- NB. The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted. -parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName) +parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName) parseModuleHeader dflags pkgName str0 = let - getKey :: String -> String -> (Maybe String,String) - getKey key str = case parseKey key str of - Nothing -> (Nothing,str) - Just (value,rest) -> (Just value,rest) + kvs :: [(String, String)] + str1 :: String - (_moduleOpt,str1) = getKey "Module" str0 - (descriptionOpt,str2) = getKey "Description" str1 - (copyrightOpt,str3) = getKey "Copyright" str2 - (licenseOpt,str4) = getKey "License" str3 - (licenceOpt,str5) = getKey "Licence" str4 - (spdxLicenceOpt,str6) = getKey "SPDX-License-Identifier" str5 - (maintainerOpt,str7) = getKey "Maintainer" str6 - (stabilityOpt,str8) = getKey "Stability" str7 - (portabilityOpt,str9) = getKey "Portability" str8 + (kvs, str1) = maybe ([], str0) id $ runP fields str0 + -- trim whitespaces + trim :: String -> String + trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse + + getKey :: String -> Maybe String + getKey key = fmap trim (lookup key kvs) + + descriptionOpt = getKey "Description" + copyrightOpt = getKey "Copyright" + licenseOpt = getKey "License" + licenceOpt = getKey "Licence" + spdxLicenceOpt = getKey "SPDX-License-Identifier" + maintainerOpt = getKey "Maintainer" + stabilityOpt = getKey "Stability" + portabilityOpt = getKey "Portability" + in (HaddockModInfo { hmi_description = parseString dflags <$> descriptionOpt, hmi_copyright = copyrightOpt, - hmi_license = spdxLicenceOpt `mplus` licenseOpt `mplus` licenceOpt, + hmi_license = spdxLicenceOpt <|> licenseOpt <|> licenceOpt, hmi_maintainer = maintainerOpt, hmi_stability = stabilityOpt, hmi_portability = portabilityOpt, hmi_safety = Nothing, hmi_language = Nothing, -- set in LexParseRn hmi_extensions = [] -- also set in LexParseRn - }, parseParas dflags pkgName str9) + }, parseParas dflags pkgName str1) --- | This function is how we read keys. +------------------------------------------------------------------------------- +-- Small parser to parse module header. +------------------------------------------------------------------------------- + +-- | The below is a small parser framework how we read keys. -- -- all fields in the header are optional and have the form -- @@ -73,78 +84,105 @@ -- -- the value will be "this is a .. description" and the rest will begin -- at "The module comment". -parseKey :: String -> String -> Maybe (String,String) -parseKey key toParse0 = - do - let - (spaces0,toParse1) = extractLeadingSpaces (dropWhile (`elem` ['\r', '\n']) toParse0) - indentation = spaces0 - afterKey0 <- extractPrefix key toParse1 - let - afterKey1 = extractLeadingSpaces afterKey0 - afterColon0 <- case snd afterKey1 of - ':':afterColon -> return afterColon - _ -> Nothing - let - (_,afterColon1) = extractLeadingSpaces afterColon0 +-- | 'C' is a 'Char' carrying its column. +-- +-- This let us make an indentation-aware parser, as we know current indentation. +-- by looking at the next character in the stream ('curInd'). +-- +-- Thus we can munch all spaces but only not-spaces which are indented. +-- +data C = C {-# UNPACK #-} !Int Char - return (scanKey True indentation afterColon1) - where - scanKey :: Bool -> String -> String -> (String,String) - scanKey _ _ [] = ([],[]) - scanKey isFirst indentation str = - let - (nextLine,rest1) = extractNextLine str +newtype P a = P { unP :: [C] -> Maybe ([C], a) } + deriving Functor - accept = isFirst || sufficientIndentation || allSpaces +instance Applicative P where + pure x = P $ \s -> Just (s, x) + (<*>) = ap - sufficientIndentation = case extractPrefix indentation nextLine of - Just (c:_) | isSpace c -> True - _ -> False +instance Monad P where + return = pure + m >>= k = P $ \s0 -> do + (s1, x) <- unP m s0 + unP (k x) s1 - allSpaces = case extractLeadingSpaces nextLine of - (_,[]) -> True - _ -> False - in - if accept - then - let - (scanned1,rest2) = scanKey False indentation rest1 +instance Alternative P where + empty = P $ \_ -> Nothing + a <|> b = P $ \s -> unP a s <|> unP b s - scanned2 = case scanned1 of - "" -> if allSpaces then "" else nextLine - _ -> nextLine ++ "\n" ++ scanned1 - in - (scanned2,rest2) - else - ([],str) +runP :: P a -> String -> Maybe a +runP p input = fmap snd (unP p input') + where + input' = concat + [ zipWith C [0..] l ++ [C (length l) '\n'] + | l <- lines input + ] - extractLeadingSpaces :: String -> (String,String) - extractLeadingSpaces [] = ([],[]) - extractLeadingSpaces (s@(c:cs)) - | isSpace c = - let - (spaces1,cs1) = extractLeadingSpaces cs - in - (c:spaces1,cs1) - | otherwise = ([],s) +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- - extractNextLine :: String -> (String,String) - extractNextLine [] = ([],[]) - extractNextLine (c:cs) - | c == '\n' = - ([],cs) - | otherwise = - let - (line,rest) = extractNextLine cs - in - (c:line,rest) +curInd :: P Int +curInd = P $ \s -> Just . (,) s $ case s of + [] -> 0 + C i _ : _ -> i - -- comparison is case-insensitive. - extractPrefix :: String -> String -> Maybe String - extractPrefix [] s = Just s - extractPrefix _ [] = Nothing - extractPrefix (c1:cs1) (c2:cs2) - | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 - | otherwise = Nothing +rest :: P String +rest = P $ \cs -> Just ([], [ c | C _ c <- cs ]) + +munch :: (Int -> Char -> Bool) -> P String +munch p = P $ \cs -> + let (xs,ys) = takeWhileMaybe p' cs in Just (ys, xs) + where + p' (C i c) + | p i c = Just c + | otherwise = Nothing + +munch1 :: (Int -> Char -> Bool) -> P String +munch1 p = P $ \s -> case s of + [] -> Nothing + (c:cs) | Just c' <- p' c -> let (xs,ys) = takeWhileMaybe p' cs in Just (ys, c' : xs) + | otherwise -> Nothing + where + p' (C i c) + | p i c = Just c + | otherwise = Nothing + +char :: Char -> P Char +char c = P $ \s -> case s of + [] -> Nothing + (C _ c' : cs) | c == c' -> Just (cs, c) + | otherwise -> Nothing + +skipSpaces :: P () +skipSpaces = P $ \cs -> Just (dropWhile (\(C _ c) -> isSpace c) cs, ()) + +takeWhileMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) +takeWhileMaybe f = go where + go xs0@[] = ([], xs0) + go xs0@(x:xs) = case f x of + Just y -> let (ys, zs) = go xs in (y : ys, zs) + Nothing -> ([], xs0) + +------------------------------------------------------------------------------- +-- Fields +------------------------------------------------------------------------------- + +field :: Int -> P (String, String) +field i = do + fn <- munch1 $ \_ c -> isAlpha c || c == '-' + skipSpaces + _ <- char ':' + skipSpaces + val <- munch $ \j c -> isSpace c || j > i + return (fn, val) + +fields :: P ([(String, String)], String) +fields = do + skipSpaces + i <- curInd + fs <- many (field i) + r <- rest + return (fs, r) + diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename @@ -23,15 +24,15 @@ import Name import Outputable ( panic ) import RdrName (RdrName(Exact)) -import PrelNames (eqTyCon_RDR) +import TysWiredIn (eqTyCon_RDR) import Control.Applicative +import Control.Arrow ( first ) import Control.Monad hiding (mapM) import Data.List import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) - renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface renameInterface dflags renamingEnv warnings iface = @@ -92,56 +93,53 @@ -------------------------------------------------------------------------------- -- Monad for renaming --- --- The monad does two things for us: it passes around the environment for --- renaming, and it returns a list of names which couldn't be found in --- the environment. -------------------------------------------------------------------------------- +-- | The monad does two things for us: it passes around the environment for +-- renaming, and it returns a list of names which couldn't be found in +-- the environment. newtype RnM a = - RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function - -> (a,[Name]) + RnM { unRn :: (Name -> (Bool, DocName)) + -- Name lookup function. The 'Bool' indicates that if the name + -- was \"found\" in the environment. + + -> (a, [Name] -> [Name]) + -- Value returned, as well as a difference list of the names not + -- found } instance Monad RnM where - (>>=) = thenRn - return = pure + m >>= k = RnM $ \lkp -> let (a, out1) = unRn m lkp + (b, out2) = unRn (k a) lkp + in (b, out1 . out2) instance Functor RnM where - fmap f x = do a <- x; return (f a) + fmap f (RnM lkp) = RnM (first f . lkp) instance Applicative RnM where - pure = returnRn - (<*>) = ap - -returnRn :: a -> RnM a -returnRn a = RnM (const (a,[])) -thenRn :: RnM a -> (a -> RnM b) -> RnM b -m `thenRn` k = RnM (\lkp -> case unRn m lkp of - (a,out1) -> case unRn (k a) lkp of - (b,out2) -> (b,out1++out2)) - -getLookupRn :: RnM (Name -> (Bool, DocName)) -getLookupRn = RnM (\lkp -> (lkp,[])) - -outRn :: Name -> RnM () -outRn name = RnM (const ((),[name])) + pure a = RnM (const (a, id)) + mf <*> mx = RnM $ \lkp -> let (f, out1) = unRn mf lkp + (x, out2) = unRn mx lkp + in (f x, out1 . out2) +-- | Look up a 'Name' in the renaming environment. lookupRn :: Name -> RnM DocName -lookupRn name = do - lkp <- getLookupRn +lookupRn name = RnM $ \lkp -> case lkp name of - (False,maps_to) -> do outRn name; return maps_to - (True, maps_to) -> return maps_to - + (False,maps_to) -> (maps_to, (name :)) + (True, maps_to) -> (maps_to, id) -runRnFM :: LinkEnv -> RnM a -> (a,[Name]) -runRnFM env rn = unRn rn lkp +-- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function. +-- Returns the renamed value along with a list of `Name`'s that could not be +-- renamed because they weren't in the environment. +runRnFM :: LinkEnv -> RnM a -> (a, [Name]) +runRnFM env rn = let (x, dlist) = unRn rn lkp in (x, dlist []) where - lkp n = case Map.lookup n env of - Nothing -> (False, Undocumented n) - Just mdl -> (True, Documented n mdl) + lkp n | isTyVarName n = (True, Undocumented n) + | otherwise = case Map.lookup n env of + Nothing -> (False, Undocumented n) + Just mdl -> (True, Documented n mdl) -------------------------------------------------------------------------------- @@ -175,8 +173,8 @@ renameLDocHsSyn = return -renameDoc :: Traversable t => t Name -> RnM (t DocName) -renameDoc = traverse rename +renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName)) +renameDoc = traverse (traverse rename) renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc @@ -185,6 +183,13 @@ renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI) renameLType = mapM renameType +renameLTypeArg :: LHsTypeArg GhcRn -> RnM (LHsTypeArg DocNameI) +renameLTypeArg (HsValArg ty) = do { ty' <- renameLType ty + ; return $ HsValArg ty' } +renameLTypeArg (HsTypeArg l ki) = do { ki' <- renameLKind ki + ; return $ HsTypeArg l ki' } +renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp + renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) renameLSigType = renameImplicit renameLType @@ -240,6 +245,11 @@ b' <- renameLType b return (HsAppTy NoExt a' b') + HsAppKindTy _ a b -> do + a' <- renameLType a + b' <- renameLKind b + return (HsAppKindTy NoExt a' b') + HsFunTy _ a b -> do a' <- renameLType a b' <- renameLType b @@ -276,7 +286,7 @@ HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsSpliceTy _ s -> renameHsSpliceTy s - HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a + HsWildCardTy a -> pure (HsWildCardTy a) -- | Rename splices, but _only_ those that turn out to be for types. -- I think this is actually safe for our possible inputs: @@ -311,9 +321,6 @@ context' <- mapM renameLType context return (L loc context') -renameWildCardInfo :: HsWildCardInfo -> RnM HsWildCardInfo -renameWildCardInfo (AnonWildCard (L l name)) = return (AnonWildCard (L l name)) - renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do cname <- rename ihdClsName @@ -600,13 +607,16 @@ rename_ty_fam_eqn :: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn) -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI)) - rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats - , feqn_fixity = fixity, feqn_rhs = rhs }) + rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs + , feqn_pats = pats, feqn_fixity = fixity + , feqn_rhs = rhs }) = do { tc' <- renameL tc - ; pats' <- mapM renameLType pats + ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs + ; pats' <- mapM renameLTypeArg pats ; rhs' <- renameLType rhs ; return (FamEqn { feqn_ext = noExt , feqn_tycon = tc' + , feqn_bndrs = bndrs' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = rhs' }) } @@ -620,6 +630,7 @@ ; rhs' <- renameLType rhs ; return (L loc (FamEqn { feqn_ext = noExt , feqn_tycon = tc' + , feqn_bndrs = Nothing -- this is always Nothing , feqn_pats = tvs' , feqn_fixity = fixity , feqn_rhs = rhs' })) } @@ -633,13 +644,16 @@ rename_data_fam_eqn :: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn) -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI)) - rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats - , feqn_fixity = fixity, feqn_rhs = defn }) + rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs + , feqn_pats = pats, feqn_fixity = fixity + , feqn_rhs = defn }) = do { tc' <- renameL tc - ; pats' <- mapM renameLType pats + ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs + ; pats' <- mapM renameLTypeArg pats ; defn' <- renameDataDefn defn ; return (FamEqn { feqn_ext = noExt , feqn_tycon = tc' + , feqn_bndrs = bndrs' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = defn' }) } diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -15,6 +15,8 @@ import GHC import Name import FastString +import TysPrim ( funTyConName ) +import TysWiredIn ( listTyConName ) import Control.Monad import Control.Monad.Trans.State @@ -47,14 +49,13 @@ -- one by one, we should avoid infinite loops. spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty specs +{-# SPECIALIZE specialize :: [(Name, HsType GhcRn)] -> HsType GhcRn -> HsType GhcRn #-} -- | Instantiate given binders with corresponding types. -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: Data a - => LHsQTyVars GhcRn -> [HsType GhcRn] - -> a -> a +specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where @@ -64,11 +65,12 @@ bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs" + specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn] -> PseudoFamilyDecl GhcRn -> PseudoFamilyDecl GhcRn specializePseudoFamilyDecl bndrs typs decl = - decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} + decl {pfdTyVars = map (fmap (specializeTyVarBndrs bndrs typs)) (pfdTyVars decl)} specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] -> Sig GhcRn @@ -110,10 +112,7 @@ sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) - | isBuiltInSyntax name' && strName == "[]" = HsListTy NoExt ltyp - where - name' = getName name - strName = occNameString . nameOccName $ name' + | getName name == listTyConName = HsListTy NoExt ltyp sugarLists typ = typ @@ -127,7 +126,7 @@ | isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps where name' = getName name - strName = occNameString . nameOccName $ name' + strName = getOccString name suitable = case parseTupleArity strName of Just arity -> arity == length apps Nothing -> False @@ -137,7 +136,7 @@ sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy NoExt la lb + | funTyConName == name' = HsFunTy NoExt la lb where name' = getName name sugarOperators typ = typ @@ -182,7 +181,7 @@ type NameRep = FastString getNameRep :: NamedThing name => name -> NameRep -getNameRep = occNameFS . getOccName +getNameRep = getOccFS nameRepString :: NameRep -> String nameRepString = unpackFS @@ -256,6 +255,7 @@ renameType (HsTyVar x ip name) = HsTyVar x ip <$> located 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 renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr renameType (HsListTy x lt) = HsListTy x <$> renameLType lt renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt @@ -281,6 +281,8 @@ renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) renameLType = located renameType +renameLKind :: LHsKind GhcRn -> Rename (IdP GhcRn) (LHsKind GhcRn) +renameLKind = renameLType renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -82,8 +82,8 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 805) && (__GLASGOW_HASKELL__ < 807) -binaryInterfaceVersion = 33 +#if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809) +binaryInterfaceVersion = 35 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -190,8 +190,9 @@ MonadIO m => NameCacheAccessor m -> FilePath + -> Bool -- ^ Disable version check. Can cause runtime crash. -> m (Either String InterfaceFile) -readInterfaceFile (get_name_cache, set_name_cache) filename = do +readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do bh0 <- liftIO $ readBinMem filename magic <- liftIO $ get bh0 @@ -200,7 +201,8 @@ case () of _ | magic /= binaryInterfaceMagic -> return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename - | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $ + | not bypass_checks + , (version `notElem` binaryInterfaceVersionCompatibility) -> return . Left $ "Interface file is of wrong version: " ++ filename | otherwise -> with_name_cache $ \update_nc -> do @@ -432,7 +434,7 @@ result <- get bh return (Example expression result) -instance Binary Hyperlink where +instance Binary a => Binary (Hyperlink a) where put_ bh (Hyperlink url label) = do put_ bh url put_ bh label @@ -699,3 +701,28 @@ name <- get bh return (Undocumented name) _ -> error "get DocName: Bad h" + +instance Binary n => Binary (Wrap n) where + put_ bh (Unadorned n) = do + putByte bh 0 + put_ bh n + put_ bh (Parenthesized n) = do + putByte bh 1 + put_ bh n + put_ bh (Backticked n) = do + putByte bh 2 + put_ bh n + + get bh = do + h <- getByte bh + case h of + 0 -> do + name <- get bh + return (Unadorned name) + 1 -> do + name <- get bh + return (Parenthesized name) + 2 -> do + name <- get bh + return (Backticked name) + _ -> error "get Wrap: Bad h" diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -43,7 +43,6 @@ import qualified Data.Char as Char import Data.Version import Control.Applicative -import Distribution.Verbosity import FastString import GHC ( DynFlags, Module, moduleUnitId ) import Haddock.Types @@ -84,6 +83,7 @@ | Flag_Version | Flag_CompatibleInterfaceVersions | Flag_InterfaceVersion + | Flag_BypassInterfaceVersonCheck | Flag_UseContents String | Flag_GenContents | Flag_UseIndex String @@ -175,6 +175,8 @@ "output compatible interface file versions and exit", Option [] ["interface-version"] (NoArg Flag_InterfaceVersion) "output interface file version and exit", + Option [] ["bypass-interface-version-check"] (NoArg Flag_BypassInterfaceVersonCheck) + "bypass the interface file version check (dangerous)", Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY") "set verbosity level", Option [] ["use-contents"] (ReqArg Flag_UseContents "URL") @@ -186,7 +188,7 @@ Option [] ["gen-index"] (NoArg Flag_GenIndex) "generate an HTML index from specified\ninterfaces", Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports) - "behave as if all modules have the\nignore-exports atribute", + "behave as if all modules have the\nignore-exports attribute", Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") "behave as if MODULE has the hide attribute", Option [] ["show"] (ReqArg Flag_ShowModule "MODULE") @@ -329,7 +331,7 @@ verbosity :: [Flag] -> Verbosity verbosity flags = case [ str | Flag_Verbosity str <- flags ] of - [] -> normal + [] -> Normal x:_ -> case parseVerbosity x of Left e -> throwE e Right v -> v @@ -371,9 +373,10 @@ -> [Flag] -- ^ Haddock flags are checked as they may contain -- the package name or version provided by the user -- which we prioritise - -> Module + -> Maybe Module -> (Maybe PackageName, Maybe Data.Version.Version) -modulePackageInfo dflags flags modu = +modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing) +modulePackageInfo dflags flags (Just modu) = ( optPackageName flags <|> fmap packageName pkgDb , optPackageVersion flags <|> fmap packageVersion pkgDb ) diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving - , FlexibleInstances, UndecidableInstances - , IncoherentInstances #-} -{-# LANGUAGE LambdaCase #-} -- | -- Module : Haddock.Parser -- Copyright : (c) Mateusz Kowalczyk 2013, @@ -19,26 +14,33 @@ ) where import qualified Documentation.Haddock.Parser as P -import DynFlags (DynFlags) -import FastString (mkFastString) import Documentation.Haddock.Types -import Lexer (mkPState, unP, ParseResult(POk)) -import Parser (parseIdentifier) -import RdrName (RdrName) -import SrcLoc (mkRealSrcLoc, unLoc) -import StringBuffer (stringToStringBuffer) +import Haddock.Types -parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod RdrName +import DynFlags ( DynFlags ) +import FastString ( fsLit ) +import Lexer ( mkPState, unP, ParseResult(POk) ) +import Parser ( parseIdentifier ) +import SrcLoc ( mkRealSrcLoc, GenLocated(..) ) +import StringBuffer ( stringToStringBuffer ) + + +parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName) parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p -parseString :: DynFlags -> String -> DocH mod RdrName +parseString :: DynFlags -> String -> DocH mod (Wrap NsRdrName) parseString d = P.overIdentifier (parseIdent d) . P.parseString -parseIdent :: DynFlags -> String -> Maybe RdrName -parseIdent dflags str0 = - let buffer = stringToStringBuffer str0 - realSrcLc = mkRealSrcLoc (mkFastString "") 0 0 +parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName) +parseIdent dflags ns str0 = + let buffer = stringToStringBuffer str1 + realSrcLc = mkRealSrcLoc (fsLit "") 0 0 pstate = mkPState dflags buffer realSrcLc + (wrap,str1) = case str0 of + '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names + -> (Parenthesized, init s) + '`' : s@(_ : _) -> (Backticked, init s) + _ -> (Unadorned, str0) in case unP parseIdentifier pstate of - POk _ name -> Just (unLoc name) + POk _ (L _ name) -> Just (wrap (NsRdrName ns name)) _ -> Nothing diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -28,23 +30,19 @@ import Control.Exception import Control.Arrow hiding ((<+>)) import Control.DeepSeq +import Control.Monad (ap) import Control.Monad.IO.Class (MonadIO(..)) -import Data.Typeable +import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) -import qualified Data.Map as Map import Documentation.Haddock.Types -import BasicTypes (Fixity(..)) +import BasicTypes (Fixity(..), PromotionFlag(..)) -import GHC hiding (NoLink) +import GHC import DynFlags (Language) import qualified GHC.LanguageExtensions as LangExt import OccName -import Outputable -import Control.Applicative (Applicative(..)) -import Control.Monad (ap) - -import Haddock.Backends.Hyperlinker.Types +import Outputable hiding ((<>)) ----------------------------------------------------------------------------- -- * Convenient synonyms @@ -143,7 +141,8 @@ -- | Tokenized source code of module (avaliable if Haddock is invoked with -- source generation flag). - , ifaceTokenizedSrc :: !(Maybe [RichToken]) + , ifaceHieFile :: !(Maybe FilePath) + , ifaceDynFlags :: !DynFlags } type WarningMap = Map Name (Doc Name) @@ -274,7 +273,7 @@ noDocForDecl :: DocForDecl name -noDocForDecl = (Documentation Nothing Nothing, Map.empty) +noDocForDecl = (Documentation Nothing Nothing, mempty) ----------------------------------------------------------------------------- @@ -285,6 +284,12 @@ -- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module +-- | An 'RdrName' tagged with some type/value namespace information. +data NsRdrName = NsRdrName + { namespace :: !Namespace + , rdrName :: !RdrName + } + -- | Extends 'Name' with cross-reference information. data DocName = Documented Name Module @@ -329,8 +334,31 @@ setName name' (Documented _ mdl) = Documented name' mdl setName name' (Undocumented _) = Undocumented name' +-- | Adds extra "wrapper" information to a name. +-- +-- This is to work around the fact that most name types in GHC ('Name', 'RdrName', +-- 'OccName', ...) don't include backticks or parens. +data Wrap n + = Unadorned { unwrap :: n } -- ^ don't do anything to the name + | Parenthesized { unwrap :: n } -- ^ add parentheses around the name + | Backticked { unwrap :: n } -- ^ add backticks around the name + deriving (Show, Functor, Foldable, Traversable) +-- | Useful for debugging +instance Outputable n => Outputable (Wrap n) where + ppr (Unadorned n) = ppr n + ppr (Parenthesized n) = hcat [ char '(', ppr n, char ')' ] + ppr (Backticked n) = hcat [ char '`', ppr n, char '`' ] +showWrapped :: (a -> String) -> Wrap a -> String +showWrapped f (Unadorned n) = f n +showWrapped f (Parenthesized n) = "(" ++ f n ++ ")" +showWrapped f (Backticked n) = "`" ++ f n ++ "`" + +instance HasOccName DocName where + + occName = occName . getName + ----------------------------------------------------------------------------- -- * Instances ----------------------------------------------------------------------------- @@ -424,10 +452,10 @@ type LDoc id = Located (Doc id) -type Doc id = DocH (ModuleName, OccName) id -type MDoc id = MetaDoc (ModuleName, OccName) id +type Doc id = DocH (Wrap (ModuleName, OccName)) (Wrap id) +type MDoc id = MetaDoc (Wrap (ModuleName, OccName)) (Wrap id) -type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a +type DocMarkup id a = DocMarkupH (Wrap (ModuleName, OccName)) id a instance (NFData a, NFData mod) => NFData (DocH mod a) where @@ -467,7 +495,7 @@ instance NFData id => NFData (Header id) where rnf (Header a b) = a `deepseq` b `deepseq` () -instance NFData Hyperlink where +instance NFData id => NFData (Hyperlink id) where rnf (Hyperlink a b) = a `deepseq` b `deepseq` () instance NFData Picture where @@ -674,6 +702,7 @@ type instance XTyVar DocNameI = NoExt type instance XStarTy DocNameI = NoExt type instance XAppTy DocNameI = NoExt +type instance XAppKindTy DocNameI = NoExt type instance XFunTy DocNameI = NoExt type instance XListTy DocNameI = NoExt type instance XTupleTy DocNameI = NoExt @@ -689,7 +718,7 @@ type instance XExplicitListTy DocNameI = NoExt type instance XExplicitTupleTy DocNameI = NoExt type instance XTyLit DocNameI = NoExt -type instance XWildCardTy DocNameI = HsWildCardInfo +type instance XWildCardTy DocNameI = NoExt type instance XXType DocNameI = NewHsTypeX type instance XUserTyVar DocNameI = NoExt @@ -742,3 +771,19 @@ type instance XHsQTvs DocNameI = NoExt type instance XConDeclField DocNameI = NoExt +type instance XXPat DocNameI = Located (Pat DocNameI) + +type instance SrcSpanLess (LPat DocNameI) = Pat DocNameI +instance HasSrcSpan (LPat DocNameI) where + -- NB: The following chooses the behaviour of the outer location + -- wrapper replacing the inner ones. + composeSrcSpan (L sp p) = if sp == noSrcSpan + then p + else XPat (L sp (stripSrcSpanPat p)) + -- NB: The following only returns the top-level location, if any. + decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p) + decomposeSrcSpan p = L noSrcSpan p + +stripSrcSpanPat :: LPat DocNameI -> Pat DocNameI +stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p +stripSrcSpanPat p = p diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -33,6 +33,7 @@ -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, + writeUtf8File, withTempDir, -- * HTML cross reference mapping html_xrefs_ref, html_xrefs_ref', @@ -48,7 +49,7 @@ MonadIO(..), -- * Logging - parseVerbosity, + parseVerbosity, Verbosity(..), silent, normal, verbose, deafening, out, -- * System tools @@ -60,9 +61,10 @@ import Haddock.Types import Haddock.GhcUtils +import BasicTypes ( PromotionFlag(..) ) +import Exception (ExceptionMonad) import GHC import Name -import HsTypes (extFieldOcc) import Outputable ( panic ) import Control.Monad ( liftM ) @@ -75,11 +77,10 @@ import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) import System.Exit -import System.IO ( hPutStr, stderr ) +import System.Directory ( createDirectory, removeDirectoryRecursive ) +import System.IO ( hPutStr, hSetEncoding, IOMode(..), stderr, utf8, withFile ) import System.IO.Unsafe ( unsafePerformIO ) import qualified System.FilePath.Posix as HtmlPath -import Distribution.Verbosity -import Distribution.ReadE #ifndef mingw32_HOST_OS import qualified System.Posix.Internals @@ -92,10 +93,27 @@ -- * Logging -------------------------------------------------------------------------------- +data Verbosity = Silent | Normal | Verbose | Deafening + deriving (Eq, Ord, Enum, Bounded, Show) -parseVerbosity :: String -> Either String Verbosity -parseVerbosity = runReadE flagToVerbosity +silent, normal, verbose, deafening :: Verbosity +silent = Silent +normal = Normal +verbose = Verbose +deafening = Deafening +-- | Parse out a verbosity level. Inspired from Cabal's verbosity parsing. +parseVerbosity :: String -> Either String Verbosity +parseVerbosity "0" = Right Silent +parseVerbosity "1" = Right Normal +parseVerbosity "2" = Right Silent +parseVerbosity "3" = Right Deafening +parseVerbosity "silent" = return Silent +parseVerbosity "normal" = return Normal +parseVerbosity "verbose" = return Verbose +parseVerbosity "debug" = return Deafening +parseVerbosity "deafening" = return Deafening +parseVerbosity other = Left ("Can't parse verbosity " ++ other) -- | Print a message to stdout, if it is not too verbose out :: MonadIO m @@ -395,6 +413,19 @@ isDigitChar c = c >= '0' && c <= '9' isAlphaNumChar c = isAlphaChar c || isDigitChar c +-- | Utility to write output to UTF-8 encoded files. +-- +-- The problem with 'writeFile' is that it picks up its 'TextEncoding' from +-- 'getLocaleEncoding', and on some platforms (like Windows) this default +-- encoding isn't enough for the characters we want to write. +writeUtf8File :: FilePath -> String -> IO () +writeUtf8File filepath contents = withFile filepath WriteMode $ \h -> do + hSetEncoding h utf8 + hPutStr h contents + +withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a +withTempDir dir = gbracket_ (liftIO $ createDirectory dir) + (liftIO $ removeDirectoryRecursive dir) ----------------------------------------------------------------------------- -- * HTML cross references diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs --- a/haddock-library/src/Documentation/Haddock/Markup.hs +++ b/haddock-library/src/Documentation/Haddock/Markup.hs @@ -2,35 +2,38 @@ module Documentation.Haddock.Markup ( markup , idMarkup + , plainMarkup ) where import Documentation.Haddock.Types +import Data.Maybe ( fromMaybe ) + markup :: DocMarkupH mod id a -> DocH mod id -> a -markup m DocEmpty = markupEmpty m -markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) -markup m (DocString s) = markupString m s -markup m (DocParagraph d) = markupParagraph m (markup m d) -markup m (DocIdentifier x) = markupIdentifier m x -markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x -markup m (DocModule mod0) = markupModule m mod0 -markup m (DocWarning d) = markupWarning m (markup m d) -markup m (DocEmphasis d) = markupEmphasis m (markup m d) -markup m (DocBold d) = markupBold m (markup m d) -markup m (DocMonospaced d) = markupMonospaced m (markup m d) -markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) -markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) -markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) -markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocHyperlink l) = markupHyperlink m l -markup m (DocAName ref) = markupAName m ref -markup m (DocPic img) = markupPic m img -markup m (DocMathInline mathjax) = markupMathInline m mathjax -markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax -markup m (DocProperty p) = markupProperty m p -markup m (DocExamples e) = markupExample m e -markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) -markup m (DocTable (Table h b)) = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b)) +markup m DocEmpty = markupEmpty m +markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) +markup m (DocString s) = markupString m s +markup m (DocParagraph d) = markupParagraph m (markup m d) +markup m (DocIdentifier x) = markupIdentifier m x +markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x +markup m (DocModule mod0) = markupModule m mod0 +markup m (DocWarning d) = markupWarning m (markup m d) +markup m (DocEmphasis d) = markupEmphasis m (markup m d) +markup m (DocBold d) = markupBold m (markup m d) +markup m (DocMonospaced d) = markupMonospaced m (markup m d) +markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) +markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) +markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) +markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) +markup m (DocHyperlink (Hyperlink u l)) = markupHyperlink m (Hyperlink u (fmap (markup m) l)) +markup m (DocAName ref) = markupAName m ref +markup m (DocPic img) = markupPic m img +markup m (DocMathInline mathjax) = markupMathInline m mathjax +markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax +markup m (DocProperty p) = markupProperty m p +markup m (DocExamples e) = markupExample m e +markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) +markup m (DocTable (Table h b)) = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b)) markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a) markupPair m (a,b) = (markup m a, markup m b) @@ -62,4 +65,35 @@ markupExample = DocExamples, markupHeader = DocHeader, markupTable = DocTable + } + +-- | Map a 'DocH' into a best estimate of an alternate string. The idea is to +-- strip away any formatting while preserving as much of the actual text as +-- possible. +plainMarkup :: (mod -> String) -> (id -> String) -> DocMarkupH mod id String +plainMarkup plainMod plainIdent = Markup { + markupEmpty = "", + markupString = id, + markupParagraph = id, + markupAppend = (++), + markupIdentifier = plainIdent, + markupIdentifierUnchecked = plainMod, + markupModule = id, + markupWarning = id, + markupEmphasis = id, + markupBold = id, + markupMonospaced = id, + markupUnorderedList = const "", + markupOrderedList = const "", + markupDefList = const "", + markupCodeBlock = id, + markupHyperlink = \(Hyperlink url lbl) -> fromMaybe url lbl, + markupAName = id, + markupPic = \(Picture uri title) -> fromMaybe uri title, + markupMathInline = id, + markupMathDisplay = id, + markupProperty = id, + markupExample = const "", + markupHeader = \(Header _ title) -> title, + markupTable = const "" } diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -27,14 +27,16 @@ import Control.Applicative import Control.Arrow (first) import Control.Monad -import Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace) -import Data.List (intercalate, unfoldr, elemIndex, notElem) +import Data.Char (chr, isUpper, isAlpha, isSpace) +import Data.List (intercalate, unfoldr, elemIndex) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import qualified Data.Set as Set import Documentation.Haddock.Doc +import Documentation.Haddock.Markup ( markup, plainMarkup ) import Documentation.Haddock.Parser.Monad import Documentation.Haddock.Parser.Util +import Documentation.Haddock.Parser.Identifier import Documentation.Haddock.Types import Prelude hiding (takeWhile) import qualified Prelude as P @@ -45,53 +47,26 @@ import qualified Data.Text as T import Data.Text (Text) -#if MIN_VERSION_base(4,9,0) -import Text.Read.Lex (isSymbolChar) -#else -import Data.Char (GeneralCategory (..), - generalCategory) -#endif -- $setup -- >>> :set -XOverloadedStrings -#if !MIN_VERSION_base(4,9,0) --- inlined from base-4.10.0.0 -isSymbolChar :: Char -> Bool -isSymbolChar c = not (isPuncChar c) && case generalCategory c of - MathSymbol -> True - CurrencySymbol -> True - ModifierSymbol -> True - OtherSymbol -> True - DashPunctuation -> True - OtherPunctuation -> c `notElem` ("'\"" :: String) - ConnectorPunctuation -> c /= '_' - _ -> False - where - -- | The @special@ character class as defined in the Haskell Report. - isPuncChar :: Char -> Bool - isPuncChar = (`elem` (",;()[]{}`" :: String)) -#endif - --- | Identifier string surrounded with opening and closing quotes/backticks. -type Identifier = (Char, String, Char) - -- | Drops the quotes/backticks around all identifiers, as if they -- were valid but still 'String's. toRegular :: DocH mod Identifier -> DocH mod String -toRegular = fmap (\(_, x, _) -> x) +toRegular = fmap (\(Identifier _ _ x _) -> x) -- | Maps over 'DocIdentifier's over 'String' with potentially failing -- conversion using user-supplied function. If the conversion fails, -- the identifier is deemed to not be valid and is treated as a -- regular string. -overIdentifier :: (String -> Maybe a) +overIdentifier :: (Namespace -> String -> Maybe a) -> DocH mod Identifier -> DocH mod a overIdentifier f d = g d where - g (DocIdentifier (o, x, e)) = case f x of - Nothing -> DocString $ o : x ++ [e] + g (DocIdentifier (Identifier ns o x e)) = case f ns x of + Nothing -> DocString $ renderNs ns ++ [o] ++ x ++ [e] Just x' -> DocIdentifier x' g DocEmpty = DocEmpty g (DocAppend x x') = DocAppend (g x) (g x') @@ -107,7 +82,7 @@ g (DocOrderedList x) = DocOrderedList $ fmap g x g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x g (DocCodeBlock x) = DocCodeBlock $ g x - g (DocHyperlink x) = DocHyperlink x + g (DocHyperlink (Hyperlink u x)) = DocHyperlink (Hyperlink u (fmap g x)) g (DocPic x) = DocPic x g (DocMathInline x) = DocMathInline x g (DocMathDisplay x) = DocMathDisplay x @@ -301,13 +276,20 @@ -- >>> parseString "\\[\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\]" -- DocMathDisplay "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}" mathDisplay :: Parser (DocH mod a) -mathDisplay = DocMathDisplay . T.unpack +mathDisplay = DocMathDisplay . T.unpack <$> ("\\[" *> takeUntil "\\]") -markdownImage :: Parser (DocH mod a) -markdownImage = fromHyperlink <$> ("!" *> linkParser) +-- | Markdown image parser. As per the commonmark reference recommendation, the +-- description text for an image converted to its a plain string representation. +-- +-- >>> parseString "![some /emphasis/ in a description](www.site.com)" +-- DocPic (Picture "www.site.com" (Just "some emphasis in a description")) +markdownImage :: Parser (DocH mod Identifier) +markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser) where - fromHyperlink (Hyperlink url label) = DocPic (Picture url label) + fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l) + stringMarkup = plainMarkup (const "") renderIdent + renderIdent (Identifier ns l c r) = renderNs ns <> [l] <> c <> [r] -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier) @@ -360,32 +342,34 @@ parseFirstRow :: Parser Text parseFirstRow = do skipHorizontalSpace - -- upper-left corner is + - c <- Parsec.char '+' - cs <- some (Parsec.char '-' <|> Parsec.char '+') + cs <- takeWhile (\c -> c == '-' || c == '+') - -- upper right corner is + too - guard (last cs == '+') + -- upper-left and upper-right corners are `+` + guard (T.length cs >= 2 && + T.head cs == '+' && + T.last cs == '+') -- trailing space skipHorizontalSpace _ <- Parsec.newline - return (T.cons c $ T.pack cs) + return cs parseRestRows :: Int -> Parser Text parseRestRows l = do skipHorizontalSpace + bs <- scan predicate l - c <- Parsec.char '|' <|> Parsec.char '+' - bs <- scan predicate (l - 2) - c2 <- Parsec.char '|' <|> Parsec.char '+' + -- Left and right edges are `|` or `+` + guard (T.length bs >= 2 && + (T.head bs == '|' || T.head bs == '+') && + (T.last bs == '|' || T.last bs == '+')) -- trailing space skipHorizontalSpace _ <- Parsec.newline - return (T.cons c (T.snoc bs c2)) + return bs where predicate n c | n <= 0 = Nothing @@ -662,7 +646,7 @@ -- Doesn't discard the trailing newline. takeNonEmptyLine :: Parser Text takeNonEmptyLine = do - l <- takeWhile1 (Parsec.noneOf "\n") >>= nonSpace + l <- takeWhile1 (/= '\n') >>= nonSpace _ <- "\n" pure (l <> "\n") @@ -732,7 +716,7 @@ nonEmptyLine = try (mfilter (T.any (not . isSpace)) takeLine) takeLine :: Parser Text -takeLine = try (takeWhile (Parsec.noneOf "\n") <* endOfLine) +takeLine = try (takeWhile (/= '\n') <* endOfLine) endOfLine :: Parser () endOfLine = void "\n" <|> Parsec.eof @@ -742,7 +726,7 @@ -- >>> snd <$> parseOnly property "prop> hello world" -- Right (DocProperty "hello world") property :: Parser (DocH mod a) -property = DocProperty . T.unpack . T.strip <$> ("prop>" *> takeWhile1 (Parsec.noneOf "\n")) +property = DocProperty . T.unpack . T.strip <$> ("prop>" *> takeWhile1 (/= '\n')) -- | -- Paragraph level codeblock. Anything between the two delimiting \@ is parsed @@ -782,22 +766,22 @@ | isNewline && isSpace c = Just isNewline | otherwise = Just $ c == '\n' -hyperlink :: Parser (DocH mod a) +hyperlink :: Parser (DocH mod Identifier) hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ] angleBracketLink :: Parser (DocH mod a) angleBracketLink = - DocHyperlink . makeLabeled Hyperlink + DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString) <$> disallowNewline ("<" *> takeUntil ">") -markdownLink :: Parser (DocH mod a) +markdownLink :: Parser (DocH mod Identifier) markdownLink = DocHyperlink <$> linkParser -linkParser :: Parser Hyperlink +linkParser :: Parser (Hyperlink (DocH mod Identifier)) linkParser = flip Hyperlink <$> label <*> (whitespace *> url) where - label :: Parser (Maybe String) - label = Just . decode . T.strip <$> ("[" *> takeUntil "]") + label :: Parser (Maybe (DocH mod Identifier)) + label = Just . parseParagraph . T.strip <$> ("[" *> takeUntil "]") whitespace :: Parser () whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace) @@ -816,41 +800,17 @@ autoUrl :: Parser (DocH mod a) autoUrl = mkLink <$> url where - url = mappend <$> choice' [ "http://", "https://", "ftp://"] <*> takeWhile1 (Parsec.satisfy (not . isSpace)) + url = mappend <$> choice' [ "http://", "https://", "ftp://"] <*> takeWhile1 (not . isSpace) mkLink :: Text -> DocH mod a mkLink s = case T.unsnoc s of Just (xs,x) | x `elem` (",.!?" :: String) -> DocHyperlink (mkHyperlink xs) `docAppend` DocString [x] _ -> DocHyperlink (mkHyperlink s) - mkHyperlink :: Text -> Hyperlink + mkHyperlink :: Text -> Hyperlink (DocH mod a) mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing - --- | Parses strings between identifier delimiters. Consumes all input that it --- deems to be valid in an identifier. Note that it simply blindly consumes --- characters and does no actual validation itself. -parseValid :: Parser String -parseValid = p some - where - idChar = Parsec.satisfy (\c -> isAlphaNum c || isSymbolChar c || c == '_') - - p p' = do - vs <- p' idChar - c <- peekChar' - case c of - '`' -> return vs - '\'' -> choice' [ (\x -> vs ++ "'" ++ x) <$> ("'" *> p many), return vs ] - _ -> fail "outofvalid" - --- | Parses identifiers with help of 'parseValid'. Asks GHC for --- 'String' from the string it deems valid. +-- | Parses identifiers with help of 'parseValid'. identifier :: Parser (DocH mod Identifier) -identifier = do - o <- idDelim - vid <- parseValid - e <- idDelim - return $ DocIdentifier (o, vid, e) - where - idDelim = Parsec.satisfy (\c -> c == '\'' || c == '`') +identifier = DocIdentifier <$> parseValid diff --git a/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs new file mode 100644 --- /dev/null +++ b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Documentation.Haddock.Parser.Identifier +-- Copyright : (c) Alec Theriault 2019, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Functionality for parsing identifiers and operators + +module Documentation.Haddock.Parser.Identifier ( + Identifier(..), + parseValid, +) where + +import Documentation.Haddock.Types ( Namespace(..) ) +import Documentation.Haddock.Parser.Monad +import qualified Text.Parsec as Parsec +import Text.Parsec.Pos ( updatePosChar ) +import Text.Parsec ( State(..) + , getParserState, setParserState ) + +import Data.Text (Text) +import qualified Data.Text as T + +import Data.Char (isAlpha, isAlphaNum) +import Control.Monad (guard) +import Data.Functor (($>)) +#if MIN_VERSION_base(4,9,0) +import Text.Read.Lex (isSymbolChar) +#else +import Data.Char (GeneralCategory (..), + generalCategory) +#endif + +import Data.Maybe + +-- | Identifier string surrounded with namespace, opening, and closing quotes/backticks. +data Identifier = Identifier !Namespace !Char String !Char + deriving (Show, Eq) + +parseValid :: Parser Identifier +parseValid = do + s@State{ stateInput = inp, statePos = pos } <- getParserState + + case takeIdentifier inp of + Nothing -> Parsec.parserFail "parseValid: Failed to match a valid identifier" + Just (ns, op, ident, cl, inp') -> + let posOp = updatePosChar pos op + posIdent = T.foldl updatePosChar posOp ident + posCl = updatePosChar posIdent cl + s' = s{ stateInput = inp', statePos = posCl } + in setParserState s' $> Identifier ns op (T.unpack ident) cl + + +#if !MIN_VERSION_base(4,9,0) +-- inlined from base-4.10.0.0 +isSymbolChar :: Char -> Bool +isSymbolChar c = not (isPuncChar c) && case generalCategory c of + MathSymbol -> True + CurrencySymbol -> True + ModifierSymbol -> True + OtherSymbol -> True + DashPunctuation -> True + OtherPunctuation -> c `notElem` "'\"" + ConnectorPunctuation -> c /= '_' + _ -> False + where + -- | The @special@ character class as defined in the Haskell Report. + isPuncChar :: Char -> Bool + isPuncChar = (`elem` (",;()[]{}`" :: String)) +#endif + +-- | Try to parse a delimited identifier off the front of the given input. +-- +-- This tries to match as many valid Haskell identifiers/operators as possible, +-- to the point of sometimes accepting invalid things (ex: keywords). Some +-- considerations: +-- +-- - operators and identifiers can have module qualifications +-- - operators can be wrapped in parens (for prefix) +-- - identifiers can be wrapped in backticks (for infix) +-- - delimiters are backticks or regular ticks +-- - since regular ticks are also valid in identifiers, we opt for the +-- longest successful parse +-- +-- This function should make /O(1)/ allocations +takeIdentifier :: Text -> Maybe (Namespace, Char, Text, Char, Text) +takeIdentifier input = listToMaybe $ do + + -- Optional namespace + let (ns, input') = case T.uncons input of + Just ('v', i) -> (Value, i) + Just ('t', i) -> (Type, i) + _ -> (None, input) + + -- Opening tick + (op, input'') <- maybeToList (T.uncons input') + guard (op == '\'' || op == '`') + + -- Identifier/operator + (ident, input''') <- wrapped input'' + + -- Closing tick + (cl, input'''') <- maybeToList (T.uncons input''') + guard (cl == '\'' || cl == '`') + + return (ns, op, ident, cl, input'''') + + where + + -- | Parse out a wrapped, possibly qualified, operator or identifier + wrapped t = do + (c, t' ) <- maybeToList (T.uncons t) + -- Tuples + case c of + '(' | Just (c', _) <- T.uncons t' + , c' == ',' || c' == ')' + -> do let (commas, t'') = T.span (== ',') t' + (')', t''') <- maybeToList (T.uncons t'') + return (T.take (T.length commas + 2) t, t''') + + -- Parenthesized + '(' -> do (n, t'' ) <- general False 0 [] t' + (')', t''') <- maybeToList (T.uncons t'') + return (T.take (n + 2) t, t''') + + -- Backticked + '`' -> do (n, t'' ) <- general False 0 [] t' + ('`', t''') <- maybeToList (T.uncons t'') + return (T.take (n + 2) t, t''') + + -- Unadorned + _ -> do (n, t'' ) <- general False 0 [] t + return (T.take n t, t'') + + -- | Parse out a possibly qualified operator or identifier + general :: Bool -- ^ refuse inputs starting with operators + -> Int -- ^ total characters \"consumed\" so far + -> [(Int, Text)] -- ^ accumulated results + -> Text -- ^ current input + -> [(Int, Text)] -- ^ total characters parsed & what remains + general !identOnly !i acc t + -- Starts with an identifier (either just an identifier, or a module qual) + | Just (n, rest) <- identLike t + = if T.null rest + then acc + else case T.head rest of + '`' -> (n + i, rest) : acc + ')' -> (n + i, rest) : acc + '.' -> general False (n + i + 1) acc (T.tail rest) + '\'' -> let (m, rest') = quotes rest + in general True (n + m + 1 + i) ((n + m + i, rest') : acc) (T.tail rest') + _ -> acc + + -- An operator + | Just (n, rest) <- optr t + , not identOnly + = (n + i, rest) : acc + + -- Anything else + | otherwise + = acc + + -- | Parse an identifier off the front of the input + identLike t + | T.null t = Nothing + | isAlpha (T.head t) || '_' == T.head t + = let !(idt, rest) = T.span (\c -> isAlphaNum c || c == '_') t + !(octos, rest') = T.span (== '#') rest + in Just (T.length idt + T.length octos, rest') + | otherwise = Nothing + + -- | Parse all but the last quote off the front of the input + -- PRECONDITION: T.head t == '\'' + quotes :: Text -> (Int, Text) + quotes t = let !n = T.length (T.takeWhile (== '\'') t) - 1 + in (n, T.drop n t) + + -- | Parse an operator off the front of the input + optr t = let !(op, rest) = T.span isSymbolChar t + in if T.null op then Nothing else Just (T.length op, rest) diff --git a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs --- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs @@ -4,15 +4,32 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Module : Documentation.Haddock.Parser.Monad +-- Copyright : (c) Alec Theriault 2018-2019, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Defines the Parsec monad over which all parsing is done and also provides +-- more efficient versions of the usual parsec combinator functions (but +-- specialized to 'Text'). module Documentation.Haddock.Parser.Monad where import qualified Text.Parsec.Char as Parsec import qualified Text.Parsec as Parsec +import Text.Parsec.Pos ( updatePosChar ) +import Text.Parsec ( State(..) + , getParserState, setParserState ) import qualified Data.Text as T import Data.Text ( Text ) +import Control.Monad ( mfilter ) +import Data.Functor ( ($>) ) import Data.String ( IsString(..) ) import Data.Bits ( Bits(..) ) import Data.Char ( ord ) @@ -20,7 +37,11 @@ import Control.Applicative as App import Documentation.Haddock.Types ( Version ) +import Prelude hiding (takeWhile) +-- | The only bit of information we really care about truding along with us +-- through parsing is the version attached to a @\@since@ annotation - if +-- the doc even contained one. newtype ParserState = ParserState { parserStateSince :: Maybe Version } deriving (Eq, Show) @@ -29,7 +50,7 @@ initialParserState = ParserState Nothing setSince :: Version -> Parser () -setSince since = Parsec.modifyState (\st -> st {parserStateSince = Just since}) +setSince since = Parsec.modifyState (\st -> st{ parserStateSince = Just since }) type Parser = Parsec.Parsec Text ParserState @@ -44,38 +65,74 @@ -- | Always succeeds, but returns 'Nothing' if at the end of input. Does not -- consume input. +-- +-- Equivalent to @Parsec.optionMaybe . Parsec.lookAhead $ Parsec.anyChar@, but +-- more efficient. peekChar :: Parser (Maybe Char) -peekChar = Parsec.optionMaybe . Parsec.try . Parsec.lookAhead $ Parsec.anyChar +peekChar = headOpt . stateInput <$> getParserState + where headOpt t | T.null t = Nothing + | otherwise = Just (T.head t) +{-# INLINE peekChar #-} -- | Fails if at the end of input. Does not consume input. +-- +-- Equivalent to @Parsec.lookAhead Parsec.anyChar@, but more efficient. peekChar' :: Parser Char -peekChar' = Parsec.lookAhead Parsec.anyChar +peekChar' = headFail . stateInput =<< getParserState + where headFail t | T.null t = Parsec.parserFail "peekChar': reached EOF" + | otherwise = App.pure (T.head t) +{-# INLINE peekChar' #-} -- | Parses the given string. Returns the parsed string. +-- +-- Equivalent to @Parsec.string (T.unpack t) $> t@, but more efficient. string :: Text -> Parser Text -string t = Parsec.string (T.unpack t) *> App.pure t +string t = do + s@State{ stateInput = inp, statePos = pos } <- getParserState + case T.stripPrefix t inp of + Nothing -> Parsec.parserFail "string: Failed to match the input string" + Just inp' -> + let pos' = T.foldl updatePosChar pos t + s' = s{ stateInput = inp', statePos = pos' } + in setParserState s' $> t +-- | Keep matching characters as long as the predicate function holds (and +-- return them). +-- +-- Equivalent to @fmap T.pack . Parsec.many@, but more efficient. +takeWhile :: (Char -> Bool) -> Parser Text +takeWhile f = do + s@State{ stateInput = inp, statePos = pos } <- getParserState + let (t, inp') = T.span f inp + pos' = T.foldl updatePosChar pos t + s' = s{ stateInput = inp', statePos = pos' } + setParserState s' $> t + +-- | Like 'takeWhile', but fails if no characters matched. +-- +-- Equivalent to @fmap T.pack . Parsec.many1@, but more efficient. +takeWhile1 :: (Char -> Bool) -> Parser Text +takeWhile1 = mfilter (not . T.null) . takeWhile + -- | Scan the input text, accumulating characters as long as the scanning -- function returns true. scan :: (s -> Char -> Maybe s) -- ^ scan function -> s -- ^ initial state -> Parser Text -scan f = fmap T.pack . go - where go s1 = do { cOpt <- peekChar - ; case cOpt >>= f s1 of - Nothing -> pure "" - Just s2 -> (:) <$> Parsec.anyChar <*> go s2 - } - --- | Apply a parser for a character zero or more times and collect the result in --- a string. -takeWhile :: Parser Char -> Parser Text -takeWhile = fmap T.pack . Parsec.many +scan f st = do + s@State{ stateInput = inp, statePos = pos } <- getParserState + go inp st pos 0 $ \inp' pos' n -> + let s' = s{ Parsec.stateInput = inp', Parsec.statePos = pos' } + in setParserState s' $> T.take n inp + where + go inp s !pos !n cont + = case T.uncons inp of + Nothing -> cont inp pos n -- ran out of input + Just (c, inp') -> + case f s c of + Nothing -> cont inp pos n -- scan function failed + Just s' -> go inp' s' (updatePosChar pos c) (n+1) cont --- | Apply a parser for a character one or more times and collect the result in --- a string. -takeWhile1 :: Parser Char -> Parser Text -takeWhile1 = fmap T.pack . Parsec.many1 -- | Parse a decimal number. decimal :: Integral a => Parser a diff --git a/haddock-library/src/Documentation/Haddock/Parser/Util.hs b/haddock-library/src/Documentation/Haddock/Parser/Util.hs --- a/haddock-library/src/Documentation/Haddock/Parser/Util.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Util.hs @@ -40,7 +40,7 @@ -- | Take leading horizontal space takeHorizontalSpace :: Parser Text -takeHorizontalSpace = takeWhile (Parsec.oneOf horizontalSpace) +takeHorizontalSpace = takeWhile (`elem` horizontalSpace) makeLabeled :: (String -> Maybe String -> a) -> Text -> a makeLabeled f input = case T.break isSpace $ removeEscapes $ T.strip input of diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -65,10 +65,10 @@ type Version = [Int] type Package = String -data Hyperlink = Hyperlink +data Hyperlink id = Hyperlink { hyperlinkUrl :: String - , hyperlinkLabel :: Maybe String - } deriving (Eq, Show) + , hyperlinkLabel :: Maybe id + } deriving (Eq, Show, Functor, Foldable, Traversable) data Picture = Picture { pictureUri :: String @@ -118,7 +118,7 @@ | DocOrderedList [DocH mod id] | DocDefList [(DocH mod id, DocH mod id)] | DocCodeBlock (DocH mod id) - | DocHyperlink Hyperlink + | DocHyperlink (Hyperlink (DocH mod id)) | DocPic Picture | DocMathInline String | DocMathDisplay String @@ -147,7 +147,7 @@ bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs) bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs) bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc) - bimap _ _ (DocHyperlink hyperlink) = DocHyperlink hyperlink + bimap f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink (Hyperlink url (fmap (bimap f g) lbl)) bimap _ _ (DocPic picture) = DocPic picture bimap _ _ (DocMathInline s) = DocMathInline s bimap _ _ (DocMathDisplay s) = DocMathDisplay s @@ -192,7 +192,7 @@ bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs bitraverse f g (DocDefList docs) = DocDefList <$> traverse (bitraverse (bitraverse f g) (bitraverse f g)) docs bitraverse f g (DocCodeBlock doc) = DocCodeBlock <$> bitraverse f g doc - bitraverse _ _ (DocHyperlink hyperlink) = pure (DocHyperlink hyperlink) + bitraverse f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink <$> (Hyperlink url <$> traverse (bitraverse f g) lbl) bitraverse _ _ (DocPic picture) = pure (DocPic picture) bitraverse _ _ (DocMathInline s) = pure (DocMathInline s) bitraverse _ _ (DocMathDisplay s) = pure (DocMathDisplay s) @@ -203,6 +203,16 @@ bitraverse f g (DocTable (Table header body)) = (\h b -> DocTable (Table h b)) <$> traverse (traverse (bitraverse f g)) header <*> traverse (traverse (bitraverse f g)) body #endif +-- | The namespace qualification for an identifier. +data Namespace = Value | Type | None deriving (Eq, Ord, Enum, Show) + +-- | Render the a namespace into the same format it was initially parsed. +renderNs :: Namespace -> String +renderNs Value = "v" +renderNs Type = "t" +renderNs None = "" + + -- | 'DocMarkupH' is a set of instructions for marking up documentation. -- In fact, it's really just a mapping from 'Doc' to some other -- type [a], where [a] is usually the type of the output (HTML, say). @@ -227,7 +237,7 @@ , markupOrderedList :: [a] -> a , markupDefList :: [(a,a)] -> a , markupCodeBlock :: a -> a - , markupHyperlink :: Hyperlink -> a + , markupHyperlink :: Hyperlink a -> a , markupAName :: String -> a , markupPic :: Picture -> a , markupMathInline :: String -> a diff --git a/haddock-library/src/Documentation/Haddock/Utf8.hs b/haddock-library/src/Documentation/Haddock/Utf8.hs deleted file mode 100644 --- a/haddock-library/src/Documentation/Haddock/Utf8.hs +++ /dev/null @@ -1,74 +0,0 @@ -module Documentation.Haddock.Utf8 (encodeUtf8, decodeUtf8) where -import Data.Bits ((.|.), (.&.), shiftL, shiftR) -import qualified Data.ByteString as BS -import Data.Char (chr, ord) -import Data.Word (Word8) - --- | Helper that encodes and packs a 'String' into a 'BS.ByteString' -encodeUtf8 :: String -> BS.ByteString -encodeUtf8 = BS.pack . encode - --- | Helper that unpacks and decodes a 'BS.ByteString' into a 'String' -decodeUtf8 :: BS.ByteString -> String -decodeUtf8 = decode . BS.unpack - --- Copy/pasted functions from Codec.Binary.UTF8.String for encoding/decoding --- | Character to use when 'encode' or 'decode' fail for a byte. -replacementCharacter :: Char -replacementCharacter = '\xfffd' - --- | Encode a Haskell String to a list of Word8 values, in UTF8 format. -encode :: String -> [Word8] -encode = concatMap (map fromIntegral . go . ord) - where - go oc - | oc <= 0x7f = [oc] - - | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) - , 0x80 + oc .&. 0x3f - ] - - | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - | otherwise = [ 0xf0 + (oc `shiftR` 18) - , 0x80 + ((oc `shiftR` 12) .&. 0x3f) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - --- | Decode a UTF8 string packed into a list of Word8 values, directly to String -decode :: [Word8] -> String -decode [ ] = "" -decode (c:cs) - | c < 0x80 = chr (fromEnum c) : decode cs - | c < 0xc0 = replacementCharacter : decode cs - | c < 0xe0 = multi1 - | c < 0xf0 = multi_byte 2 0xf 0x800 - | c < 0xf8 = multi_byte 3 0x7 0x10000 - | c < 0xfc = multi_byte 4 0x3 0x200000 - | c < 0xfe = multi_byte 5 0x1 0x4000000 - | otherwise = replacementCharacter : decode cs - where - multi1 = case cs of - c1 : ds | c1 .&. 0xc0 == 0x80 -> - let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f) - in if d >= 0x000080 then toEnum d : decode ds - else replacementCharacter : decode ds - _ -> replacementCharacter : decode cs - - multi_byte :: Int -> Word8 -> Int -> String - multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask)) - where - aux 0 rs acc - | overlong <= acc && acc <= 0x10ffff && - (acc < 0xd800 || 0xdfff < acc) && - (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs - | otherwise = replacementCharacter : decode rs - - aux n (r:rs) acc - | r .&. 0xc0 == 0x80 = aux (n-1) rs - $ shiftL acc 6 .|. fromEnum (r .&. 0x3f) - - aux _ rs _ = replacementCharacter : decode rs diff --git a/haddock.cabal b/haddock.cabal --- a/haddock.cabal +++ b/haddock.cabal @@ -1,6 +1,6 @@ -cabal-version: 2.0 +cabal-version: 2.4 name: haddock -version: 2.22.0 +version: 2.23.0 synopsis: A documentation-generation tool for Haskell libraries description: This is Haddock, a tool for automatically generating documentation @@ -23,8 +23,8 @@ without any documentation annotations, Haddock can generate useful documentation from your source code. . - <> -license: BSD3 + <> +license: BSD-3-Clause license-file: LICENSE author: Simon Marlow, David Waern maintainer: Alec Theriault , Alex Biehl , Simon Hengel , Mateusz Kowalczyk @@ -33,7 +33,7 @@ copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -tested-with: GHC==8.6.* +tested-with: GHC==8.8.* extra-source-files: CHANGES.md @@ -47,9 +47,10 @@ html-test/ref/*.html hypsrc-test/src/*.hs hypsrc-test/ref/src/*.html - latex-test/src/Simple/*.hs - latex-test/ref/Simple/*.tex - latex-test/ref/Simple/*.sty + latex-test/src/**/*.hs + latex-test/ref/**/*.tex + hoogle-test/src/**/*.hs + hoogle-test/ref/**/*.txt flag in-ghc-tree description: Are we in a GHC tree? @@ -62,9 +63,9 @@ hs-source-dirs: driver ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded - -- haddock typically only supports a single GHC major version + -- haddock typically only supports a single GHC major version build-depends: - base ^>= 4.12.0 + base ^>= 4.13.0.0 if flag(in-ghc-tree) hs-source-dirs: haddock-api/src, haddock-library/src @@ -76,9 +77,8 @@ deepseq, array, xhtml >= 3000.2 && < 3000.3, - Cabal >= 1.10, ghc-boot, - ghc == 8.6.*, + ghc == 8.8.*, bytestring, parsec, text, @@ -87,9 +87,9 @@ other-modules: Documentation.Haddock.Parser Documentation.Haddock.Parser.Monad + Documentation.Haddock.Parser.Identifier Documentation.Haddock.Types Documentation.Haddock.Doc - Documentation.Haddock.Utf8 Documentation.Haddock.Parser.Util Documentation.Haddock.Markup @@ -119,7 +119,6 @@ Haddock.Backends.HaddockDB Haddock.Backends.Hoogle Haddock.Backends.Hyperlinker - Haddock.Backends.Hyperlinker.Ast Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Renderer Haddock.Backends.Hyperlinker.Types @@ -142,7 +141,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.22.0 + build-depends: haddock-api == 2.23.0 test-suite html-test type: exitcode-stdio-1.0 diff --git a/hoogle-test/ref/Bug722/test.txt b/hoogle-test/ref/Bug722/test.txt new file mode 100644 --- /dev/null +++ b/hoogle-test/ref/Bug722/test.txt @@ -0,0 +1,16 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Bug722 +class Foo a +(!@#) :: Foo a => a -> a -> a +infixl 4 !@# +type family (&*) :: * -> * -> * +infixr 3 &* +data a :-& b +(:^&) :: a -> b -> (:-&) a b +infixl 6 :-& +infixl 6 :^& diff --git a/hoogle-test/ref/Bug806/test.txt b/hoogle-test/ref/Bug806/test.txt new file mode 100644 --- /dev/null +++ b/hoogle-test/ref/Bug806/test.txt @@ -0,0 +1,25 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Bug806 + +-- | F1 docs +type family F1 a b :: * -> * + +-- | F2 docs +type family F2 a b :: * -> * + +-- | D docs +data family D a :: * -> * +v :: Int + +-- | C docs +class C a where { + + -- | AT docs + type family AT a; + type AT a = Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy))))))))); +} diff --git a/hoogle-test/ref/Bug825/test.txt b/hoogle-test/ref/Bug825/test.txt new file mode 100644 --- /dev/null +++ b/hoogle-test/ref/Bug825/test.txt @@ -0,0 +1,9 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Bug825 +data a :~: b +data (:~~:) a b diff --git a/hoogle-test/ref/Bug873/test.txt b/hoogle-test/ref/Bug873/test.txt new file mode 100644 --- /dev/null +++ b/hoogle-test/ref/Bug873/test.txt @@ -0,0 +1,27 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Bug873 + +-- | Application operator. This operator is redundant, since ordinary +-- application (f x) means the same as (f $ x). +-- However, $ has low, right-associative binding precedence, so it +-- sometimes allows parentheses to be omitted; for example: +-- +-- 
+--   f $ g $ h x  =  f (g (h x))
+--
+-- +-- It is also useful in higher-order situations, such as map +-- ($ 0) xs, or zipWith ($) fs xs. +-- +-- Note that ($) is levity-polymorphic in its result +-- type, so that foo $ True where foo :: Bool -> +-- Int# is well-typed. +($) :: forall (r :: RuntimeRep) a (b :: TYPE r). (a -> b) -> a -> b +infixr 0 $ +($$) :: (a -> b) -> a -> b +infixr 0 $$ diff --git a/hoogle-test/ref/Bug946/test.txt b/hoogle-test/ref/Bug946/test.txt new file mode 100644 --- /dev/null +++ b/hoogle-test/ref/Bug946/test.txt @@ -0,0 +1,19 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Bug946 + +-- | A wrapper around Int +data AnInt + +-- | some Int +AnInt :: Int -> AnInt + +-- | The Int 0 +pattern Zero :: AnInt + +-- | The double 2.5 +pattern TwoPointFive :: Double diff --git a/hoogle-test/ref/Bug992/test.txt b/hoogle-test/ref/Bug992/test.txt new file mode 100644 --- /dev/null +++ b/hoogle-test/ref/Bug992/test.txt @@ -0,0 +1,9 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Bug992 +data K (m :: * -> *) +K :: K (m :: * -> *) diff --git a/hoogle-test/ref/assoc-types/test.txt b/hoogle-test/ref/assoc-types/test.txt new file mode 100644 --- /dev/null +++ b/hoogle-test/ref/assoc-types/test.txt @@ -0,0 +1,14 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module AssocTypes +class Foo a where { + type family Bar a b; + type family Baz a; + type Baz a = [(a, a)]; +} +bar :: Foo a => Bar a a +instance AssocTypes.Foo [a] diff --git a/hoogle-test/ref/classes/test.txt b/hoogle-test/ref/classes/test.txt new file mode 100644 --- /dev/null +++ b/hoogle-test/ref/classes/test.txt @@ -0,0 +1,17 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Classes +class Foo f +bar :: Foo f => f a -> f b -> f (a, b) +baz :: Foo f => f () +class Quux q +(+++) :: Quux q => q -> q -> q +(///) :: Quux q => q -> q -> q +(***) :: Quux q => q -> q -> q +logBase :: Quux q => q -> q -> q +foo :: Quux q => q -> q -> q +quux :: Quux q => q -> q -> q diff --git a/hoogle-test/ref/fixity/test.txt b/hoogle-test/ref/fixity/test.txt new file mode 100644 --- /dev/null +++ b/hoogle-test/ref/fixity/test.txt @@ -0,0 +1,13 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Fixity +(+++) :: a -> a -> a +infix 6 +++ +(***) :: a -> a -> a +infixl 7 *** +(///) :: a -> a -> a +infixr 8 /// diff --git a/hoogle-test/ref/modules/test.txt b/hoogle-test/ref/modules/test.txt new file mode 100644 --- /dev/null +++ b/hoogle-test/ref/modules/test.txt @@ -0,0 +1,13 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Foo +foo :: Int -> Int +foo' :: Int -> Int -> Int + +module Bar +bar :: Int -> Int +bar' :: Int -> Int -> Int diff --git a/hoogle-test/ref/type-sigs/test.txt b/hoogle-test/ref/type-sigs/test.txt new file mode 100644 --- /dev/null +++ b/hoogle-test/ref/type-sigs/test.txt @@ -0,0 +1,16 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module ReaderT +newtype ReaderT r m a +ReaderT :: (r -> m a) -> ReaderT r m a +[runReaderT] :: ReaderT r m a -> r -> m a + +module ReaderTReexport +newtype ReaderT r m a +ReaderT :: (r -> m a) -> ReaderT r m a +[runReaderT] :: ReaderT r m a -> r -> m a +runReaderT :: ReaderT r m a -> r -> m a diff --git a/hoogle-test/src/Bug722/Bug722.hs b/hoogle-test/src/Bug722/Bug722.hs new file mode 100644 --- /dev/null +++ b/hoogle-test/src/Bug722/Bug722.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeOperators, TypeFamilies #-} +module Bug722 where + +class Foo a where + (!@#) :: a -> a -> a +infixl 4 !@# + +type family (&*) :: * -> * -> * +infixr 3 &* + +data a :-& b = a :^& b +infixl 6 :-&, :^& + diff --git a/hoogle-test/src/Bug806/Bug806.hs b/hoogle-test/src/Bug806/Bug806.hs new file mode 100644 --- /dev/null +++ b/hoogle-test/src/Bug806/Bug806.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Bug806 where + +import Data.Proxy + +-- | 'F1' docs +type family F1 a b :: * -> * +-- | 'F2' docs +type family F2 a b :: * -> * where + F2 Int b = Maybe + F2 a b = [] +-- | 'D' docs +data family D a :: * -> * + +v :: Int +v = 42 + +-- | 'C' docs +class C a where + -- | 'AT' docs + type AT a + type AT a = Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy))))))))) diff --git a/hoogle-test/src/Bug825/Bug825.hs b/hoogle-test/src/Bug825/Bug825.hs new file mode 100644 --- /dev/null +++ b/hoogle-test/src/Bug825/Bug825.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +module Bug825 where + +data a :~: b +data (:~~:) a b diff --git a/hoogle-test/src/Bug873/Bug873.hs b/hoogle-test/src/Bug873/Bug873.hs new file mode 100644 --- /dev/null +++ b/hoogle-test/src/Bug873/Bug873.hs @@ -0,0 +1,5 @@ +module Bug873 (($), ($$)) where +infixr 0 $$ + +($$) :: (a -> b) -> a -> b +f $$ x = f x diff --git a/hoogle-test/src/Bug946/Bug946.hs b/hoogle-test/src/Bug946/Bug946.hs new file mode 100644 --- /dev/null +++ b/hoogle-test/src/Bug946/Bug946.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PatternSynonyms #-} +module Bug946 ( + AnInt(AnInt, Zero), + pattern TwoPointFive, +) where + +-- | A wrapper around 'Int' +data AnInt = AnInt Int -- ^ some 'Int' + +-- | The 'Int' 0 +pattern Zero :: AnInt +pattern Zero = AnInt 0 + +-- | The double 2.5 +pattern TwoPointFive :: Double +pattern TwoPointFive = 2.5 diff --git a/hoogle-test/src/Bug992/Bug992.hs b/hoogle-test/src/Bug992/Bug992.hs new file mode 100644 --- /dev/null +++ b/hoogle-test/src/Bug992/Bug992.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE KindSignatures #-} + +module Bug992 where + +data K (m :: * -> *) = K diff --git a/hoogle-test/src/assoc-types/AssocTypes.hs b/hoogle-test/src/assoc-types/AssocTypes.hs new file mode 100644 --- /dev/null +++ b/hoogle-test/src/assoc-types/AssocTypes.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + + +module AssocTypes where + + +class Foo a where + + type Bar a b + type Baz a + + type Baz a = [(a, a)] + + bar :: Bar a a + bar = undefined + + +instance Foo [a] where + + type Bar [a] Int = [(a, Bool)] + type Bar [a] Bool = [(Int, a)] + + type Baz [a] = (a, a, a) diff --git a/hoogle-test/src/classes/Classes.hs b/hoogle-test/src/classes/Classes.hs new file mode 100644 --- /dev/null +++ b/hoogle-test/src/classes/Classes.hs @@ -0,0 +1,16 @@ +module Classes where + + +class Foo f where + + bar :: f a -> f b -> f (a, b) + baz :: f () + + baz = undefined + + +class Quux q where + + (+++), (///) :: q -> q -> q + (***), logBase :: q -> q -> q + foo, quux :: q -> q -> q diff --git a/hoogle-test/src/fixity/Fixity.hs b/hoogle-test/src/fixity/Fixity.hs new file mode 100644 --- /dev/null +++ b/hoogle-test/src/fixity/Fixity.hs @@ -0,0 +1,12 @@ +module Fixity where + + +(+++), (***), (///) :: a -> a -> a +(+++) = undefined +(***) = undefined +(///) = undefined + + +infix 6 +++ +infixl 7 *** +infixr 8 /// diff --git a/hoogle-test/src/modules/Bar.hs b/hoogle-test/src/modules/Bar.hs new file mode 100644 --- /dev/null +++ b/hoogle-test/src/modules/Bar.hs @@ -0,0 +1,12 @@ +module Bar where + + +import Foo + + +bar :: Int -> Int +bar x = foo' x x + + +bar' :: Int -> Int -> Int +bar' x y = foo' (bar (foo x)) (bar (foo y)) diff --git a/hoogle-test/src/modules/Foo.hs b/hoogle-test/src/modules/Foo.hs new file mode 100644 --- /dev/null +++ b/hoogle-test/src/modules/Foo.hs @@ -0,0 +1,9 @@ +module Foo where + + +foo :: Int -> Int +foo = (* 2) + + +foo' :: Int -> Int -> Int +foo' x y = foo x + foo y diff --git a/hoogle-test/src/type-sigs/ReaderT.hs b/hoogle-test/src/type-sigs/ReaderT.hs new file mode 100644 --- /dev/null +++ b/hoogle-test/src/type-sigs/ReaderT.hs @@ -0,0 +1,3 @@ +module ReaderT where + +newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a } diff --git a/hoogle-test/src/type-sigs/ReaderTReexport.hs b/hoogle-test/src/type-sigs/ReaderTReexport.hs new file mode 100644 --- /dev/null +++ b/hoogle-test/src/type-sigs/ReaderTReexport.hs @@ -0,0 +1,3 @@ +module ReaderTReexport (ReaderT(..), runReaderT) where + +import ReaderT diff --git a/html-test/Main.hs b/html-test/Main.hs --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -45,7 +45,7 @@ -- | List of modules in which we don't 'stripLinks' preserveLinksModules :: [String] -preserveLinksModules = ["Bug253"] +preserveLinksModules = ["Bug253.html", "NamespacedIdentifiers.html"] ingoredTests :: [FilePath] ingoredTests = diff --git a/html-test/ref/A.html b/html-test/ref/A.html --- a/html-test/ref/A.html +++ b/html-test/ref/A.html @@ -1,18 +1,24 @@ A
B
Bug1
Bug1004
Safe HaskellSafe

Bug1004

Synopsis

Documentation

data Product (f :: k -> Type) (g :: k -> Type) (a :: k) #

Lifted product of functors.

Constructors

Pair (f a) (g a)

Instances

Instances details
Generic1 (Product f g :: k -> Type)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Associated Types

type Rep1 (Product f g) :: k -> Type #

Methods

from1 :: forall (a :: k0). Product f g a -> Rep1 (Product f g) a #

to1 :: forall (a :: k0). Rep1 (Product f g) a -> Product f g a #

(Monad f, Monad g) => Monad (Product f g)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

(>>=) :: Product f g a -> (a -> Product f g b) -> Product f g b #

(>>) :: Product f g a -> Product f g b -> Product f g b #

return :: a -> Product f g a #

(Functor f, Functor g) => Functor (Product f g)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

fmap :: (a -> b) -> Product f g a -> Product f g b #

(<$) :: a -> Product f g b -> Product f g a #

(MonadFix f, MonadFix g) => MonadFix (Product f g)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

mfix :: (a -> Product f g a) -> Product f g a #

(Applicative f, Applicative g) => Applicative (Product f g)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

pure :: a -> Product f g a #

(<*>) :: Product f g (a -> b) -> Product f g a -> Product f g b #

liftA2 :: (a -> b -> c) -> Product f g a -> Product f g b -> Product f g c #

(*>) :: Product f g a -> Product f g b -> Product f g b #

(<*) :: Product f g a -> Product f g b -> Product f g a #

(Foldable f, Foldable g) => Foldable (Product f g)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

fold :: Monoid m => Product f g m -> m #

foldMap :: Monoid m => (a -> m) -> Product f g a -> m #

foldMap' :: Monoid m => (a -> m) -> Product f g a -> m #

foldr :: (a -> b -> b) -> b -> Product f g a -> b #

foldr' :: (a -> b -> b) -> b -> Product f g a -> b #

foldl :: (b -> a -> b) -> b -> Product f g a -> b #

foldl' :: (b -> a -> b) -> b -> Product f g a -> b #

foldr1 :: (a -> a -> a) -> Product f g a -> a #

foldl1 :: (a -> a -> a) -> Product f g a -> a #

toList :: Product f g a -> [a] #

null :: Product f g a -> Bool #

length :: Product f g a -> Int #

elem :: Eq a => a -> Product f g a -> Bool #

maximum :: Ord a => Product f g a -> a #

minimum :: Ord a => Product f g a -> a #

sum :: Num a => Product f g a -> a #

product :: Num a => Product f g a -> a #

(Traversable f, Traversable g) => Traversable (Product f g)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

traverse :: Applicative f0 => (a -> f0 b) -> Product f g a -> f0 (Product f g b) #

sequenceA :: Applicative f0 => Product f g (f0 a) -> f0 (Product f g a) #

mapM :: Monad m => (a -> m b) -> Product f g a -> m (Product f g b) #

sequence :: Monad m => Product f g (m a) -> m (Product f g a) #

(Eq1 f, Eq1 g) => Eq1 (Product f g)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

liftEq :: (a -> b -> Bool) -> Product f g a -> Product f g b -> Bool #

(Ord1 f, Ord1 g) => Ord1 (Product f g)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

liftCompare :: (a -> b -> Ordering) -> Product f g a -> Product f g b -> Ordering #

(Read1 f, Read1 g) => Read1 (Product f g)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Product f g a) #

liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [Product f g a] #

liftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (Product f g a) #

liftReadListPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec [Product f g a] #

(Show1 f, Show1 g) => Show1 (Product f g)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Product f g a -> ShowS #

liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> [Product f g a] -> ShowS #

(MonadZip f, MonadZip g) => MonadZip (Product f g)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

mzip :: Product f g a -> Product f g b -> Product f g (a, b) #

mzipWith :: (a -> b -> c) -> Product f g a -> Product f g b -> Product f g c #

munzip :: Product f g (a, b) -> (Product f g a, Product f g b) #

(Alternative f, Alternative g) => Alternative (Product f g)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

empty :: Product f g a #

(<|>) :: Product f g a -> Product f g a -> Product f g a #

some :: Product f g a -> Product f g [a] #

many :: Product f g a -> Product f g [a] #

(MonadPlus f, MonadPlus g) => MonadPlus (Product f g)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

mzero :: Product f g a #

mplus :: Product f g a -> Product f g a -> Product f g a #

(Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

(==) :: Product f g a -> Product f g a -> Bool #

(/=) :: Product f g a -> Product f g a -> Bool #

(Typeable a, Typeable f, Typeable g, Typeable k, Data (f a), Data (g a)) => Data (Product f g a)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b) -> (forall g0. g0 -> c g0) -> Product f g a -> c (Product f g a) #

gunfold :: (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c (Product f g a) #

toConstr :: Product f g a -> Constr #

dataTypeOf :: Product f g a -> DataType #

dataCast1 :: Typeable t => (forall d. Data d => c (t d)) -> Maybe (c (Product f g a)) #

dataCast2 :: Typeable t => (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Product f g a)) #

gmapT :: (forall b. Data b => b -> b) -> Product f g a -> Product f g a #

gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Product f g a -> r #

gmapQr :: forall r r'. (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Product f g a -> r #

gmapQ :: (forall d. Data d => d -> u) -> Product f g a -> [u] #

gmapQi :: Int -> (forall d. Data d => d -> u) -> Product f g a -> u #

gmapM :: Monad m => (forall d. Data d => d -> m d) -> Product f g a -> m (Product f g a) #

gmapMp :: MonadPlus m => (forall d. Data d => d -> m d) -> Product f g a -> m (Product f g a) #

gmapMo :: MonadPlus m => (forall d. Data d => d -> m d) -> Product f g a -> m (Product f g a) #

(Ord1 f, Ord1 g, Ord a) => Ord (Product f g a)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

compare :: Product f g a -> Product f g a -> Ordering #

(<) :: Product f g a -> Product f g a -> Bool #

(<=) :: Product f g a -> Product f g a -> Bool #

(>) :: Product f g a -> Product f g a -> Bool #

(>=) :: Product f g a -> Product f g a -> Bool #

max :: Product f g a -> Product f g a -> Product f g a #

min :: Product f g a -> Product f g a -> Product f g a #

(Read1 f, Read1 g, Read a) => Read (Product f g a)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

readsPrec :: Int -> ReadS (Product f g a) #

readList :: ReadS [Product f g a] #

readPrec :: ReadPrec (Product f g a) #

readListPrec :: ReadPrec [Product f g a] #

(Show1 f, Show1 g, Show a) => Show (Product f g a)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Methods

showsPrec :: Int -> Product f g a -> ShowS #

show :: Product f g a -> String #

showList :: [Product f g a] -> ShowS #

Generic (Product f g a)

Since: base-4.9.0.0

Instance details

Defined in Data.Functor.Product

Associated Types

type Rep (Product f g a) :: Type -> Type #

Methods

from :: Product f g a -> Rep (Product f g a) x #

to :: Rep (Product f g a) x -> Product f g a #

type Rep1 (Product f g :: k -> Type)
Instance details

Defined in Data.Functor.Product

type Rep1 (Product f g :: k -> Type) = D1 ('MetaData "Product" "Data.Functor.Product" "base" 'False) (C1 ('MetaCons "Pair" 'PrefixI 'False) (S1 ('MetaSel ('Nothing :: Maybe Symbol) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy) (Rec1 f) :*: S1 ('MetaSel ('Nothing :: Maybe Symbol) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy) (Rec1 g)))
type Rep (Product f g a)
Instance details

Defined in Data.Functor.Product

type Rep (Product f g a) = D1 ('MetaData "Product" "Data.Functor.Product" "base" 'False) (C1 ('MetaCons "Pair" 'PrefixI 'False) (S1 ('MetaSel ('Nothing :: Maybe Symbol) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy) (Rec0 (f a)) :*: S1 ('MetaSel ('Nothing :: Maybe Symbol) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy) (Rec0 (g a))))
diff --git a/html-test/ref/Bug1033.html b/html-test/ref/Bug1033.html new file mode 100644 --- /dev/null +++ b/html-test/ref/Bug1033.html @@ -0,0 +1,222 @@ +Bug1033
Safe HaskellSafe

Bug1033

Documentation

data Foo #

Constructors

Foo

Instances

Instances details
Generic Foo #

This does some generic foos.

Instance details

Defined in Bug1033

Associated Types

type Rep Foo :: Type -> Type #

Methods

from :: Foo -> Rep Foo x #

to :: Rep Foo x -> Foo #

type Rep Foo #
Instance details

Defined in Bug1033

type Rep Foo = D1 ('MetaData "Foo" "Bug1033" "main" 'False) (C1 ('MetaCons "Foo" 'PrefixI 'False) (U1 :: Type -> Type))
diff --git a/html-test/ref/Bug1035.html b/html-test/ref/Bug1035.html new file mode 100644 --- /dev/null +++ b/html-test/ref/Bug1035.html @@ -0,0 +1,146 @@ +Bug1035
Safe HaskellSafe

Bug1035

Synopsis

Documentation

data Foo #

Constructors

Bar

data Bar #

Constructors

Foo

foo :: () #

A link to Bar

diff --git a/html-test/ref/Bug1063.html b/html-test/ref/Bug1063.html new file mode 100644 --- /dev/null +++ b/html-test/ref/Bug1063.html @@ -0,0 +1,100 @@ +Bug1063
Safe HaskellSafe

Bug1063

Documentation

class (c => d) => Implies c d #

Instances

Instances details
(c => d) => Implies c d #
Instance details

Defined in Bug1063

diff --git a/html-test/ref/Bug195.html b/html-test/ref/Bug195.html --- a/html-test/ref/Bug195.html +++ b/html-test/ref/Bug195.html @@ -1,18 +1,24 @@ Bug195
Bug2
Bug201
Bug253
Synopsis

foo :: () :: () #

This link should generate #v anchor: fakeFakeFake

Bug26
Instances

Instances

Instances details
Bug280
Bug294
#

Instances

Instances

Instances details
#

Instances

Instances

Instances details
#

Instances

Instances

Instances details
#

Instances

Instances

Instances details
Bug298
Bug3
Bug308
Bug308CrossModule
Bug310
Bug313
Bug335
Bug387
Bug387

Bug4
Bug458
Bug466
Safe HaskellSafe

Bug466

Documentation

class Cl a #

Associated Types

type Fam a :: [*] #

Instances

Instances details
Cl X #
Instance details

Defined in Bug466

Associated Types

type Fam X :: [Type] #

data X #

Constructors

X

Instances

Instances details
Cl X #
Instance details

Defined in Bug466

Associated Types

type Fam X :: [Type] #

type Fam X #
Instance details

Defined in Bug466

type Fam X = '[Char]
diff --git a/html-test/ref/Bug546.html b/html-test/ref/Bug546.html --- a/html-test/ref/Bug546.html +++ b/html-test/ref/Bug546.html @@ -1,18 +1,24 @@ Bug546
Bug548
Instances

Instances

Instances details
Type)

Since: base-4.7.0.0

from1 :: :: forall (a0 :: k). WrappedArrow a b a0 -> Rep1

to1 :: :: forall (a0 :: k). Rep1 (WrappedArrowWrappedArrow a b c)

Since: base-4.7.0.0

Type)

Since: base-4.7.0.0

Type) = D1 ( ('MetaData "WrappedArrow" "Control.Applicative" "base" "WrappedArrow" "Control.Applicative" "base" 'True) (C1 ( ('MetaCons "WrapArrow" "WrapArrow" 'PrefixI 'True) (S1 ( ('MetaSel ( ('Just "unwrapArrow") "unwrapArrow") 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy) (Rec1WrappedArrow a b c)

Since: base-4.7.0.0

WrappedArrow a b c) = D1 ( ('MetaData "WrappedArrow" "Control.Applicative" "base" "WrappedArrow" "Control.Applicative" "base" 'True) (C1 ( ('MetaCons "WrapArrow" "WrapArrow" 'PrefixI 'True) (S1 ( ('MetaSel ( ('Just "unwrapArrow") "unwrapArrow") 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy) (Rec0Bug574
Bug6
Bug613

Instances

Instances

Instances details
Instances

Instances

Instances details
Bug647
Bug679
Instances

Instances

Instances details

Instances

Instances

Instances details
Bug7
Instances

Instances

Instances details
The Bar class

Instances

Instances

Instances details
Bug8
Bug85
Bug865
Safe HaskellSafe

Bug865

Synopsis

Documentation

link :: () #

An emphasized link yes this is emphasized while this is + monospaced. And here is an image:

diff --git a/html-test/ref/Bug923.html b/html-test/ref/Bug923.html new file mode 100644 --- /dev/null +++ b/html-test/ref/Bug923.html @@ -0,0 +1,200 @@ +Bug923
Safe HaskellSafe

Bug923

Synopsis
  • data T :: (* -> (*, *)) -> * where

Documentation

data T :: (* -> (*, *)) -> * where #

A promoted tuple type

Constructors

T :: a -> T ('(,) a)

Instances

Instances details
Eq a => Eq (T ('(,) a :: Type -> (Type, Type))) #

A promoted tuple type in an instance

Instance details

Defined in Bug923

Methods

(==) :: T ('(,) a) -> T ('(,) a) -> Bool #

(/=) :: T ('(,) a) -> T ('(,) a) -> Bool #

diff --git a/html-test/ref/Bug953.html b/html-test/ref/Bug953.html new file mode 100644 --- /dev/null +++ b/html-test/ref/Bug953.html @@ -0,0 +1,150 @@ +Bug953
Safe HaskellSafe

Bug953

Synopsis

Documentation

data Foo #

A foo

Examples

Expand

Foo example body

Constructors

Foo'

data Bar #

A bar

Examples

Expand

Bar example body

Constructors

Bar'
diff --git a/html-test/ref/Bug973.html b/html-test/ref/Bug973.html new file mode 100644 --- /dev/null +++ b/html-test/ref/Bug973.html @@ -0,0 +1,174 @@ +Bug973
Safe HaskellSafe

Bug973

Synopsis

Documentation

showRead #

Arguments

:: forall a b. (Show a, Read b)
=> a

this gets turned into a string...

-> b

...from which this is read

showRead' #

Arguments

:: forall b a. (Show a, Read b)
=> a

this gets turned into a string...

-> b

...from which this is read

Same as showRead, but with type variable order flipped

diff --git a/html-test/ref/BugDeprecated.html b/html-test/ref/BugDeprecated.html --- a/html-test/ref/BugDeprecated.html +++ b/html-test/ref/BugDeprecated.html @@ -1,18 +1,24 @@ BugDeprecated
BugExportHeadings
BugExportHeadings

Bugs
BundledPatterns
BundledPatterns2
ConstructorArgs
ConstructorPatternExport
MyGADTCons :: a -> Int -> MyGADT ( -> MyGADT (Maybe String
 

 

DefaultAssociatedTypes
Safe HaskellSafe

DefaultAssociatedTypes

Synopsis

Documentation

class Foo a where #

Documentation for Foo.

Associated Types

type Qux a :: * #

Doc for Qux

type Qux a = [a] #

Methods

bar :: a -> String #

Documentation for bar and baz.

baz :: a -> String #

Documentation for bar and baz.

diff --git a/html-test/ref/DefaultSignatures.html b/html-test/ref/DefaultSignatures.html new file mode 100644 --- /dev/null +++ b/html-test/ref/DefaultSignatures.html @@ -0,0 +1,182 @@ +DefaultSignatures
Safe HaskellSafe

DefaultSignatures

Synopsis

Documentation

class Foo a where #

Documentation for Foo.

Minimal complete definition

baz

Methods

bar :: a -> String #

Documentation for bar and baz.

default bar :: Show a => a -> String #

baz :: a -> String #

Documentation for bar and baz.

baz' :: String -> a #

Documentation for baz'.

default baz' :: Read a => String -> a #

diff --git a/html-test/ref/DeprecatedClass.html b/html-test/ref/DeprecatedClass.html --- a/html-test/ref/DeprecatedClass.html +++ b/html-test/ref/DeprecatedClass.html @@ -1,18 +1,24 @@ DeprecatedClass
DeprecatedData
DeprecatedFunction
DeprecatedFunction2
DeprecatedFunction3
DeprecatedModule
DeprecatedModule2
DeprecatedNewtype
DeprecatedReExport
DeprecatedReExport

DeprecatedRecord

DeprecatedTypeFamily
DeprecatedTypeSynonym
DuplicateRecordFields
Examples
Extensions
FunArgs
:: :: forall a. Ord a:: forall a b c. a-> forall d. d=> forall c. a b c d proxy (a :: ()) b. proxy a
:: a

First argument

-> d

Result

:: forall (b :: ()). d ~ a (b :: ()) d. d ~ '()
=> a b c d

abcd

:: forall (a :: ()). proxy a

First argument

GADTRecords
GadtConstructorArgs
Hash
Hash

Hash key => key -> IO ( (Maybe val)

  • Hash key => key -> IO ( (Maybe val) #

    Looks up a key in the hash table, returns Just val if the key was found, or Nothing otherwise.

    • Instances

    Instances

    Instances details
    HiddenInstances
    Should be visible

    Instances

    Instances

    Instances details
    Should be visible

    Instances

    Instances

    Instances details
    HiddenInstancesB
    Should be visible

    Instances

    Instances

    Instances details
    Should be visible

    Instances

    Instances

    Instances details
    Hyperlinks
    Identifiers
    Safe HaskellSafe

    Identifiers

    Synopsis

    Documentation

    data Id #

    Constructors

    Id

    data a :* b #

    Constructors

    a :* b

    foo :: () #

    diff --git a/html-test/ref/IgnoreExports.html b/html-test/ref/IgnoreExports.html --- a/html-test/ref/IgnoreExports.html +++ b/html-test/ref/IgnoreExports.html @@ -1,10 +1,12 @@ IgnoreExports
    Instances
    Instances

    Instances

    Instances details

    Instances

    Instances

    Instances details
    Foo Maybe

    foo :: :: Maybe Int -> a -> -> a -> Maybe a #

    foo' :: :: Maybe ( (Maybe a) -> Int -> -> Maybe ( (Maybe Int

    Instances

    Instances

    Instances details
    Bar Maybe Bool

    bar :: :: Maybe Bool -> -> Maybe Bool

    bar' :: :: Maybe ( (Maybe Bool) -> ) -> Maybe ( (Maybe ( (Maybe b)) #

    bar0 :: ( :: (Maybe Bool, , Maybe Bool) -> () -> (Maybe b, b, Maybe c) #

    bar1 :: ( :: (Maybe Bool, , Maybe Bool) -> () -> (Maybe b, b, Maybe c) # Bar Maybe [a]

    bar :: :: Maybe [a] -> [a] -> Maybe Bool

    bar' :: :: Maybe ( (Maybe [a]) -> [a]) -> Maybe ( (Maybe ( (Maybe b)) #

    bar0 :: ( :: (Maybe [a], [a], Maybe [a]) -> ( [a]) -> (Maybe b, b, Maybe c) #

    bar1 :: ( :: (Maybe [a], [a], Maybe [a]) -> ( [a]) -> (Maybe b, b, Maybe c) #

    Instances

    Instances

    Instances details
    Instances

    Instances

    Instances details

    Instances

    Instances

    Instances details
    Int c Bool :: Type #

    Thud Int c :: Type c #

    type Plugh [a] c [b] :: Type [a] c [b] #

    data Thud [a] c :: Type [a] c #

    Math
    normalDensity

    \[ + >\[ \int_{-\infty}^{\infty} e^{-x^2/2} = \sqrt{2\pi} - \]

    \(\int_{-\infty}^{\infty} e^{-x^2/2} = \sqrt{2\pi}\)

    \(\int_{-\infty}^{\infty} e^{-x^2/2} = \sqrt{2\pi}\)

    Math (inline) for normalDensity - \(\int_{-\infty}^{\infty} e^{-x^2/2} = \sqrt{2\pi}\) - \[\int_{-\infty}^{\infty} e^{-x^2/2} = \sqrt{2\pi}\]

    \(\int_{-\infty}^{\infty} e^{-x^2/2} = \sqrt{2\pi}\) + \[\int_{-\infty}^{\infty} e^{-x^2/2} = \sqrt{2\pi}\]

    Minimal
    ModuleWithWarning
    NamedDoc
    NamespacedIdentifiers
    Safe HaskellSafe

    NamespacedIdentifiers

    Synopsis

    Documentation

    data Foo #

    A link to:

    • the type Bar
    • the constructor Bar
    • the unimported but qualified type A
    • the unimported but qualified value A

    Constructors

    Bar

    data Bar #

    A link to the value Foo (which shouldn't exist).

    diff --git a/html-test/ref/Nesting.html b/html-test/ref/Nesting.html --- a/html-test/ref/Nesting.html +++ b/html-test/ref/Nesting.html @@ -1,18 +1,24 @@ Nesting
    NoLayout
    NonGreedy
    Operators
    pattern (:+) :: forall a. a -> a -> [a] :: a -> a -> [a]
  • datapattern (:+) :: forall a. a -> a -> [a] :: a -> a -> [a] infixr 3OrphanInstances
    OrphanInstances

    OrphanInstancesClass

    Instances

    Instances

    Instances details
    OrphanInstancesType
    Instances

    Instances

    Instances details
    PR643
    PR643_1
    PatternSyns
    pattern Foo :: forall x. x -> :: x -> FooType x
  • pattern Bar :: forall x. x -> :: x -> FooType (FooTypepattern (:<->) :: forall x x1. x -> x1 -> ( :: x -> x1 -> (FooType x, FooTypedata BlubType = = forall x.Show x => x => BlubCtor x
  • pattern Blub :: () => forall x. :: () => Show x => x -> BlubTypepattern E :: forall k a (b :: k). a :: a >< b
  • pattern Foo :: forall x. x -> :: x -> FooType x #pattern Bar :: forall x. x -> :: x -> FooType (FooTypepattern (:<->) :: forall x x1. x -> x1 -> ( :: x -> x1 -> (FooType x, FooType
    forall x.Show x => x => BlubCtor xpattern Blub :: () => forall x. :: () => Show x => x -> BlubTypepattern E :: forall k a (b :: k). a :: a >< b #PromotedTypes
    		Cons :: :: Maybe h -> PatternRevCons :: :: Maybe h -> RevPatternProperties
    PruneWithWarning
    QuantifiedConstraints
    QuasiExpr
    • Instances

    Instances

    Instances details
    Instances

    Instances

    Instances details
    QuasiQuote
    SpuriousSuperclassConstraints
    #

    Instances

    Instances

    Instances details
    TH
    TH2
    Table
    		 \[ + > \[ f(n) = \sum_{i=1} - \]
    Test
    Test

    Instances

    Instances

    Instances details
    forall b.C b => b => Ex1 b
    forall b. Ex2 b
    forall b.C a => a => Ex3 bf' - but f' doesn't get link'd 'f\''

    Threaded
    Threaded_TH
    Ticket112
    Ticket61
    Ticket75
    TitledPicture
    TypeFamilies
    Instances

    Instances

    Instances detailsDoc for: data Y

    Instances

    Instances

    Instances details
    'XX >< 'XXX AssocD X :: Type #

    AssocT X :: Type #

    type 'XXX <> 'XX
    type 'XXX <> 'XX = = 'X
    AssocT X = ( = Foo X :: Type)
    AssocD Y :: Type #

    AssocT Y :: Type #

    Instances

    Instances

    Instances details
  • BatZ1 :: forall (z :: Z). :: Z -> Bat 'ZA
  • BatZ2 :: forall (z :: Z). {..} -> :: {..} -> Bat 'ZB
    • Doc for: class Test a

    Instances

    Instances

    Instances details
    Doc for: type family Foo a

    Instances

    Instances

    Instances details
    Doc for: data family Bat a

    Instances

    Instances

    Instances details
  • BatZ1 :: forall (z :: Z). :: Z -> Bat 'ZA
  • BatZ2 :: forall (z :: Z). {..} -> :: {..} -> Bat 'ZB
    • Instances

    Instances

    Instances details
    AssocD Y :: Type #

    AssocT Y :: Type #

    AssocD X :: Type #

    AssocT X :: Type #

    #

    Instances

    Instances

    Instances details
    type 'XXX <> 'XX
    type 'XXX <> 'XX = = 'X
    #

    Instances

    Instances

    Instances details
    'XX >< 'XXX TypeFamilies2
    Exported type

    Instances

    Instances

    Instances details
    Exported type family

    Instances

    Instances

    Instances details
    Exported data family

    Instances

    Instances

    Instances details
    TypeFamilies3
    An open family

    Instances

    Instances

    Instances details
    A data family

    Instances

    Instances

    Instances details
    TypeOperators
    UnboxedStuff
    Safe HaskellSafe

    UnboxedStuff

    Synopsis

    Documentation

    data X #

    data Y #

    data Z #

    Unboxed type constructors

    unboxedUnit :: (# #) -> (# #) #

    unboxedTuple :: (# X, Y #) -> (# X, Y, Z #) #

    unboxedSum :: (# X | Y #) -> (# X | Y | Z #) #

    diff --git a/html-test/ref/Unicode.html b/html-test/ref/Unicode.html --- a/html-test/ref/Unicode.html +++ b/html-test/ref/Unicode.html @@ -1,18 +1,24 @@ Unicode
    Unicode2
    Visible
    d) => Implies c d +instance (c => d) => Implies c d diff --git a/html-test/src/Bug466.hs b/html-test/src/Bug466.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Bug466.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds, TypeFamilies, StarIsType #-} +module Bug466 where + +class Cl a where + type Fam a :: [*] + +data X = X +instance Cl X where + type Fam X = '[Char] diff --git a/html-test/src/Bug865.hs b/html-test/src/Bug865.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Bug865.hs @@ -0,0 +1,9 @@ +module Bug865 where + +-- | An emphasized link [yes /this/ is emphasized while this is +-- @monospaced@](https://www.haskell.org/). And here is an image: +-- +-- ![/emphasis/ stripped](https://www.haskell.org/static/img/haskell-logo.svg) +-- +link :: () +link = () diff --git a/html-test/src/Bug923.hs b/html-test/src/Bug923.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Bug923.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE KindSignatures, FlexibleInstances, GADTs, DataKinds #-} +module Bug923 where + +-- | A promoted tuple type +data T :: (* -> (*,*)) -> * where + T :: a -> T ('(,) a) + +-- | A promoted tuple type in an instance +instance Eq a => Eq (T ('(,) a)) where + T x == T y = x == y + diff --git a/html-test/src/Bug953.hs b/html-test/src/Bug953.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Bug953.hs @@ -0,0 +1,17 @@ +module Bug953 where + +{- | A foo + +==== __Examples__ + +Foo example body +-} +data Foo = Foo' + +{- | A bar + +==== __Examples__ + +Bar example body +-} +data Bar = Bar' diff --git a/html-test/src/Bug975.hs b/html-test/src/Bug975.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Bug975.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ExplicitForAll #-} +module Bug973 where + +showRead + :: forall a b. (Show a, Read b) + => a -- ^ this gets turned into a string... + -> b -- ^ ...from which this is read +showRead = read . show + +-- | Same as 'showRead', but with type variable order flipped +showRead' + :: forall b a. (Show a, Read b) + => a -- ^ this gets turned into a string... + -> b -- ^ ...from which this is read +showRead' = read . show diff --git a/html-test/src/DefaultAssociatedTypes.hs b/html-test/src/DefaultAssociatedTypes.hs new file mode 100644 --- /dev/null +++ b/html-test/src/DefaultAssociatedTypes.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DefaultSignatures, TypeFamilies #-} + +module DefaultAssociatedTypes where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Doc for Qux + type Qux a :: * + + -- | Doc for default Qux + type Qux a = [a] diff --git a/html-test/src/DefaultSignatures.hs b/html-test/src/DefaultSignatures.hs new file mode 100644 --- /dev/null +++ b/html-test/src/DefaultSignatures.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DefaultSignatures #-} + +module DefaultSignatures where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Documentation for the default signature of bar. + default bar :: Show a => a -> String + bar = show + + -- | Documentation for baz'. + baz' :: String -> a + + -- | Documentation for the default signature of baz'. + default baz' :: Read a => String -> a + baz' = read diff --git a/html-test/src/Identifiers.hs b/html-test/src/Identifiers.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Identifiers.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TypeOperators #-} +module Identifiers where + +import Data.List (elem, (++)) + +data Id = Id +data a :* b = a :* b + +{-| + + * Unadorned: + + - Unqualified: '++', 'elem' + - Qualified: 'Data.List.++', 'Data.Lis.elem' + - Namespaced: v'++', t'++', v'elem', t'elem', v'Id', t'Id', v':*', t':*' + + * Parenthesized: + + - Unqualified: @'(++)' [1,2,3] [4,5,6]@ + - Qualified: @'(Data.List.++)' [1,2,3] [4,5,6]@ + - Namespaced: v'(++)', t'++', v'(:*)', t'(:*)' + + * Backticked: + + - Unqualified: @1 '`elem`' [-3..3]@ + - Qualified: @1 '`Data.List.elem`' [-3..3]@ + - Namespaced: v'`elem`', t'`elem`', v'`Id`', t'`Id`' + + * Edge cases: + + - Tuples: '()', '(,,,)' + +-} +foo :: () +foo = () diff --git a/html-test/src/NamespacedIdentifiers.hs b/html-test/src/NamespacedIdentifiers.hs new file mode 100644 --- /dev/null +++ b/html-test/src/NamespacedIdentifiers.hs @@ -0,0 +1,13 @@ +module NamespacedIdentifiers where + +-- | A link to: +-- +-- * the type t'Bar' +-- * the constructor v'Bar' +-- * the unimported but qualified type t'A.A' +-- * the unimported but qualified value v'A.A' +-- +data Foo = Bar + +-- | A link to the value v'Foo' (which shouldn't exist). +data Bar diff --git a/html-test/src/UnboxedStuff.hs b/html-test/src/UnboxedStuff.hs new file mode 100644 --- /dev/null +++ b/html-test/src/UnboxedStuff.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE UnboxedSums, UnboxedTuples #-} +module UnboxedStuff where + +data X +data Y +data Z + +-- * Unboxed type constructors + +unboxedUnit :: (# #) -> (# #) +unboxedUnit = undefined + +unboxedTuple :: (# X, Y #) -> (# X, Y, Z #) +unboxedTuple = undefined + +unboxedSum :: (# X | Y #) -> (# X | Y | Z #) +unboxedSum = undefined + diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs --- a/hypsrc-test/Main.hs +++ b/hypsrc-test/Main.hs @@ -15,14 +15,16 @@ checkConfig :: CheckConfig Xml checkConfig = CheckConfig { ccfgRead = parseXml - , ccfgClean = \_ -> strip + , ccfgClean = strip , ccfgDump = dumpXml , ccfgEqual = (==) `on` dumpXml } where - strip = stripAnchors' . stripLinks' . stripFooter + strip _ = stripAnchors' . stripLinks' . stripIds' . stripFooter + stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name + stripIds' = stripIdsWhen $ \name -> "local-" `isPrefixOf` name dirConfig :: DirConfig diff --git a/hypsrc-test/ref/src/CPP.html b/hypsrc-test/ref/src/CPP.html --- a/hypsrc-test/ref/src/CPP.html +++ b/hypsrc-test/ref/src/CPP.html @@ -11,8 +11,8 @@ > module where - -#define SOMETHING1 + > + +#define SOMETHING1 foofoo :: StringString foofoo :: String +foo "foo" - -"foo"#define SOMETHING2 + > + +#define SOMETHING2 barbar :: StringString barbar :: String +bar = "block comment in a string is not a comment {- " - -"block comment in a string is not a comment {- "#define SOMETHING3 + > + +#define SOMETHING3 -- " single quotes are fine in line comments -- {- unclosed block comments are fine in line comments -- Multiline CPP is also fine -#define FOO\ + > +#define FOO\ 1 bazbaz :: StringString bazbaz :: String +baz = "line comment in a string is not a comment --""line comment in a string is not a comment --" 
    {-# LANGUAGE CPP #-}
+module ClangCppBug where
+
+foo :: Int
+foo :: Int
+foo = 1
+
+-- Clang doesn't mind these:
+#define BAX 2
+{-# INLINE bar #-}
+
+bar :: Int
+bar :: Int
+bar = 3
+
+-- But it doesn't like this:
+{-# RULES
+"bar/qux" bar = qux
+"qux/foo" qux = foo
+  #-}
+
+qux :: Int
+qux :: Int
+qux = 88
+
    diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -19,1045 +19,1435 @@ > - -class Foo a where - bar :: a -> Int - baz :: Int -> (a, a) - -instance Foo Int where - bar = id - baz x = (x, x) - -instance Foo [a] where - bar = length - baz _ = ([], []) - - -class Foo a => Foo' a where - quux :: (a, a) -> a - quux (x, y) = norf [x, y] - - norf :: [a] -> a - norf = quux . baz . sum . map bar - -instance Foo' Int where - norf = sum - -instance Foo' [a] where - quux = uncurry (++) - - -class Plugh p where - plugh :: p a a -> p b b -> p (a -> b) (b -> a) - -instance Plugh Either where - plugh (Left a) _ = Right $ const a - plugh (Right a) _ = Right $ const a - plugh _ (Left b) = Left $ const b - plugh _ (Right b) = Left $ const b - + +class Foo a where + bar :: a -> Int + baz :: Int -> (a, a) + +instance Foo Int where + bar :: Int -> Int +bar = Int -> Int +forall a. a -> a +id + baz :: Int -> (Int, Int) +baz x :: Int +x = (Int +x, Int +x) + +instance Foo [a] where + bar :: [a] -> Int +bar = [a] -> Int +forall (t :: * -> *) a. Foldable t => t a -> Int +length + baz :: Int -> ([a], [a]) +baz _ = ([], []) + + +class Foo a => Foo' a where + quux :: (a, a) -> a + quux (x :: a +x, y :: a +y) = [a] -> a +forall a. Foo' a => [a] -> a +norf [a +x, a +y] + + norf :: [a] -> a + norf = (a, a) -> a +forall a. Foo' a => (a, a) -> a +quux ((a, a) -> a) -> ([a] -> (a, a)) -> [a] -> a +forall b c a. (b -> c) -> (a -> b) -> a -> c +. Int -> (a, a) +forall a. Foo a => Int -> (a, a) +baz (Int -> (a, a)) -> ([a] -> Int) -> [a] -> (a, a) +forall b c a. (b -> c) -> (a -> b) -> a -> c +. [Int] -> Int +forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a +sum ([Int] -> Int) -> ([a] -> [Int]) -> [a] -> Int +forall b c a. (b -> c) -> (a -> b) -> a -> c +. (a -> Int) -> [a] -> [Int] +forall a b. (a -> b) -> [a] -> [b] +map a -> Int +forall a. Foo a => a -> Int +bar + +instance Foo' Int where + norf :: [Int] -> Int +norf = [Int] -> Int +forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a +sum + +instance Foo' [a] where + quux :: ([a], [a]) -> [a] +quux = ([a] -> [a] -> [a]) -> ([a], [a]) -> [a] +forall a b c. (a -> b -> c) -> (a, b) -> c +uncurry [a] -> [a] -> [a] +forall a. [a] -> [a] -> [a] +(++) + + +class Plugh p where + plugh :: p a a -> p b b -> p (a -> b) (b -> a) + +instance Plugh Either where + plugh :: Either a a -> Either b b -> Either (a -> b) (b -> a) +plugh (Left a :: a +a) _ = (b -> a) -> Either (a -> b) (b -> a) +forall a b. b -> Either a b +Right ((b -> a) -> Either (a -> b) (b -> a)) +-> (b -> a) -> Either (a -> b) (b -> a) +forall a b. (a -> b) -> a -> b +$ a -> b -> a +forall a b. a -> b -> a +const a +a + plugh (Right a :: a +a) _ = (b -> a) -> Either (a -> b) (b -> a) +forall a b. b -> Either a b +Right ((b -> a) -> Either (a -> b) (b -> a)) +-> (b -> a) -> Either (a -> b) (b -> a) +forall a b. (a -> b) -> a -> b +$ a -> b -> a +forall a b. a -> b -> a +const a +a + plugh _ (Left b :: b +b) = (a -> b) -> Either (a -> b) (b -> a) +forall a b. a -> Either a b +Left ((a -> b) -> Either (a -> b) (b -> a)) +-> (a -> b) -> Either (a -> b) (b -> a) +forall a b. (a -> b) -> a -> b +$ b -> a -> b +forall a b. a -> b -> a +const b +b + plugh _ (Right b :: b +b) = (a -> b) -> Either (a -> b) (b -> a) +forall a b. a -> Either a b +Left ((a -> b) -> Either (a -> b) (b -> a)) +-> (a -> b) -> Either (a -> b) (b -> a) +forall a b. (a -> b) -> a -> b +$ b -> a -> b +forall a b. a -> b -> a +const b +b + - -data Foo - = Bar - | Baz - | Quux Foo Int - -newtype Norf = Norf (Foo, [Foo], Foo) - - -bar, baz, quux :: Foo -bar = Bar -baz = Baz -quux = Quux quux 0 - - -unfoo :: Foo -> Int -unfoo Bar = 0 -unfoo Baz = 0 -unfoo (Quux foo n) = 42 * n + unfoo foo - - -unnorf :: Norf -> [Foo] -unnorf (Norf (Bar, xs, Bar)) = xs -unnorf (Norf (Baz, xs, Baz)) = reverse xs -unnorf _ = undefined - - -unnorf' :: Norf -> Int -unnorf' x@(Norf (f1@(Quux _ n), _, f2@(Quux f3 _))) = - x' + n * unfoo f1 + aux f3 - where - aux fx = unfoo f2 * unfoo fx * unfoo f3 - x' = sum . map unfoo . unnorf $ x - + +data Foo + = Bar + | Baz + | Quux Foo Int + +newtype Norf = Norf (Foo, [Foo], Foo) + + +bar, baz, quux :: Foo +bar :: Foo +bar = Foo +Bar +baz :: Foo +baz = Foo +Baz +quux :: Foo +quux = Foo -> Int -> Foo +Quux Foo +quux 0 + + +unfoo :: Foo -> Int +unfoo :: Foo -> Int +unfoo Bar = 0 +unfoo Baz = 0 +unfoo (Quux foo :: Foo +foo n :: Int +n) = 42 Int -> Int -> Int +forall a. Num a => a -> a -> a +* Int +n Int -> Int -> Int +forall a. Num a => a -> a -> a ++ Foo -> Int +unfoo Foo +foo + + +unnorf :: Norf -> [Foo] +unnorf :: Norf -> [Foo] +unnorf (Norf (Bar, xs :: [Foo] +xs, Bar)) = [Foo] +xs +unnorf (Norf (Baz, xs :: [Foo] +xs, Baz)) = [Foo] -> [Foo] +forall a. [a] -> [a] +reverse [Foo] +xs +unnorf _ = [Foo] +forall a. HasCallStack => a +undefined + + +unnorf' :: Norf -> Int +unnorf' :: Norf -> Int +unnorf' x :: Norf +x@(Norf (f1 :: Foo +f1@(Quux _ n :: Int +n), _, f2 :: Foo +f2@(Quux f3 :: Foo +f3 _))) = + Int +x' Int -> Int -> Int +forall a. Num a => a -> a -> a ++ Int +n Int -> Int -> Int +forall a. Num a => a -> a -> a +* Foo -> Int +unfoo Foo +f1 Int -> Int -> Int +forall a. Num a => a -> a -> a ++ Foo -> Int +aux Foo +f3 + where + aux :: Foo -> Int +aux fx :: Foo +fx = Foo -> Int +unfoo Foo +f2 Int -> Int -> Int +forall a. Num a => a -> a -> a +* Foo -> Int +unfoo Foo +fx Int -> Int -> Int +forall a. Num a => a -> a -> a +* Foo -> Int +unfoo Foo +f3 + x' :: Int +x' = [Int] -> Int +forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a +sum ([Int] -> Int) -> (Norf -> [Int]) -> Norf -> Int +forall b c a. (b -> c) -> (a -> b) -> a -> c +. (Foo -> Int) -> [Foo] -> [Int] +forall a b. (a -> b) -> [a] -> [b] +map Foo -> Int +unfoo ([Foo] -> [Int]) -> (Norf -> [Foo]) -> Norf -> [Int] +forall b c a. (b -> c) -> (a -> b) -> a -> c +. Norf -> [Foo] +unnorf (Norf -> Int) -> Norf -> Int +forall a b. (a -> b) -> a -> b +$ Norf +x + - -foo, bar, baz :: Int -> Int -> Int -foo x y = x + x * bar y x * y + y -bar x y = y + x - baz x y - x + y -baz x y = x * y * y * y * x - -quux :: Int -> Int -quux x = foo (bar x x) (bar x x) - -norf :: Int -> Int -> Int -> Int -norf x y z - | x < 0 = quux x - | y < 0 = quux y - | z < 0 = quux z - | otherwise = norf (-x) (-y) (-z) - - -main :: IO () -main = do - putStrLn . show $ foo x y - putStrLn . show $ quux z - putStrLn . show $ Identifiers.norf x y z - where - x = 10 - y = 20 - z = 30 - + +foo, bar, baz :: Int -> Int -> Int +foo :: Int -> Int -> Int +foo x :: Int +x y :: Int +y = Int +x Int -> Int -> Int +forall a. Num a => a -> a -> a ++ Int +x Int -> Int -> Int +forall a. Num a => a -> a -> a +* Int -> Int -> Int +bar Int +y Int +x Int -> Int -> Int +forall a. Num a => a -> a -> a +* Int +y Int -> Int -> Int +forall a. Num a => a -> a -> a ++ Int +y +bar :: Int -> Int -> Int +bar x :: Int +x y :: Int +y = Int +y Int -> Int -> Int +forall a. Num a => a -> a -> a ++ Int +x Int -> Int -> Int +forall a. Num a => a -> a -> a +- Int -> Int -> Int +baz Int +x Int +y Int -> Int -> Int +forall a. Num a => a -> a -> a +- Int +x Int -> Int -> Int +forall a. Num a => a -> a -> a ++ Int +y +baz :: Int -> Int -> Int +baz x :: Int +x y :: Int +y = Int +x Int -> Int -> Int +forall a. Num a => a -> a -> a +* Int +y Int -> Int -> Int +forall a. Num a => a -> a -> a +* Int +y Int -> Int -> Int +forall a. Num a => a -> a -> a +* Int +y Int -> Int -> Int +forall a. Num a => a -> a -> a +* Int +x + +quux :: Int -> Int +quux :: Int -> Int +quux x :: Int +x = Int -> Int -> Int +foo (Int -> Int -> Int +bar Int +x Int +x) (Int -> Int -> Int +bar Int +x Int +x) + +norf :: Int -> Int -> Int -> Int +norf :: Int -> Int -> Int -> Int +norf x :: Int +x y :: Int +y z :: Int +z + | Int +x Int -> Int -> Bool +forall a. Ord a => a -> a -> Bool +< 0 = Int -> Int +quux Int +x + | Int +y Int -> Int -> Bool +forall a. Ord a => a -> a -> Bool +< 0 = Int -> Int +quux Int +y + | Int +z Int -> Int -> Bool +forall a. Ord a => a -> a -> Bool +< 0 = Int -> Int +quux Int +z + | Bool +otherwise = Int -> Int -> Int -> Int +norf (-Int +x) (-Int +y) (-Int +z) + + +main :: IO () +main :: IO () +main = do + String -> IO () +putStrLn (String -> IO ()) -> (Int -> String) -> Int -> IO () +forall b c a. (b -> c) -> (a -> b) -> a -> c +. Int -> String +forall a. Show a => a -> String +show (Int -> IO ()) -> Int -> IO () +forall a b. (a -> b) -> a -> b +$ Int -> Int -> Int +foo Int +x Int +y + String -> IO () +putStrLn (String -> IO ()) -> (Int -> String) -> Int -> IO () +forall b c a. (b -> c) -> (a -> b) -> a -> c +. Int -> String +forall a. Show a => a -> String +show (Int -> IO ()) -> Int -> IO () +forall a b. (a -> b) -> a -> b +$ Int -> Int +quux Int +z + String -> IO () +putStrLn (String -> IO ()) -> (Int -> String) -> Int -> IO () +forall b c a. (b -> c) -> (a -> b) -> a -> c +. Int -> String +forall a. Show a => a -> String +show (Int -> IO ()) -> Int -> IO () +forall a b. (a -> b) -> a -> b +$ Int -> Int -> Int -> Int +Identifiers.norf Int +x Int +y Int +z + where + x :: Int +x = 10 + y :: Int +y = 20 + z :: Int +z = 30 +
    -- Tests that the identifers/operators are properly linked even when:
+--
+--   * backquoted, parenthesized, vanilla
+--   * qualified, not-qualified
+--
+module LinkingIdentifiers where
+
+ident :: Int -> Int -> Int
+x :: Int
+x ident :: Int -> Int -> Int
+`ident` 2 = (Int
+x Int -> Int -> Int
+`ident` 2) Int -> Int -> Int
+forall a. Num a => a -> a -> a
++ (Int
+x Int -> Int -> Int
+`LinkingIdentifiers.ident` 2)
+ident x :: Int
+x 2 = Int -> Int -> Int
+ident Int
+x 2 Int -> Int -> Int
+forall a. Num a => a -> a -> a
++ Int -> Int -> Int
+LinkingIdentifiers.ident Int
+x 2
+
+(++:++) :: Int -> Int -> Int
+x :: Int
+x ++:++ :: Int -> Int -> Int
+++:++ 2 = (Int
+x Int -> Int -> Int
+++:++ 2) Int -> Int -> Int
+forall a. Num a => a -> a -> a
++ (Int
+x Int -> Int -> Int
+LinkingIdentifiers.++:++ 2)
+(++:++) x :: Int
+x 2 = Int -> Int -> Int
+(++:++) Int
+x 2 Int -> Int -> Int
+forall a. Num a => a -> a -> a
++ Int -> Int -> Int
+(LinkingIdentifiers.++:++) Int
+x 2
+
    diff --git a/hypsrc-test/ref/src/Literals.html b/hypsrc-test/ref/src/Literals.html --- a/hypsrc-test/ref/src/Literals.html +++ b/hypsrc-test/ref/src/Literals.html @@ -19,238 +19,334 @@ > strstr :: StringString strstr :: String +str = "str literal""str literal" num :: Num a => anum :: Num a => a numnum :: a +num = 00 +a -> a -> a +forall a. Num a => a -> a -> a ++ 11 +a -> a -> a +forall a. Num a => a -> a -> a ++ 10100111010011 *a -> a -> a +forall a. Num a => a -> a -> a +* 4123141231 +a -> a -> a +forall a. Num a => a -> a -> a ++ 1213112131 frac :: Fractional a => afrac :: Fractional a => a fracfrac :: a +frac = 42.000000142.0000001 list :: [[[[a]]]]list :: [[[[a]]]] listlist :: [[[[a]]]] +list pairpair pairpair :: ((), ((), (), ()), ()) +pair - -(+++) :: [a] -> [a] -> [a] -a +++ b = a ++ b ++ a - -($$$) :: [a] -> [a] -> [a] -a $$$ b = b +++ a - -(***) :: [a] -> [a] -> [a] -(***) a [] = a -(***) a (_:b) = a +++ (a *** b) - -(*/\*) :: [[a]] -> [a] -> [a] -a */\* b = concatMap (*** b) a - -(**/\**) :: [[a]] -> [[a]] -> [[a]] -a **/\** b = zipWith (*/\*) [a +++ b] (a $$$ b) - - -(#.#) :: a -> b -> (c -> (a, b)) -a #.# b = const $ (a, b) - + +(+++) :: [a] -> [a] -> [a] +a :: [a] +a +++ :: [a] -> [a] -> [a] ++++ b :: [a] +b = [a] +a [a] -> [a] -> [a] +forall a. [a] -> [a] -> [a] +++ [a] +b [a] -> [a] -> [a] +forall a. [a] -> [a] -> [a] +++ [a] +a + +($$$) :: [a] -> [a] -> [a] +a :: [a] +a $$$ :: [a] -> [a] -> [a] +$$$ b :: [a] +b = [a] +b [a] -> [a] -> [a] +forall a. [a] -> [a] -> [a] ++++ [a] +a + +(***) :: [a] -> [a] -> [a] +*** :: [a] -> [a] -> [a] +(***) a :: [a] +a [] = [a] +a +(***) a :: [a] +a (_:b :: [a] +b) = [a] +a [a] -> [a] -> [a] +forall a. [a] -> [a] -> [a] ++++ ([a] +a [a] -> [a] -> [a] +forall a. [a] -> [a] -> [a] +*** [a] +b) + +(*/\*) :: [[a]] -> [a] -> [a] +a :: [[a]] +a */\* :: [[a]] -> [a] -> [a] +*/\* b :: [a] +b = ([a] -> [a]) -> [[a]] -> [a] +forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] +concatMap ([a] -> [a] -> [a] +forall a. [a] -> [a] -> [a] +*** [a] +b) [[a]] +a + +(**/\**) :: [[a]] -> [[a]] -> [[a]] +a :: [[a]] +a **/\** :: [[a]] -> [[a]] -> [[a]] +**/\** b :: [[a]] +b = ([[a]] -> [a] -> [a]) -> [[[a]]] -> [[a]] -> [[a]] +forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] +zipWith [[a]] -> [a] -> [a] +forall a. [[a]] -> [a] -> [a] +(*/\*) [[[a]] +a [[a]] -> [[a]] -> [[a]] +forall a. [a] -> [a] -> [a] ++++ [[a]] +b] ([[a]] +a [[a]] -> [[a]] -> [[a]] +forall a. [a] -> [a] -> [a] +$$$ [[a]] +b) + + +(#.#) :: a -> b -> (c -> (a, b)) +a :: a +a #.# :: a -> b -> c -> (a, b) +#.# b :: b +b = (a, b) -> c -> (a, b) +forall a b. a -> b -> a +const ((a, b) -> c -> (a, b)) -> (a, b) -> c -> (a, b) +forall a b. (a -> b) -> a -> b +$ (a +a, b +b) + {-# LANGUAGE ScopedTypeVariables #-} - - -module Polymorphism where - - -foo :: a -> a -> a -foo = undefined - -foo' :: forall a. a -> a -> a -foo' = undefined - -bar :: a -> b -> (a, b) -bar = undefined - -bar' :: forall a b. a -> b -> (a, b) -bar' = undefined - -baz :: a -> (a -> [a -> a] -> b) -> b -baz = undefined - -baz' :: forall a b. a -> (a -> [a -> a] -> b) -> b -baz' = undefined - -quux :: a -> (forall a. a -> a) -> a -quux x f = f x - -quux' :: forall a. a -> (forall a. a -> a) -> a -quux' x f = f x - - -num :: Num a => a -> a -> a -num = undefined - -num' :: forall a. Num a => a -> a -> a -num' = undefined - -eq :: (Eq a, Eq b) => [a] -> [b] -> (a, b) -eq = undefined - -eq' :: forall a b. (Eq a, Eq b) => [a] -> [b] -> (a, b) -eq' = undefined - -mon :: Monad m => (a -> m a) -> m a -mon = undefined - -mon' :: forall m a. Monad m => (a -> m a) -> m a -mon' = undefined - - -norf :: a -> (forall a. Ord a => a -> a) -> a -norf x f = x - -norf' :: forall a. a -> (forall a. Ord a => a -> a) -> a -norf' x f = x - - -plugh :: forall a. a -> a -plugh x = x :: a - -thud :: forall a b. (a -> b) -> a -> (a, b) -thud f x = - (x :: a, y) :: (a, b) - where - y = (f :: a -> b) x :: b -{-# LANGUAGE ScopedTypeVariables #-} + + +module Polymorphism where + + +foo :: a -> a -> a +foo :: a -> a -> a +foo = a -> a -> a +forall a. HasCallStack => a +undefined + +foo' :: forall a. a -> a -> a +foo' :: a -> a -> a +foo' = a -> a -> a +forall a. HasCallStack => a +undefined + +bar :: a -> b -> (a, b) +bar :: a -> b -> (a, b) +bar = a -> b -> (a, b) +forall a. HasCallStack => a +undefined + +bar' :: forall a b. a -> b -> (a, b) +bar' :: a -> b -> (a, b) +bar' = a -> b -> (a, b) +forall a. HasCallStack => a +undefined + +baz :: a -> (a -> [a -> a] -> b) -> b +baz :: a -> (a -> [a -> a] -> b) -> b +baz = a -> (a -> [a -> a] -> b) -> b +forall a. HasCallStack => a +undefined + +baz' :: forall a b. a -> (a -> [a -> a] -> b) -> b +baz' :: a -> (a -> [a -> a] -> b) -> b +baz' = a -> (a -> [a -> a] -> b) -> b +forall a. HasCallStack => a +undefined + +quux :: a -> (forall a. a -> a) -> a +quux :: a -> (forall a. a -> a) -> a +quux x :: a +x f :: forall a. a -> a +f = a -> a +forall a. a -> a +f a +x + +quux' :: forall a. a -> (forall a. a -> a) -> a +quux' :: a -> (forall a. a -> a) -> a +quux' x :: a +x f :: forall a. a -> a +f = a -> a +forall a. a -> a +f a +x + + +num :: Num a => a -> a -> a +num :: a -> a -> a +num = a -> a -> a +forall a. HasCallStack => a +undefined + +num' :: forall a. Num a => a -> a -> a +num' :: a -> a -> a +num' = a -> a -> a +forall a. HasCallStack => a +undefined + +eq :: (Eq a, Eq b) => [a] -> [b] -> (a, b) +eq :: [a] -> [b] -> (a, b) +eq = [a] -> [b] -> (a, b) +forall a. HasCallStack => a +undefined + +eq' :: forall a b. (Eq a, Eq b) => [a] -> [b] -> (a, b) +eq' :: [a] -> [b] -> (a, b) +eq' = [a] -> [b] -> (a, b) +forall a. HasCallStack => a +undefined + +mon :: Monad m => (a -> m a) -> m a +mon :: (a -> m a) -> m a +mon = (a -> m a) -> m a +forall a. HasCallStack => a +undefined + +mon' :: forall m a. Monad m => (a -> m a) -> m a +mon' :: (a -> m a) -> m a +mon' = (a -> m a) -> m a +forall a. HasCallStack => a +undefined + + +norf :: a -> (forall a. Ord a => a -> a) -> a +norf :: a -> (forall a. Ord a => a -> a) -> a +norf x :: a +x f :: forall a. Ord a => a -> a +f = a +x + +norf' :: forall a. a -> (forall a. Ord a => a -> a) -> a +norf' :: a -> (forall a. Ord a => a -> a) -> a +norf' x :: a +x f :: forall a. Ord a => a -> a +f = a +x + + +plugh :: forall a. a -> a +plugh :: a -> a +plugh x :: a +x = a +x :: a + +thud :: forall a b. (a -> b) -> a -> (a, b) +thud :: (a -> b) -> a -> (a, b) +thud f :: a -> b +f x :: a +x = + (a +x :: a, b +y) :: (a, b) + where + y :: b +y = (a -> b +f :: a -> b) a +x :: b +
    module PositionPragmas where
+
+{-# LINE 8 "hypsrc-test/src/PositionPragmas.hs" #-}
+
+foo :: String
+foo :: String
+foo = String
+bar
+
+{-# LINE 23 "hypsrc-test/src/PositionPragmas.hs" #-}
+
+bar :: String
+bar :: String
+bar = String
+foo 
+
+
    diff --git a/hypsrc-test/ref/src/Records.html b/hypsrc-test/ref/src/Records.html --- a/hypsrc-test/ref/src/Records.html +++ b/hypsrc-test/ref/src/Records.html @@ -11,965 +11,1419 @@ > {-# LANGUAGE RecordWildCards #-} - - -module Records where - - -data Point = Point - { x :: !Int - , y :: !Int - } - - -point :: Int -> Int -> Point -point x y = Point { x = x, y = y } - - -lengthSqr :: Point -> Int -lengthSqr (Point { x = x, y = y }) = x * x + y * y - -lengthSqr' :: Point -> Int -lengthSqr' (Point { x, y }) = y * y + x * x - - -translateX, translateY :: Point -> Int -> Point -translateX p d = p { x = x p + d } -translateY p d = p { y = y p + d } - -translate :: Int -> Int -> Point -> Point -translate x y p = - aux p - where - (dx, dy) = (x, y) - aux Point{..} = p { x = x + dx, y = y + dy } -{-# LANGUAGE RecordWildCards #-} + + +module Records where + + +data Point = Point + { Point -> Int +x :: !Int + , Point -> Int +y :: !Int + } + + +point :: Int -> Int -> Point +point :: Int -> Int -> Point +point x :: Int +x y :: Int +y = $WPoint :: Int -> Int -> Point +Point { x :: Int +x = Int +x, y :: Int +y = Int +y } + + +lengthSqr :: Point -> Int +lengthSqr :: Point -> Int +lengthSqr (Point { x :: Point -> Int +x = Int +x, y :: Point -> Int +y = Int +y }) = Int +x Int -> Int -> Int +forall a. Num a => a -> a -> a +* Int +x Int -> Int -> Int +forall a. Num a => a -> a -> a ++ Int +y Int -> Int -> Int +forall a. Num a => a -> a -> a +* Int +y + +lengthSqr' :: Point -> Int +lengthSqr' :: Point -> Int +lengthSqr' (Point { Int +x :: Int +x :: Point -> Int +x, Int +y :: Int +y :: Point -> Int +y }) = Int +y Int -> Int -> Int +forall a. Num a => a -> a -> a +* Int +y Int -> Int -> Int +forall a. Num a => a -> a -> a ++ Int +x Int -> Int -> Int +forall a. Num a => a -> a -> a +* Int +x + + +translateX, translateY :: Point -> Int -> Point +translateX :: Point -> Int -> Point +translateX p :: Point +p d :: Int +d = Point +p { x :: Int +x = Point -> Int +x Point +p Int -> Int -> Int +forall a. Num a => a -> a -> a ++ Int +d } +translateY :: Point -> Int -> Point +translateY p :: Point +p d :: Int +d = Point +p { y :: Int +y = Point -> Int +y Point +p Int -> Int -> Int +forall a. Num a => a -> a -> a ++ Int +d } + +translate :: Int -> Int -> Point -> Point +translate :: Int -> Int -> Point -> Point +translate x :: Int +x y :: Int +y p :: Point +p = + Point -> Point +aux Point +p + where + (dx :: Int +dx, dy :: Int +dy) = (Int +x, Int +y) + aux :: Point -> Point +aux Point{..} = Point +p { x :: Int +x = Int +x Int -> Int -> Int +forall a. Num a => a -> a -> a ++ Int +dx, y :: Int +y = Int +y Int -> Int -> Int +forall a. Num a => a -> a -> a ++ Int +dy } + - -module Types where - - -data Quux = Bar | Baz - -newtype Foo = Foo () - -type FooQuux = (Foo, Quux) -type QuuxFoo = (Quux, Foo) - - -data family Norf a b - -data instance Norf Foo Quux = NFQ Foo Quux -data instance Norf Quux Foo = NQF Quux Foo - - -type family Norf' a b - -type instance Norf' Foo Quux = (Foo, Quux) -type instance Norf' Quux Foo = (Quux, Foo) - - -norf1 :: Norf Foo Quux -> Int -norf1 (NFQ (Foo ()) Bar) = 0 -norf1 (NFQ (Foo ()) Baz) = 1 - -norf2 :: Norf Quux Foo -> Int -norf2 (NQF Bar (Foo ())) = 0 -norf2 (NQF Baz (Foo ())) = 1 - - -norf1' :: Norf' Foo Quux -> Int -norf1' (Foo (), Bar) = 0 -norf1' (Foo (), Baz) = 1 - -norf2' :: Norf' Quux Foo -> Int -norf2' (Bar, Foo ()) = 0 -norf2' (Baz, Foo ()) = 1 - + +module Types where + + +data Quux = Bar | Baz + +newtype Foo = Foo () + +type FooQuux = (Foo, Quux) +type QuuxFoo = (Quux, Foo) + + +data family Norf a b + +data instance Norf Foo Quux = NFQ Foo Quux +data instance Norf Quux Foo = NQF Quux Foo + + +type family Norf' a b + +type instance Norf' Foo Quux = (Foo, Quux) +type instance Norf' Quux Foo = (Quux, Foo) + + +norf1 :: Norf Foo Quux -> Int +norf1 :: Norf Foo Quux -> Int +norf1 (NFQ (Foo ()) Bar) = 0 +norf1 (NFQ (Foo ()) Baz) = 1 + +norf2 :: Norf Quux Foo -> Int +norf2 :: Norf Quux Foo -> Int +norf2 (NQF Bar (Foo ())) = 0 +norf2 (NQF Baz (Foo ())) = 1 + + +norf1' :: Norf' Foo Quux -> Int +norf1' :: Norf' Foo Quux -> Int +norf1' (Foo (), Bar) = 0 +norf1' (Foo (), Baz) = 1 + +norf2' :: Norf' Quux Foo -> Int +norf2' :: Norf' Quux Foo -> Int +norf2' (Bar, Foo ()) = 0 +norf2' (Baz, Foo ()) = 1 + Int -> Int +x `ident` 2 = (x `ident` 2) + (x `LinkingIdentifiers.ident` 2) +ident x 2 = ident x 2 + LinkingIdentifiers.ident x 2 + +(++:++) :: Int -> Int -> Int +x ++:++ 2 = (x ++:++ 2) + (x LinkingIdentifiers.++:++ 2) +(++:++) x 2 = (++:++) x 2 + (LinkingIdentifiers.++:++) x 2 diff --git a/hypsrc-test/src/PositionPragmas.hs b/hypsrc-test/src/PositionPragmas.hs new file mode 100644 --- /dev/null +++ b/hypsrc-test/src/PositionPragmas.hs @@ -0,0 +1,12 @@ +module PositionPragmas where + +{-# LINE 8 "hypsrc-test/src/PositionPragmas.hs" #-} + +foo :: String +foo = bar + +{-# LINE 23 "hypsrc-test/src/PositionPragmas.hs" #-} + +bar :: String +bar = foo + diff --git a/latex-test/Main.hs b/latex-test/Main.hs --- a/latex-test/Main.hs +++ b/latex-test/Main.hs @@ -19,7 +19,9 @@ dirConfig :: DirConfig -dirConfig = defaultDirConfig $ takeDirectory __FILE__ +dirConfig = (defaultDirConfig $ takeDirectory __FILE__) + { dcfgCheckIgnore = (`elem` ["haddock.sty", "main.tex"]) . takeFileName + } main :: IO () diff --git a/latex-test/ref/ConstructorArgs/ConstructorArgs.tex b/latex-test/ref/ConstructorArgs/ConstructorArgs.tex new file mode 100644 --- /dev/null +++ b/latex-test/ref/ConstructorArgs/ConstructorArgs.tex @@ -0,0 +1,71 @@ +\haddockmoduleheading{ConstructorArgs} +\label{module:ConstructorArgs} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module ConstructorArgs ( + Foo((:|), Rec, Baz, Boa, (:*), x, y), Boo(Foo, Foa, Fo, Fo'), + pattern Bo, pattern Bo' + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data Foo +\end{tabular}] +{\haddockbegindoc +\enspace \emph{Constructors}\par +\haddockbeginconstrs +\haddockdecltt{=} & \haddockdecltt{Rec} & doc on a record \\ + & \haddocktt{\qquad \{} \haddockdecltt{x :: String} & doc on the \haddockid{String} field of \haddockid{Rec} \\ + & \haddocktt{\qquad ,} \haddockdecltt{y :: String} & doc on the \haddockid{String} field of \haddockid{Rec} \\ & \haddocktt{\qquad \}} \\ +\haddockdecltt{|} & \haddockdecltt{Baz Int String} & old prefix doc style \\ +\haddockdecltt{|} & \haddockdecltt{Boa} & doc on the \haddockid{Boa} constrictor \\ + & \qquad \haddockdecltt{!Int} & doc on the \haddockid{Int} field of \haddockid{Boa} \\ + & \qquad \haddockdecltt{!String} & doc on the \haddockid{String} field of \haddockid{Boa} \\ +\haddockdecltt{|} & \haddockdecltt{Int :| String} & old infix doc style \\ +\haddockdecltt{|} & \haddockdecltt{(:*)} & doc on the \haddockid{:*} constructor \\ + & \qquad \haddockdecltt{Int} & doc on the \haddockid{Int} field of the \haddockid{:*} constructor \\ + & \qquad \haddockdecltt{String} & doc on the \haddockid{String} field of the \haddockid{:*} constructor \\ +\end{tabulary}\par} +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data Boo where +\end{tabular}] +{\haddockbegindoc +\enspace \emph{Constructors}\par +\haddockbeginconstrs +& \haddockdecltt{Foo} & Info about a \haddockid{Foo} \\ + & \qquad \haddockdecltt{::} \enspace \haddockdecltt{Int} & \haddockid{Int} field of \haddockid{Foo} \\ + & \qquad \haddockdecltt{->} \enspace \haddockdecltt{String} & \haddockid{String} field of \haddockid{Foo} \\ + & \qquad \haddockdecltt{->} \enspace \haddockdecltt{Boo} & Make a \haddockid{Boo} \\ +& \haddockdecltt{Foa :: Int -> Boo} & no argument docs GADT \\ +\end{tabulary}\par +\enspace \emph{Bundled Patterns}\par +\haddockbeginconstrs +& \haddockdecltt{pattern Fo} & Info about bundled \haddockid{Fo} \\ + & \qquad \haddockdecltt{::} \enspace \haddockdecltt{Int} & an \haddockid{Int} \\ + & \qquad \haddockdecltt{->} \enspace \haddockdecltt{String} & a \haddockid{String} \\ + & \qquad \haddockdecltt{->} \enspace \haddockdecltt{Boo} & a \haddockid{Boo} \\ +& \haddockdecltt{pattern Fo' :: Boo} & Bundled and no argument docs \\ +\end{tabulary}\par} +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +pattern Bo +\end{tabular}] +{\haddockbegindoc +\haddockbeginargs +\haddockdecltt{::} & \haddockdecltt{Int} & an \haddockid{Int} \\ +\haddockdecltt{->} & \haddockdecltt{String} & a \haddockid{String} \\ +\haddockdecltt{->} & \haddockdecltt{Boo} & a \haddockid{Boo} pattern \\ +\end{tabulary}\par +Info about not-bundled \haddockid{Bo}\par} +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +pattern Bo' :: Int -> String -> Boo +\end{tabular}] +{\haddockbegindoc +Not bunded and no argument docs\par} +\end{haddockdesc} diff --git a/latex-test/ref/DefaultSignatures/DefaultSignatures.tex b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex new file mode 100644 --- /dev/null +++ b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex @@ -0,0 +1,41 @@ +\haddockmoduleheading{DefaultSignatures} +\label{module:DefaultSignatures} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module DefaultSignatures ( + Foo(baz', baz, bar) + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +class Foo a where +\end{tabular}] +{\haddockbegindoc +Documentation for Foo.\par +\haddockpremethods{}\emph{Methods} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +bar, baz :: a -> String +\end{tabular}] +{\haddockbegindoc +Documentation for bar and baz.\par} +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +default bar :: Show a => a -> String +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +baz' :: String -> a +\end{tabular}] +{\haddockbegindoc +Documentation for baz'.\par} +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +default baz' :: Read a => String -> a +\end{tabular}] +\end{haddockdesc}} +\end{haddockdesc} diff --git a/latex-test/ref/Deprecated/Deprecated.tex b/latex-test/ref/Deprecated/Deprecated.tex new file mode 100644 --- /dev/null +++ b/latex-test/ref/Deprecated/Deprecated.tex @@ -0,0 +1,17 @@ +\haddockmoduleheading{Deprecated} +\label{module:Deprecated} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module Deprecated ( + deprecated + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +deprecated :: Int +\end{tabular}] +{\haddockbegindoc +Deprecated: Don't use this\par +Docs for something deprecated\par} +\end{haddockdesc} diff --git a/latex-test/ref/Example/Example.tex b/latex-test/ref/Example/Example.tex new file mode 100644 --- /dev/null +++ b/latex-test/ref/Example/Example.tex @@ -0,0 +1,30 @@ +\haddockmoduleheading{Example} +\label{module:Example} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module Example ( + split + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +split :: Int -> () +\end{tabular}] +{\haddockbegindoc +Example use.\par +\begin{quote} +{\haddockverb\begin{verbatim} +>>> split 1 +() + +\end{verbatim}} +\end{quote} +\begin{quote} +{\haddockverb\begin{verbatim} +>>> split 2 +() + +\end{verbatim}} +\end{quote}} +\end{haddockdesc} diff --git a/latex-test/ref/GadtConstructorArgs/GadtConstructorArgs.tex b/latex-test/ref/GadtConstructorArgs/GadtConstructorArgs.tex new file mode 100644 --- /dev/null +++ b/latex-test/ref/GadtConstructorArgs/GadtConstructorArgs.tex @@ -0,0 +1,26 @@ +\haddockmoduleheading{GadtConstructorArgs} +\label{module:GadtConstructorArgs} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module GadtConstructorArgs ( + Boo(Fot, Fob, x, y, w, z) + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data Boo where +\end{tabular}] +{\haddockbegindoc +\enspace \emph{Constructors}\par +\haddockbeginconstrs +& \haddockdecltt{Fot} & \\ + & \qquad \haddockdecltt{:: {\char '173}} \enspace \haddockdecltt{x :: Int} & an \haddockid{x} \\ + & \qquad \haddockdecltt{\ \ \ \ ,} \enspace \haddockdecltt{y :: Int} & a \haddockid{y} \\ + & \qquad \haddockdecltt{\ \ \ \ {\char '175} ->} \enspace \haddockdecltt{Boo} & \\ +& \haddockdecltt{Fob} & Record GADT with docs \\ + & \qquad \haddockdecltt{:: {\char '173}} \enspace \haddockdecltt{w :: Int} & a \haddockid{w} \\ + & \qquad \haddockdecltt{\ \ \ \ ,} \enspace \haddockdecltt{z :: Int} & a \haddockid{z} \\ + & \qquad \haddockdecltt{\ \ \ \ {\char '175} ->} \enspace \haddockdecltt{Boo} & a \haddockid{Boo} \\ +\end{tabulary}\par} +\end{haddockdesc} diff --git a/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex b/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex new file mode 100644 --- /dev/null +++ b/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex @@ -0,0 +1,37 @@ +\haddockmoduleheading{NamespacedIdentifiers} +\label{module:NamespacedIdentifiers} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module NamespacedIdentifiers ( + Foo(Bar), Bar + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data Foo +\end{tabular}] +{\haddockbegindoc +A link to:\par +\vbox{\begin{itemize} +\item +the type \haddockid{Bar}\par +\item +the constructor \haddockid{Bar}\par +\item +the unimported but qualified type \haddockid{A}\par +\item +the unimported but qualified value \haddockid{A}\par +\end{itemize}} +\enspace \emph{Constructors}\par +\haddockbeginconstrs +\haddockdecltt{=} & \haddockdecltt{Bar} & \\ +\end{tabulary}\par} +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data Bar +\end{tabular}] +{\haddockbegindoc +A link to the value \haddocktt{Foo} (which shouldn't exist).\par} +\end{haddockdesc} diff --git a/latex-test/ref/Simple/Simple.tex b/latex-test/ref/Simple/Simple.tex --- a/latex-test/ref/Simple/Simple.tex +++ b/latex-test/ref/Simple/Simple.tex @@ -9,8 +9,8 @@ \begin{haddockdesc} \item[\begin{tabular}{@{}l} -foo\ ::\ t -\end{tabular}]\haddockbegindoc -This is foo.\par - +foo :: t +\end{tabular}] +{\haddockbegindoc +This is foo.\par} \end{haddockdesc} diff --git a/latex-test/ref/Simple/haddock.sty b/latex-test/ref/Simple/haddock.sty deleted file mode 100644 --- a/latex-test/ref/Simple/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% Default Haddock style definitions. To use your own style, invoke -% Haddock with the option --latex-style=mystyle. - -\usepackage{tabulary} % see below - -% make hyperlinks in the PDF, and add an expandabale index -\usepackage[pdftex,bookmarks=true]{hyperref} - -\newenvironment{haddocktitle} - {\begin{center}\bgroup\large\bfseries} - {\egroup\end{center}} -\newenvironment{haddockprologue}{\vspace{1in}}{} - -\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} - -\newcommand{\haddockbeginheader}{\hrulefill} -\newcommand{\haddockendheader}{\noindent\hrulefill} - -% a little gap before the ``Methods'' header -\newcommand{\haddockpremethods}{\vspace{2ex}} - -% inserted before \\begin{verbatim} -\newcommand{\haddockverb}{\small} - -% an identifier: add an index entry -\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} - -% The tabulary environment lets us have a column that takes up ``the -% rest of the space''. Unfortunately it doesn't allow -% the \end{tabulary} to be in the expansion of a macro, it must appear -% literally in the document text, so Haddock inserts -% the \end{tabulary} itself. -\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} -\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} - -\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} -\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} - -\makeatletter -\newenvironment{haddockdesc} - {\list{}{\labelwidth\z@ \itemindent-\leftmargin - \let\makelabel\haddocklabel}} - {\endlist} -\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} -\makeatother - -% after a declaration, start a new line for the documentation. -% Otherwise, the documentation starts right after the declaration, -% because we're using the list environment and the declaration is the -% ``label''. I tried making this newline part of the label, but -% couldn't get that to work reliably (the space seemed to stretch -% sometimes). -\newcommand{\haddockbegindoc}{\hfill\\[1ex]} - -% spacing between paragraphs and no \parindent looks better -\parskip=10pt plus2pt minus2pt -\setlength{\parindent}{0cm} diff --git a/latex-test/ref/Simple/main.tex b/latex-test/ref/Simple/main.tex deleted file mode 100644 --- a/latex-test/ref/Simple/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{Simple} -\end{document} diff --git a/latex-test/ref/TypeFamilies3/TypeFamilies3.tex b/latex-test/ref/TypeFamilies3/TypeFamilies3.tex new file mode 100644 --- /dev/null +++ b/latex-test/ref/TypeFamilies3/TypeFamilies3.tex @@ -0,0 +1,44 @@ +\haddockmoduleheading{TypeFamilies3} +\label{module:TypeFamilies3} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module TypeFamilies3 ( + Foo, Bar, Baz(Baz3, Baz2, Baz1) + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +type family Foo a where +\end{tabular}] +{\haddockbegindoc +\haddockbeginargs +\haddockdecltt{Foo () = Int} \\ +\haddockdecltt{Foo {\char '137} = ()} \\ +\end{tabulary}\par +A closed type family\par} +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +type family Bar a +\end{tabular}] +{\haddockbegindoc +An open family\par} +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +type instance Bar Int = ()\\type instance Bar () = Int +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data family Baz a +\end{tabular}] +{\haddockbegindoc +A data family\par} +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +newtype instance Baz Double\\data instance Baz Int\\data instance Baz () +\end{tabular}] +\end{haddockdesc} diff --git a/latex-test/ref/UnboxedStuff/UnboxedStuff.tex b/latex-test/ref/UnboxedStuff/UnboxedStuff.tex new file mode 100644 --- /dev/null +++ b/latex-test/ref/UnboxedStuff/UnboxedStuff.tex @@ -0,0 +1,36 @@ +\haddockmoduleheading{UnboxedStuff} +\label{module:UnboxedStuff} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module UnboxedStuff ( + X, Y, Z, unboxedUnit, unboxedTuple, unboxedSum + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data X +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data Y +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data Z +\end{tabular}] +\end{haddockdesc} +\section{Unboxed type constructors} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +unboxedUnit :: ({\char '43} {\char '43}) -> ({\char '43} {\char '43}) +\end{tabular}] +\item[\begin{tabular}{@{}l} +unboxedTuple :: ({\char '43} X, Y {\char '43}) -> ({\char '43} X, Y, Z {\char '43}) +\end{tabular}] +\item[\begin{tabular}{@{}l} +unboxedSum :: ({\char '43} X | Y {\char '43}) -> ({\char '43} X | Y | Z {\char '43}) +\end{tabular}] +\end{haddockdesc} diff --git a/latex-test/src/ConstructorArgs/ConstructorArgs.hs b/latex-test/src/ConstructorArgs/ConstructorArgs.hs new file mode 100644 --- /dev/null +++ b/latex-test/src/ConstructorArgs/ConstructorArgs.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE GADTs, PatternSynonyms #-} + +module ConstructorArgs (Foo(..), Boo(Foo, Foa, Fo, Fo'), pattern Bo, pattern Bo') where + +data Foo + = Rec -- ^ doc on a record + { x :: String -- ^ doc on the `String` field of `Rec` + , y :: String -- ^ doc on the `String` field of `Rec` + } + | Baz Int String -- ^ old prefix doc style + | Boa -- ^ doc on the `Boa` constrictor + !Int -- ^ doc on the `Int` field of `Boa` + !String -- ^ doc on the `String` field of `Boa` + | Int :| String -- ^ old infix doc style + | Int -- ^ doc on the `Int` field of the `:*` constructor + :* -- ^ doc on the `:*` constructor + String -- ^ doc on the `String` field of the `:*` constructor + +infixr 1 `Foo` +infixr 2 `Boa` +infixr 3 :* + +data Boo where + -- | Info about a 'Foo' + Foo :: Int -- ^ `Int` field of `Foo` + -> String -- ^ `String` field of `Foo` + -> Boo -- ^ Make a `Boo` + + -- | no argument docs GADT + Foa :: Int -> Boo + +infixr 4 `Boo` + +-- | Info about bundled 'Fo' +pattern Fo :: Int -- ^ an 'Int' + -> String -- ^ a 'String' + -> Boo -- ^ a 'Boo' +pattern Fo x y = Foo x y + +-- | Bundled and no argument docs +pattern Fo' :: Boo +pattern Fo' = Foo 1 "hi" + +infixr 5 `Fo` + +-- | Info about not-bundled 'Bo' +pattern Bo :: Int -- ^ an 'Int' + -> String -- ^ a 'String' + -> Boo -- ^ a 'Boo' pattern +pattern Bo x y = Foo x y + +-- | Not bunded and no argument docs +pattern Bo' :: Int -> String -> Boo +pattern Bo' x y = Foo x y + +infixr 6 `Bo` diff --git a/latex-test/src/DefaultSignatures/DefaultSignatures.hs b/latex-test/src/DefaultSignatures/DefaultSignatures.hs new file mode 100644 --- /dev/null +++ b/latex-test/src/DefaultSignatures/DefaultSignatures.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DefaultSignatures #-} + +module DefaultSignatures where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Documentation for the default signature of bar. + default bar :: Show a => a -> String + bar = show + + -- | Documentation for baz'. + baz' :: String -> a + + -- | Documentation for the default signature of baz'. + default baz' :: Read a => String -> a + baz' = read diff --git a/latex-test/src/Deprecated/Deprecated.hs b/latex-test/src/Deprecated/Deprecated.hs new file mode 100644 --- /dev/null +++ b/latex-test/src/Deprecated/Deprecated.hs @@ -0,0 +1,7 @@ +module Deprecated where + +-- | Docs for something deprecated +deprecated :: Int +deprecated = 1 + +{-# DEPRECATED deprecated "Don't use this" #-} diff --git a/latex-test/src/Example/Example.hs b/latex-test/src/Example/Example.hs new file mode 100644 --- /dev/null +++ b/latex-test/src/Example/Example.hs @@ -0,0 +1,11 @@ +module Example where + +-- | Example use. +-- +-- >>> split 1 +-- () +-- +-- >>> split 2 +-- () +split :: Int -> () +split _ = () diff --git a/latex-test/src/GadtConstructorArgs/GadtConstructorArgs.hs b/latex-test/src/GadtConstructorArgs/GadtConstructorArgs.hs new file mode 100644 --- /dev/null +++ b/latex-test/src/GadtConstructorArgs/GadtConstructorArgs.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE GADTs, PatternSynonyms #-} + +module GadtConstructorArgs (Boo(..)) where + +data Boo where + Fot :: { x :: Int -- ^ an 'x' + , y :: Int -- ^ a 'y' + } -> Boo + + -- | Record GADT with docs + Fob :: { w :: Int -- ^ a 'w' + , z :: Int -- ^ a 'z' + } -> Boo -- ^ a 'Boo' diff --git a/latex-test/src/NamespacedIdentifier/NamespacedIdentifier.hs b/latex-test/src/NamespacedIdentifier/NamespacedIdentifier.hs new file mode 100644 --- /dev/null +++ b/latex-test/src/NamespacedIdentifier/NamespacedIdentifier.hs @@ -0,0 +1,13 @@ +module NamespacedIdentifiers where + +-- | A link to: +-- +-- * the type t'Bar' +-- * the constructor v'Bar' +-- * the unimported but qualified type t'A.A' +-- * the unimported but qualified value v'A.A' +-- +data Foo = Bar + +-- | A link to the value v'Foo' (which shouldn't exist). +data Bar diff --git a/latex-test/src/TypeFamilies3/TypeFamilies3.hs b/latex-test/src/TypeFamilies3/TypeFamilies3.hs new file mode 100644 --- /dev/null +++ b/latex-test/src/TypeFamilies3/TypeFamilies3.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeFamilies #-} + +module TypeFamilies3 where + +-- | A closed type family +type family Foo a where + Foo () = Int + Foo _ = () + +-- | An open family +type family Bar a + +type instance Bar Int = () +type instance Bar () = Int + +-- | A data family +data family Baz a + +data instance Baz () = Baz1 +data instance Baz Int = Baz2 Bool +newtype instance Baz Double = Baz3 Float diff --git a/latex-test/src/UnboxedStuff/UnboxedStuff.hs b/latex-test/src/UnboxedStuff/UnboxedStuff.hs new file mode 100644 --- /dev/null +++ b/latex-test/src/UnboxedStuff/UnboxedStuff.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE UnboxedSums, UnboxedTuples #-} +module UnboxedStuff where + +data X +data Y +data Z + +-- * Unboxed type constructors + +unboxedUnit :: (# #) -> (# #) +unboxedUnit = undefined + +unboxedTuple :: (# X, Y #) -> (# X, Y, Z #) +unboxedTuple = undefined + +unboxedSum :: (# X | Y #) -> (# X | Y | Z #) +unboxedSum = undefined +