diff --git a/.travis.yml b/.travis.yml index 2bcb301a10..2417dea916 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,3 +1,6 @@ +# NOTE: manually changes were made to an otherwise autogenerated script. This is to +# query GHC CI artifacts instead of going via Herbert's PPA +# # This Travis job script has been generated by a script via # # make_travis_yml_2.hs 'haddock.cabal' @@ -28,46 +31,50 @@ before_cache: matrix: include: - - compiler: "ghc-head" - env: GHCHEAD=true - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}} + - os: linux + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head], sources: [hvr-ghc]}} + env: + - GHC_ZIP='https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/download?job=validate-x86_64-linux-deb8' before_install: - - HC=${CC} + # Manually install GHC validate artifact + - travis_retry curl -L $GHC_ZIP --output artifact.zip + - unzip artifact.zip + - tar xpf ghc.tar.xz --strip-components 1 + - ./configure + - sudo make V=1 install + + # Set up some vars + - HC=ghc - HCPKG=${HC/ghc/ghc-pkg} - - unset CC - - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH + - PATH=/usr/local/bin:/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH - PKGNAME='haddock' install: - cabal --version - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - BENCH=${BENCH---enable-benchmarks} - - TEST=${TEST---enable-tests} - - GHCHEAD=${GHCHEAD-false} + - BENCH=--enable-benchmarks + - TEST=--enable-tests - travis_retry cabal update -v - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - rm -fv cabal.project.local - rm -f cabal.project.freeze # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage - | - if $GHCHEAD; then - sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config - for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done + sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config + for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done - echo 'repository head.hackage' >> ${HOME}/.cabal/config - echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config - echo ' secure: True' >> ${HOME}/.cabal/config - echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config - echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config - echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config - echo ' key-threshold: 3' >> ${HOME}/.cabal.config + echo 'repository head.hackage' >> ${HOME}/.cabal/config + echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config + echo ' secure: True' >> ${HOME}/.cabal/config + echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config + echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config + echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config + echo ' key-threshold: 3' >> ${HOME}/.cabal.config - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' + grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - cabal new-update head.hackage -v - fi + cabal new-update head.hackage -v - travis_retry cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 --allow-newer --constraint 'setup.Cabal installed' all - travis_retry cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 --allow-newer --constraint 'setup.Cabal installed' all @@ -76,8 +83,8 @@ install: script: - if [ -f configure.ac ]; then autoreconf -i; fi - rm -rf dist/ - - cabal sdist # test that a source-distribution can be generated - - cd dist/ + - cabal new-sdist # test that a source-distribution can be generated + - cd dist-newstyle/sdist/ - SRCTAR=(${PKGNAME}-*.tar.gz) - SRC_BASENAME="${SRCTAR/%.tar.gz}" - tar -xvf "./$SRC_BASENAME.tar.gz" diff --git a/CHANGES.md b/CHANGES.md index 5a9e0d31ee..bb5e845b3a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -6,6 +6,12 @@ * 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) + ## Changes in version 2.22.0 * Make `--package-version` optional for `--hoogle` (#899) diff --git a/doc/invoking.rst b/doc/invoking.rst index 667b89a74c..a056065610 100644 --- a/doc/invoking.rst +++ b/doc/invoking.rst @@ -504,7 +504,7 @@ The following options are available: .. option:: --bypass-interface-version-check - **DANGEROUS** Causes Haddock to ignore the interface verions of + **DANGEROUS** Causes Haddock to ignore the interface versions of binary Haddock interface files. This can make Haddock crash during deserialization of interface files. diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 2a94c5f5f0..af5fd68348 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -46,7 +46,7 @@ library , Cabal ^>= 2.4.0 , ghc ^>= 8.7 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.7.0 + , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by @@ -59,6 +59,7 @@ library , directory , filepath , ghc-boot + , ghc-boot-th , transformers hs-source-dirs: src @@ -97,7 +98,6 @@ library 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 @@ -130,7 +130,6 @@ test-suite spec Haddock Haddock.Backends.Hoogle Haddock.Backends.Hyperlinker - Haddock.Backends.Hyperlinker.Ast Haddock.Backends.Hyperlinker.Renderer Haddock.Backends.Hyperlinker.Utils Haddock.Backends.LaTeX @@ -171,7 +170,7 @@ test-suite spec build-depends: Cabal ^>= 2.4 , ghc ^>= 8.7 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.7.0 + , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2 , hspec >= 2.4.4 && < 2.6 , QuickCheck ^>= 2.11 @@ -187,6 +186,7 @@ test-suite spec , directory , filepath , ghc-boot + , ghc-boot-th , transformers build-tool-depends: diff --git a/haddock-api/resources/html/solarized.css b/haddock-api/resources/html/solarized.css index e83dc5ec70..0146eeddca 100644 --- a/haddock-api/resources/html/solarized.css +++ b/haddock-api/resources/html/solarized.css @@ -53,3 +53,45 @@ a:link, a:visited { a:hover, a.hover-highlight { background-color: #eee8d5; } + +span.annot{ + position:relative; + color:#000; + text-decoration:none + } + +span.annot:hover{z-index:25; background-color:#ff0} + +span.annot span.annottext{ + display: none; + border-radius: 5px 5px; + + -moz-border-radius: 5px; + -webkit-border-radius: 5px; + + box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.1); + -webkit-box-shadow: 5px 5px rgba(0, 0, 0, 0.1); + -moz-box-shadow: 5px 5px rgba(0, 0, 0, 0.1); + + position: absolute; + left: 1em; top: 2em; + z-index: 99; + margin-left: 5; + background: #FFFFAA; + border: 2px solid #FFAD33; + padding: 0.8em 1em; +} + +span.annot:hover span.annottext{ + display:block; +} + +/* This bridges the gap so you can mouse into the tooltip without it disappearing */ +span.annot span.annottext:before{ + content: ""; + position: absolute; + left: -1em; top: -1em; + background: #FFFFFF00; + z-index:-1; + padding: 2em 2em; +} diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 0c75eadf91..4a047db6f8 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -39,6 +39,7 @@ import Haddock.Version import Haddock.InterfaceFile import Haddock.Options import Haddock.Utils +import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) import Control.Monad hiding (forM_) import Data.Foldable (forM_, foldl') @@ -66,6 +67,8 @@ import qualified GHC.Paths as GhcPaths 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) @@ -164,6 +167,15 @@ haddockWithGhc ghc args = handleTopExceptions $ do -- 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 @@ -171,7 +183,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do when noChecks $ hPutStrLn stderr noCheckWarning - ghc flags' $ do + ghc flags' $ withDir $ do dflags <- getDynFlags forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do @@ -202,6 +214,15 @@ haddockWithGhc ghc args = handleTopExceptions $ do -- 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") @@ -221,8 +242,9 @@ withGhc flags action = do 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] @@ -444,24 +466,10 @@ readInterfaceFiles name_cache_accessor pairs bypass_version_check = do -- | 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 - (foldl' gopt_set dynflags - [ -- Include docstrings in .hi-files. - Opt_Haddock - - -- Ignore any aspects of .hi-files except docs. - , Opt_SkipIfaceVersionCheck - - -- If we can't use an old .hi-file, save the new one. - , Opt_WriteInterface - ]) { - 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 $ @@ -492,11 +500,30 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do parseGhcFlags dynflags = do -- TODO: handle warnings? - let flags' = filterRtsFlags flags - (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags') + let extra_opts = + [ Opt_Haddock + -- Include docstrings in .hi-files. + + , Opt_SkipIfaceVersionCheck + -- Ignore any aspects of .hi-files except docs. + + , Opt_WriteInterface + -- If we can't use an old .hi-file, save the new one. + ] ++ + [ Opt_WriteHie | needHieFiles + -- Generate .hie-files + ] + 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 = diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 8f0c4b674d..5ef7d9bba6 100644 --- 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 @@ -8,15 +9,24 @@ module Haddock.Backends.Hyperlinker 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 ) +import Data.Map as M +import FastString ( mkFastString ) +import Module ( Module, moduleName ) +import NameCache ( initNameCache ) +import UniqSupply ( mkSplitUniqSupply ) +import SysTools.Info ( getCompilerInfo' ) + -- | Generate hyperlinked source for given interfaces. -- @@ -27,10 +37,10 @@ ppHyperlinkedSource :: FilePath -- ^ Output directory -> FilePath -- ^ Resource directory -> Maybe FilePath -- ^ Custom CSS file path -> Bool -- ^ Flag indicating whether to pretty-print HTML - -> SrcMap -- ^ Paths to sources + -> 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 @@ -39,17 +49,39 @@ ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do 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 -> writeUtf8File 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 + } <- fmap fst (readHieFile (initNameCache u []) hfp) + comp <- getCompilerInfo' df + + -- 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 comp 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. @@ -63,3 +95,4 @@ highlightScript = "highlight.js" -- | 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 index a9ffc36e54..0000000000 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -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.dL->GHC.L sspan (GHC.HsVar _ name)) - :: GHC.LHsExpr GHC.GhcRn)) -> - pure (sspan, RtkVar (GHC.unLoc name)) - (Just (GHC.dL->GHC.L _ (GHC.RecordCon _ - (GHC.dL->GHC.L sspan name) _))) -> - pure (sspan, RtkVar name) - _ -> empty - rec term = case cast term of - Just (GHC.HsRecField (GHC.dL->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.dL->GHC.L sspan (GHC.HsTyVar _ _ name)) - :: GHC.LHsType GHC.GhcRn)) -> - pure (sspan, RtkType (GHC.unLoc name)) - (Just ((GHC.dL->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.dL->GHC.L sspan name) _ _ _ - :: GHC.HsBind GHC.GhcRn)) -> - pure (sspan, RtkBind name) - (Just (GHC.PatSynBind _ - (GHC.PSB _ (GHC.dL->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.dL->GHC.L sspan (GHC.VarPat _ name)) - :: GHC.LPat GHC.GhcRn)) -> - pure (sspan, RtkBind (GHC.unLoc name)) - (Just (GHC.dL->GHC.L _ - (GHC.ConPatIn (GHC.dL->GHC.L sspan name) recs))) -> - [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs - (Just (GHC.dL->GHC.L _ (GHC.AsPat _ (GHC.dL->GHC.L sspan name) _))) -> - pure (sspan, RtkBind name) - _ -> empty - rec term = case cast term of - (Just (GHC.HsRecField (GHC.dL->GHC.L sspan name) - (_ :: GHC.LPat GHC.GhcRn) _)) -> - pure (sspan, RtkVar name) - _ -> empty - tvar term = case cast term of - (Just ((GHC.dL->GHC.L sspan (GHC.UserTyVar _ name)) - :: GHC.LHsTyVarBndr GHC.GhcRn)) -> - pure (sspan, RtkBind (GHC.unLoc name)) - (Just (GHC.dL->GHC.L _ (GHC.KindedTyVar _ (GHC.dL->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.dL->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.dL->GHC.L sspan name) _ _ _ - :: GHC.HsBind GHC.GhcRn)) - | GHC.isExternalName name -> pure (sspan, RtkDecl name) - (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.dL->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.dL->GHC.L sspan x) -> (sspan, RtkVar x)) names - Just ((GHC.XFixitySig {}) :: GHC.FixitySig GHC.GhcRn) - -> GHC.panic "haddock:decls" - Nothing -> empty - tyfam (GHC.dL->GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName] - tyfam (GHC.dL->GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels" - tyfam _ = GHC.panic "tyfam: Impossible Match" - - sig (GHC.dL->GHC.L _ (GHC.TypeSig _ names _)) = map decl names - sig (GHC.dL->GHC.L _ (GHC.PatSynSig _ names _)) = map decl names - sig (GHC.dL->GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names - sig _ = [] - decl (GHC.dL->GHC.L sspan name) = (sspan, RtkDecl name) - tyref (GHC.dL->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.dL->GHC.L sspan name) = (sspan, RtkType name) - var (GHC.dL->GHC.L sspan name) = (sspan, RtkVar name) - modu (GHC.dL->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 index f84942420d..1d5576cce9 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,213 +1,212 @@ +{-# 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 qualified Data.ByteString.Char8 as BSC + +import GHC.LanguageExtensions.Type + +import BasicTypes ( IntegralLit(..) ) +import DynFlags +import qualified EnumSet as E +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 + :: CompilerInfo -- ^ Underlying CC compiler (whatever expanded CPP) + -> 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 comp 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. + initState = mkPStatePure pflags buf start + buf = stringBufferFromByteString bs + start = mkRealSrcLoc (mkFastString fpath) 1 1 + needPragHack' = needPragHack comp dflags + 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 + + 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 + + -- | 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 + + -- | 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 + + -- | 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 + + -- 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) + + 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 + + let newLoc = mkRealSrcLoc (srcSpanFile spF) (srcSpanEndLine spF) (fromIntegral col) + (bEnd'', _) <- getInput + setInput (bEnd'', newLoc) + + pure (bEnd'', False) + + -- See 'needPragHack' + ITclose_prag{} + | needPragHack' + , '\n' `BSC.elem` spaceBStr + -> getInput >>= \(b,p) -> setInput (b,advanceSrcLoc p '\n') >> pure (bEnd, False) + + _ -> pure (bEnd, inPragDef) + + 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 } + + pure (plainTok : [ spaceTok | not (BS.null spaceBStr) ], inPrag') + + -- | 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) + + +-- | This is really, really, /really/ gross. Problem: consider a Haskell +-- file that looks like: -- --- * 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) +-- @ +-- {-# LANGUAGE CPP #-} +-- module SomeMod where -- -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 - 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 ] - - in case L.lexTokenStream (stringToStringBuffer hSrc) pos dflags of - - -- 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 - - -- Successfully lexed - L.POk ss toks -> - let (new_pos, cpp) = mkToken ITlineComment (L.loc ss) cppSrc - in toks ++ [cpp] ++ go new_pos rest - - -- 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)) - - --- | Split apart the initial file into Haskell source lines ('Left' entries) and --- CPP lines ('Right' entries). +-- #define SIX 6 +-- +-- {-# INLINE foo +-- #-} +-- foo = 1 +-- @ -- --- All characters in the input are present in the output: +-- Clang's CPP replaces the @#define SIX 6@ line with an empty line (as it +-- should), but get confused about @#-}@. I'm guessing it /starts/ by +-- parsing that as a pre-processor directive and, when it fails to, it just +-- leaves the line alone. HOWEVER, it still adds an extra newline. =.= -- --- 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 +-- This function makes sure that the Hyperlinker backend also adds that +-- extra newline (or else our spans won't line up with GHC's anymore). +needPragHack :: CompilerInfo -> DynFlags -> Bool +needPragHack comp dflags = isCcClang && E.member Cpp (extensionFlags dflags) where - ~(l, rest) = spanToNewline 0 s + isCcClang = case comp of + GCC -> False + Clang -> True + AppleClang -> True + AppleClang51 -> True + UnknownCC -> False +-- | Get the input +getInput :: P (StringBuffer, RealSrcLoc) +getInput = P $ \p @ PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc) --- | 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 +-- | Set the input +setInput :: (StringBuffer, RealSrcLoc) -> P () +setInput (buf, srcLoc) = P $ \p -> POk (p { buffer = buf, loc = srcLoc }) () --- | 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) - --- 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) - --- 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) - --- 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, "") - - -- An actual Haskell token - else let (str'', rest) = spanToNewline 0 str' - in (lexed ++ str'', rest) - --- In all other cases, advance one character at a time -spanToNewline n (c:str) = - let (str', rest) = spanToNewline n str - in (c:str', rest) - - --- | 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) - - 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 - - --- | 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 @@ -382,12 +381,7 @@ classify tok = 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 @@ -404,9 +398,9 @@ classify tok = | 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 index d7ea70a609..a7cc7e3ed8 100644 --- 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 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils -import qualified GHC -import qualified Name as GHC -import qualified Unique as GHC +import 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 @@ import qualified Text.XHtml as Html type StyleClass = String +-- | 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 -render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken] - -> Html -render mcss mjs srcs tokens = header mcss mjs <> body srcs 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,25 +61,132 @@ header mcss mjs = , 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"] @@ -87,61 +204,70 @@ tokenStyle TkPragma = ["hs-pragma"] tokenStyle TkUnknown = [] multiclass :: [StyleClass] -> HtmlAttr -multiclass = Html.theclass . intercalate " " +multiclass = Html.theclass . unwords + +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 -externalAnchor :: TokenDetails -> Html -> Html -externalAnchor (RtkDecl name) content = - Html.anchor content ! [ Html.name $ externalAnchorIdent name ] -externalAnchor _ 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 -internalAnchor :: TokenDetails -> Html -> Html -internalAnchor (RtkBind name) content = - Html.anchor content ! [ Html.name $ internalAnchorIdent name ] -internalAnchor _ content = content +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 -externalAnchorIdent :: GHC.Name -> String +externalAnchorIdent :: Name -> String externalAnchorIdent = hypSrcNameUrl -internalAnchorIdent :: GHC.Name -> String -internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique - -hyperlink :: SrcMap -> TokenDetails -> Html -> Html -hyperlink srcs details = case rtkName details of - Left name -> - if GHC.isInternalName name - then internalHyperlink name - else externalNameHyperlink srcs name - Right name -> externalModHyperlink srcs name - -internalHyperlink :: GHC.Name -> Html -> Html -internalHyperlink name content = - Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] - -externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html -externalNameHyperlink srcs name content = case Map.lookup mdl srcs of - Just SrcLocal -> Html.anchor content ! - [ Html.href $ hypSrcModuleNameUrl mdl name ] - Just (SrcExternal path) -> Html.anchor content ! - [ Html.href $ path hypSrcModuleNameUrl mdl name ] - Nothing -> content +internalAnchorIdent :: Name -> String +internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique + +-- | 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 + where - mdl = GHC.nameModule name + internalHyperlink name content = + Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] + + 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 (Just mdl) (Just name) Nothing (".." path) ] + Nothing -> content + where + mdl = nameModule 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 + 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' (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 @@ renderSpace line space = 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 index e377471eac..50916937ef 100644 --- 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 @@ data TokenType | 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 @@ data SrcPath | 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 index 1ade700680..403de38b22 100644 --- 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 @@ module Haddock.Backends.Hyperlinker.Utils , 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 = hypSrcModuleFile hypSrcModuleUrl' :: ModuleName -> String hypSrcModuleUrl' = hypSrcModuleFile' +{-# INLINE hypSrcNameUrl #-} hypSrcNameUrl :: Name -> String -hypSrcNameUrl name = spliceURL - Nothing (Just name) Nothing nameFormat +hypSrcNameUrl = escapeStr . getOccString +{-# INLINE hypSrcLineUrl #-} hypSrcLineUrl :: Int -> String -hypSrcLineUrl line = spliceURL - 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 @@ nameFormat = "%{NAME}" 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/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 0bf629f1ab..2e7cbfef79 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -21,7 +21,7 @@ module Haddock.Convert ( import Bag ( emptyBag ) import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..) - , DefMethSpec(..), PromotionFlag(..) ) + , PromotionFlag(..), DefMethSpec(..) ) import Class import CoAxiom import ConLike @@ -92,7 +92,7 @@ tyThingToLHsDecl prr t = case t of { feqn_ext = noExt , feqn_tycon = fdLName fd , feqn_bndrs = Nothing - -- this must change eventually + -- TODO: this must change eventually , feqn_pats = fdTyVars fd , feqn_fixity = fdFixity fd , feqn_rhs = synifyType WithinType [] rhs } @@ -156,8 +156,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) in HsIB { hsib_ext = map tyVarName tkvs , hsib_body = FamEqn { feqn_ext = noExt , feqn_tycon = name - , feqn_pats = map HsValArg annot_typats , feqn_bndrs = Nothing + -- TODO: this must change eventually + , feqn_pats = map HsValArg annot_typats , feqn_fixity = synifyFixity name , feqn_rhs = hs_rhs } } where diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 3ddde33ecf..24efc39f9f 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -19,12 +19,14 @@ module Haddock.GhcUtils where import Control.Arrow +import Data.Char ( isSpace ) + import Haddock.Types( DocNameI ) import Exception import FastString ( fsLit ) import FV -import Outputable +import Outputable ( Outputable, panic, showPpr ) import Name import NameSet import Module @@ -33,6 +35,7 @@ import HscTypes import GHC import Class import DynFlags +import SrcLoc ( advanceSrcLoc ) import Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind, isInvisibleArgFlag ) import VarSet ( VarSet, emptyVarSet ) @@ -40,6 +43,13 @@ import VarEnv ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) import TyCoRep ( Type(..), isRuntimeRepVar ) import TysWiredIn( liftedRepDataConTyCon ) +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 @@ -425,15 +435,131 @@ minimalDef n = do ------------------------------------------------------------------------------- -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' @@ -535,3 +661,4 @@ defaultRuntimeRepVars = go emptyVarEnv go _ ty@(LitTy {}) = ty go _ ty@(CoercionTy {}) = ty + diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 43de962a07..133036566f 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -43,18 +43,16 @@ import Haddock.Types 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 System.Exit import Text.Printf import Digraph import DynFlags hiding (verbosity) -import Exception import GHC hiding (verbosity) import GhcMake import HscTypes @@ -91,7 +89,7 @@ processModules verbosity modules flags extIfaces = do out verbosity verbose "Creating interfaces..." let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces , iface <- ifInstalledIfaces ext ] - interfaces <- createIfaces0 verbosity modules flags instIfaceMap + interfaces <- createIfaces verbosity modules flags instIfaceMap let exportedNames = Set.unions $ map (Set.fromList . ifaceExports) $ @@ -124,51 +122,22 @@ processModules verbosity modules flags extIfaces = do -------------------------------------------------------------------------------- -createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] -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 - -- Why do we change the output dir here? - -- In any case mustn't set the hiDir to some path where we won't find the - -- .hi-files we need. - modifySessionDynFlags (\dflags0 -> (setOutputDir dir dflags0) { hiDir = hiDir dflags0 } ) - withTempDir dir action - - - depAnalysis :: Ghc ModuleGraph - depAnalysis = do - targets <- mapM (\f -> guessTarget f Nothing) modules - setTargets targets - depanal [] False - - -createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface] -createIfaces verbosity flags instIfaceMap mods = do +createIfaces :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] +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 -- Create (if necessary) and load .hi-files. success <- withTiming getDynFlags "load'" (const ()) $ do - load' LoadAllTargets Nothing mods + load' LoadAllTargets Nothing modGraph when (failed success) $ do out verbosity normal "load' failed" liftIO exitFailure - 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, _) <- foldM f ([], Map.empty) sortedMods return (reverse ifaces) @@ -193,11 +162,12 @@ processModule verbosity modsum flags modMap instIfaceMap = do loadSysInterface (text "processModule 1") (ms_mod modsum) + let mod_loc = ms_location modsum if not $ isBootSummary modsum then do out verbosity verbose "Creating interface..." (interface, msgs) <- {-# SCC createIterface #-} withTiming getDynFlags "createInterface" (const ()) $ - runWriterGhc $ createInterface mod_iface flags modMap instIfaceMap + runWriterGhc $ createInterface mod_iface mod_loc flags modMap instIfaceMap liftIO $ mapM_ putStrLn (nub msgs) dflags <- getDynFlags @@ -264,12 +234,3 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) 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/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 10449ee3e0..f930e2b9a2 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -61,11 +61,12 @@ import PrelNames ( dATA_TUPLE, pRELUDE, gHC_PRIM, gHC_TYPES ) -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'. createInterface :: ModIface + -> ModLocation -> [Flag] -- Boolean flags -> IfaceMap -- Locally processed modules -> InstIfaceMap -- External, already installed interfaces -> ErrMsgGhc Interface -createInterface mod_iface flags modMap instIfaceMap = do +createInterface mod_iface mod_loc flags modMap instIfaceMap = do dflags <- getDynFlags let mdl = mi_module mod_iface @@ -189,7 +190,8 @@ createInterface mod_iface flags modMap instIfaceMap = do , ifaceRnOrphanInstances = [] , ifaceHaddockCoverage = coverage , ifaceWarningMap = warningMap - , ifaceTokenizedSrc = Nothing -- TODO: Get this from the extended .hie-files. + , ifaceHieFile = Just $ ml_hie_file mod_loc + , ifaceDynFlags = dflags } where -- Note [Exporting built-in items] diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index b00d175e77..c329af1021 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -31,23 +31,21 @@ module Haddock.Types ( import Control.Exception import Control.Arrow hiding ((<+>)) import Control.DeepSeq -import Data.Typeable +import Control.Monad (ap) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) -import qualified Data.Map as Map -import Documentation.Haddock.Parser -import Documentation.Haddock.Types import BasicTypes (Fixity(..), PromotionFlag(..)) -import GHC hiding (NoLink) +import GHC import DynFlags (Language, HasDynFlags(..)) import qualified GHC.LanguageExtensions as LangExt import OccName import Outputable -import Control.Monad (ap) -import Control.Monad.IO.Class -import Haddock.Backends.Hyperlinker.Types +import Documentation.Haddock.Types +import Documentation.Haddock.Parser ----------------------------------------------------------------------------- -- * Convenient synonyms @@ -136,7 +134,8 @@ data Interface = Interface -- | 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) @@ -267,7 +266,7 @@ type DocForDecl name = (Documentation name, FnArgsDoc name) noDocForDecl :: DocForDecl name -noDocForDecl = (Documentation Nothing Nothing, Map.empty) +noDocForDecl = (Documentation Nothing Nothing, mempty) ----------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 2550e8238e..69d8034089 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -34,7 +34,7 @@ module Haddock.Utils ( -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, - writeUtf8File, + writeUtf8File, withTempDir, -- * HTML cross reference mapping html_xrefs_ref, html_xrefs_ref', @@ -63,6 +63,7 @@ import Haddock.Types import Haddock.GhcUtils import BasicTypes ( PromotionFlag(..) ) +import Exception (ExceptionMonad) import GHC import Name import Outputable ( panic ) @@ -77,6 +78,7 @@ import Data.List ( isSuffixOf ) import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) import System.Exit +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 @@ -413,6 +415,10 @@ 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-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index 4639253cce..ff18cb401e 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -1,22 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where - import Test.Hspec import Test.QuickCheck -import qualified GHC +import GHC ( runGhc, getSessionDynFlags ) +import DynFlags ( CompilerInfo, DynFlags ) +import SysTools.Info ( getCompilerInfo' ) import Control.Monad.IO.Class +import Data.String ( fromString ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS + import Haddock (getGhcDirs) import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types -withDynFlags :: (GHC.DynFlags -> IO ()) -> IO () +withDynFlags :: ((DynFlags, CompilerInfo) -> IO ()) -> IO () withDynFlags cont = do libDir <- fmap snd (getGhcDirs []) - GHC.runGhc (Just libDir) $ do - dflags <- GHC.getSessionDynFlags - liftIO $ cont dflags + runGhc (Just libDir) $ do + dflags <- getSessionDynFlags + cinfo <- liftIO $ getCompilerInfo' dflags + liftIO $ cont (dflags, cinfo) main :: IO () @@ -53,51 +60,60 @@ instance Arbitrary NoGhcRewrite where parseSpec :: Spec parseSpec = around withDynFlags $ do - it "is total" $ \dflags -> - property $ \src -> length (parse dflags "" src) `shouldSatisfy` (>= 0) + it "is total" $ \(dflags, cinfo) -> + property $ \src -> length (parse cinfo dflags "" (fromString src)) `shouldSatisfy` (>= 0) - it "retains file layout" $ \dflags -> - property $ \(NoGhcRewrite src) -> concatMap tkValue (parse dflags "" src) == src + it "retains file layout" $ \(dflags, cinfo) -> + property $ \(NoGhcRewrite src) -> + let orig = fromString src + lexed = BS.concat (map tkValue (parse cinfo dflags "" orig)) + in lexed == orig context "when parsing single-line comments" $ do - it "should ignore content until the end of line" $ \dflags -> + it "should ignore content until the end of line" $ \(dflags, cinfo) -> shouldParseTo "-- some very simple comment\nidentifier" [TkComment, TkSpace, TkIdentifier] + cinfo dflags - it "should allow endline escaping" $ \dflags -> + it "should allow endline escaping" $ \(dflags, cinfo) -> shouldParseTo "#define first line\\\nsecond line\\\nand another one" [TkCpp] + cinfo dflags context "when parsing multi-line comments" $ do - it "should support nested comments" $ \dflags -> + it "should support nested comments" $ \(dflags, cinfo) -> shouldParseTo "{- comment {- nested -} still comment -} {- next comment -}" [TkComment, TkSpace, TkComment] + cinfo dflags - it "should distinguish compiler pragma" $ \dflags -> + it "should distinguish compiler pragma" $ \(dflags, cinfo) -> shouldParseTo "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}" [TkComment, TkPragma, TkComment] + cinfo dflags - it "should recognize preprocessor directives" $ \dflags -> do + it "should recognize preprocessor directives" $ \(dflags, cinfo) -> do shouldParseTo "\n#define foo bar" - [TkSpace, TkCpp] + [TkCpp] + cinfo dflags shouldParseTo "x # y" [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier] + cinfo dflags - it "should distinguish basic language constructs" $ \dflags -> do + it "should distinguish basic language constructs" $ \(dflags, cinfo) -> do shouldParseTo "(* 2) <$> (\"abc\", foo)" @@ -105,6 +121,7 @@ parseSpec = around withDynFlags $ do , TkSpace, TkOperator, TkSpace , TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial ] + cinfo dflags shouldParseTo @@ -114,6 +131,7 @@ parseSpec = around withDynFlags $ do , TkIdentifier, TkSpace, TkKeyword, TkSpace , TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier ] + cinfo dflags shouldParseTo @@ -124,9 +142,10 @@ parseSpec = around withDynFlags $ do , TkSpace, TkKeyword, TkSpace , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier ] + cinfo dflags - it "should parse do-notation syntax" $ \dflags -> do + it "should parse do-notation syntax" $ \(dflags, cinfo) -> do shouldParseTo "do { foo <- getLine; putStrLn foo }" [ TkKeyword, TkSpace, TkSpecial, TkSpace @@ -134,10 +153,11 @@ parseSpec = around withDynFlags $ do , TkIdentifier, TkSpecial, TkSpace , TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial ] + cinfo dflags shouldParseTo - (unlines + (fromString $ unlines [ "do" , " foo <- getLine" , " putStrLn foo" @@ -146,7 +166,10 @@ parseSpec = around withDynFlags $ do , TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace , TkIdentifier, TkSpace, TkIdentifier, TkSpace ] + cinfo dflags where - shouldParseTo :: String -> [TokenType] -> GHC.DynFlags -> Expectation - shouldParseTo str tokens dflags = map tkType (parse dflags "" str) `shouldBe` tokens + shouldParseTo :: ByteString -> [TokenType] -> CompilerInfo -> DynFlags -> Expectation + shouldParseTo str tokens cinfo dflags = [ tkType tok + | tok <- parse cinfo dflags "" str + , not (BS.null (tkValue tok)) ] `shouldBe` tokens diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md index 971d8dc752..265579ca57 100644 --- a/haddock-library/CHANGES.md +++ b/haddock-library/CHANGES.md @@ -1,7 +1,10 @@ -## TBA +## Changes in version 1.8.0 * Support inline markup in markdown-style links (#875) + * Remove now unused `Documentation.Haddock.Utf8` module. + This module was anyways copied from the `utf8-string` package. + ## Changes in version 1.7.0 * Make `Documentation.Haddock.Parser.Monad` an internal module diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 0b4405b9d2..b24db5d455 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -1,33 +1,42 @@ -cabal-version: 2.0 +cabal-version: 2.2 name: haddock-library -version: 1.7.0 +version: 1.8.0 synopsis: Library exposing some functionality of Haddock. + description: Haddock is a documentation-generation tool for Haskell - libraries. These modules expose some functionality of it - without pulling in the GHC dependency. Please note that the - API is likely to change so specify upper bounds in your - project. For interacting with Haddock + libraries. These modules expose some + functionality of it without pulling in the GHC + dependency. Please note that the API is likely + to change so be sure to specify upper bounds in + your projects. For interacting with Haddock itself, see the [haddock package](https://hackage.haskell.org/package/haddock). -license: BSD3 + +license: BSD-2-Clause license-files: LICENSE maintainer: Alec Theriault , Alex Biehl , Simon Hengel , Mateusz Kowalczyk homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues category: Documentation -build-type: Simple extra-source-files: CHANGES.md -library - default-language: Haskell2010 +common lib-defaults + default-language: Haskell2010 build-depends: - base >= 4.5 && < 4.13 - , bytestring >= 0.9.2.1 && < 0.11 - , containers >= 0.4.2.1 && < 0.7 - , transformers >= 0.3.0 && < 0.6 - , text >= 1.2.3.0 && < 1.3 - , parsec >= 3.1.13.0 && < 3.2 + , base >= 4.5 && < 4.14 + , bytestring ^>= 0.9.2.1 || ^>= 0.10.0.0 + , containers ^>= 0.4.2.1 || ^>= 0.5.0.0 || ^>= 0.6.0.1 + , transformers ^>= 0.3.0.0 || ^>= 0.4.1.0 || ^>= 0.5.0.0 + , text ^>= 1.2.3.0 + , parsec ^>= 3.1.13.0 + + ghc-options: -funbox-strict-fields -Wall -fwarn-tabs + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + +library + import: lib-defaults hs-source-dirs: src @@ -36,74 +45,67 @@ library Documentation.Haddock.Markup Documentation.Haddock.Parser Documentation.Haddock.Types - Documentation.Haddock.Utf8 other-modules: Documentation.Haddock.Parser.Util Documentation.Haddock.Parser.Monad - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs - if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances - - test-suite spec + import: lib-defaults type: exitcode-stdio-1.0 - default-language: Haskell2010 main-is: Spec.hs hs-source-dirs: test - , src - ghc-options: -Wall + src cpp-options: -DTEST other-modules: Documentation.Haddock.Doc + Documentation.Haddock.Markup Documentation.Haddock.Parser Documentation.Haddock.Parser.Monad Documentation.Haddock.Parser.Util Documentation.Haddock.Parser.UtilSpec Documentation.Haddock.ParserSpec Documentation.Haddock.Types - Documentation.Haddock.Utf8 - Documentation.Haddock.Utf8Spec build-depends: - base >= 4.5 && < 4.13 - , base-compat >= 0.9.3 && < 0.11 - , bytestring >= 0.9.2.1 && < 0.11 - , containers >= 0.4.2.1 && < 0.7 - , transformers >= 0.3.0 && < 0.6 - , hspec >= 2.4.4 && < 2.6 - , QuickCheck ^>= 2.11 - , text >= 1.2.3.0 && < 1.3 - , parsec >= 3.1.13.0 && < 3.2 - , deepseq >= 1.3 && < 1.5 + , base-compat ^>= 0.9.3 || ^>= 0.10.0 + , QuickCheck ^>= 2.11.3 + , deepseq ^>= 1.3.0.0 || ^>= 1.4.0.0 + + -- NB: build-depends & build-tool-depends have independent + -- install-plans, so it's best to limit to a single major + -- version of `hspec` & `hspec-discover` to ensure + -- intercompatibility + build-depends: + , hspec ^>= 2.5.5 build-tool-depends: - hspec-discover:hspec-discover >= 2.4.4 && < 2.6 + , hspec-discover:hspec-discover ^>= 2.5.5 test-suite fixtures type: exitcode-stdio-1.0 default-language: Haskell2010 main-is: Fixtures.hs - ghc-options: -Wall -O0 + ghc-options: -Wall hs-source-dirs: fixtures buildable: False build-depends: - base >= 4.5 && < 4.13 + -- intra-package dependency + , haddock-library + -- constraints inherited via lib:haddock-library component + , base + + -- extra dependencies , base-compat >= 0.9.3 && < 0.11 , directory ^>= 1.3.0.2 , filepath ^>= 1.4.1.2 , optparse-applicative ^>= 0.14.0.0 , tree-diff ^>= 0.0.0.1 - -- Depend on the library. - build-depends: - haddock-library - source-repository head type: git subdir: haddock-library diff --git a/haddock-library/src/Documentation/Haddock/Utf8.hs b/haddock-library/src/Documentation/Haddock/Utf8.hs deleted file mode 100644 index 3f75e53b9a..0000000000 --- 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-library/test/Documentation/Haddock/Utf8Spec.hs b/haddock-library/test/Documentation/Haddock/Utf8Spec.hs deleted file mode 100644 index 47e127042c..0000000000 --- a/haddock-library/test/Documentation/Haddock/Utf8Spec.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Documentation.Haddock.Utf8Spec (main, spec) where - -import Test.Hspec -import Test.QuickCheck -import Documentation.Haddock.Utf8 - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "decodeUtf8" $ do - it "is inverse to encodeUtf8" $ do - property $ \xs -> (decodeUtf8 . encodeUtf8) xs `shouldBe` xs diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs index d45201006f..6c19dbca98 100644 --- a/haddock-test/src/Test/Haddock/Xhtml.hs +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -8,7 +8,7 @@ module Test.Haddock.Xhtml ( Xml(..) , parseXml, dumpXml - , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter + , stripLinks, stripLinksWhen, stripAnchorsWhen, stripIdsWhen, stripFooter ) where import Data.Data ( Data(..), Typeable, eqT, (:~:)(..) ) @@ -62,6 +62,14 @@ stripAnchorsWhen p = | qName key == "name" && p val = attr { attrVal = "" } | otherwise = attr +stripIdsWhen :: (String -> Bool) -> Xml -> Xml +stripIdsWhen p = + processAnchors unname + where + unname attr@(Attr { attrKey = key, attrVal = val }) + | qName key == "id" && p val = attr { attrVal = "" } + | otherwise = attr + processAnchors :: (Attr -> Attr) -> Xml -> Xml processAnchors f = Xml . gmapEverywhere f . xmlElement diff --git a/haddock.cabal b/haddock.cabal index 8285764a33..2b8ee6ff89 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -64,7 +64,8 @@ executable haddock -- haddock typically only supports a single GHC major version build-depends: - base ^>= 4.12.0 + -- FIXME: drop 4.12.0.0 once GHC HEAD updates to 4.13.0.0 + base ^>= 4.12.0.0 || ^>= 4.13.0.0 if flag(in-ghc-tree) hs-source-dirs: haddock-api/src, haddock-library/src @@ -78,6 +79,7 @@ executable haddock xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, ghc-boot, + ghc-boot-th, ghc == 8.7.*, bytestring, parsec, @@ -89,7 +91,6 @@ executable haddock Documentation.Haddock.Parser.Monad Documentation.Haddock.Types Documentation.Haddock.Doc - Documentation.Haddock.Utf8 Documentation.Haddock.Parser.Util Documentation.Haddock.Markup @@ -119,7 +120,6 @@ executable haddock 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 diff --git a/hoogle-test/ref/Bug873/test.txt b/hoogle-test/ref/Bug873/test.txt index 3c0e187066..6887331746 100644 --- a/hoogle-test/ref/Bug873/test.txt +++ b/hoogle-test/ref/Bug873/test.txt @@ -21,7 +21,7 @@ module Bug873 -- Note that ($) is levity-polymorphic in its result -- type, so that foo $ True where foo :: Bool -> -- Int# is well-typed. -($) :: () => (a -> b) -> a -> b +($) :: forall (r :: RuntimeRep) a (b :: TYPE r). (a -> b) -> a -> b infixr 0 $ ($$) :: (a -> b) -> a -> b infixr 0 $$ diff --git a/html-test/ref/Bug548.html b/html-test/ref/Bug548.html index 1a906cc385..e040e6031a 100644 --- a/html-test/ref/Bug548.html +++ b/html-test/ref/Bug548.html @@ -148,7 +148,9 @@ >

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

to1 :: :: forall (a0 :: k). Rep1 (WrappedArrowS1 ('MetaSel (' ('Just "unwrapArrow") 'NoSourceUnpackednessS1 ('MetaSel (' ('Just "unwrapArrow") 'NoSourceUnpackednessMyGADTCons :: a -> Int -> MyGADT ( -> MyGADT (Maybe String +> \ No newline at end of file diff --git a/html-test/ref/Hash.html b/html-test/ref/Hash.html index b66915c64d..65b2037b3c 100644 --- a/html-test/ref/Hash.html +++ b/html-test/ref/Hash.html @@ -121,7 +121,7 @@ >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.

    Foo Maybe

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

    foo' :: :: Maybe ( (Maybe a) -> Int -> -> Maybe ( (Maybe Int 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) #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 #

    pattern (:+) :: forall a. a -> a -> [a]
    • :: a -> a -> [a]
  • datapattern (:+) :: forall a. a -> a -> [a] :: a -> a -> [a] infixr 3 +> \ No newline at end of file diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html index af6d0210b1..6b4f8fda5d 100644 --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -68,9 +68,7 @@ >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, FooTypepattern 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, FooTypepattern Blub :: () => forall x. :: () => Show x => x -> BlubTypepattern E :: forall k a (b :: k). a :: a >< b # +> \ No newline at end of file diff --git a/html-test/ref/PromotedTypes.html b/html-test/ref/PromotedTypes.html index cc65b57ef9..9f3395be35 100644 --- a/html-test/ref/PromotedTypes.html +++ b/html-test/ref/PromotedTypes.html @@ -108,7 +108,7 @@ >Cons :: :: Maybe h -> PatternRevCons :: :: Maybe h -> RevPattern +> \ No newline at end of file diff --git a/html-test/ref/Test.html b/html-test/ref/Test.html index c1d6395677..b76622e7dd 100644 --- a/html-test/ref/Test.html +++ b/html-test/ref/Test.html @@ -173,7 +173,7 @@ >A Int ( (Maybe FloatA Int ( (Maybe FloatAssocD X :: Type #

    AssocT X :: Type #

    AssocD Y :: Type #

    AssocT Y :: Type #

  • BatZ1 :: forall (z :: Z). :: Z -> Bat
  • BatZ2 :: forall (z :: Z). {..} -> :: {..} -> Bat 'ZB
  • BatZ1 :: forall (z :: Z). :: Z -> Bat
  • BatZ2 :: forall (z :: Z). {..} -> :: {..} -> Bat 'ZBAssocD Y :: Type #

    AssocT Y :: Type #

    AssocD X :: Type #

    AssocT X :: Type #

    strip + , ccfgClean = strip , ccfgDump = dumpXml , ccfgEqual = (==) `on` dumpXml } where - strip = stripAnchors' . stripLinks' . stripFooter + -- The whole point of the ClangCppBug is to demonstrate a situation where + -- line numbers may vary (and test that links still work). Consequently, we + -- strip out line numbers for this test case. + strip f | takeBaseName f == "ClangCppBug" + = stripAnchors' . stripLinks' . stripIds' . stripIds'' . stripFooter + | otherwise + = stripAnchors' . stripLinks' . stripIds' . stripFooter + stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name + stripIds' = stripIdsWhen $ \name -> "local-" `isPrefixOf` name + stripIds'' = stripIdsWhen $ \name -> "line-" `isPrefixOf` name dirConfig :: DirConfig diff --git a/hypsrc-test/ref/src/CPP.html b/hypsrc-test/ref/src/CPP.html index fb85bd2f01..2ebcae90dc 100644 --- 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
+
    \ No newline at end of file diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html index d2604e823a..443d7f96b6 100644 --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -19,36 +19,40 @@ > class FooFoo aa barbar :: aa -> IntInt bazbaz :: IntInt (aa, aa) instance FooFoo IntInt barbar :: Int -> Int +bar = idInt -> Int +forall a. a -> a +id baz xbaz :: Int -> (Int, Int) +baz x :: Int +x (xInt +x, xInt +x) instance Foo [a] where + >instance Foo [a] where bar = length + > bar :: [a] -> Int bar = [a] -> Int +forall (t :: * -> *) a. Foldable t => t a -> Int +length + baz :: Int -> ([a], [a]) +baz baz _ = ([], [])_ = ([], []) class FooFoo aa => Foo'Foo' aa quuxquux (aa, aa)-> aa quux (x, y) = norf [x, y]quux (x :: a +x, y :: a +y) = [a] -> a +forall a. Foo' a => [a] -> a +norf [a +x, a +y] norfnorf [aa]-> aa norf = quux . baz . sum . map barnorf = (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' IntFoo' Int norfnorf :: [Int] -> Int +norf = sum[Int] -> Int +forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a +sum instance Foo' [a] where + >instance Foo' [a] where quux = uncurry (++) 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 PlughPlugh pp plugh :: p a a -> p b b -> p (a -> b) (b -> a)plugh :: p a a -> p b b -> p (a -> b) (b -> a) instance PlughPlugh EitherEither plughplugh :: Either a a -> Either b b -> Either (a -> b) (b -> a) +plugh (LeftLeft aa :: a +a)= Right(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 +$ consta -> b -> a +forall a b. a -> b -> a +const aa +a plughplugh (RightRight aa :: a +a)= Right(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 +$ consta -> b -> a +forall a b. a -> b -> a +const aa +a plughplugh (LeftLeft bb :: b +b)= Left(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 +$ constb -> a -> b +forall a b. a -> b -> a +const bb +b plughplugh (RightRight bb :: b +b)= Left(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 +$ constb -> a -> b +forall a b. a -> b -> a +const bb +b data FooFoo = BarBar | BazBaz | QuuxQuux FooFoo IntInt newtype NorfNorf = NorfNorf (FooFoo, [FooFoo], FooFoo) barbar, bazbaz, quuxquux :: FooFoo barbar :: Foo +bar = BarFoo +Bar bazbaz :: Foo +baz = BazFoo +Baz quuxquux :: Foo +quux = QuuxFoo -> Int -> Foo +Quux quuxFoo +quux 00 unfoounfoo :: FooFoo -> IntInt unfoounfoo :: Foo -> Int +unfoo BarBar = 00 unfoounfoo BazBaz = 00 unfoounfoo (Quux fooQuux nfoo :: Foo +foo n :: Int +n)= 4242 *Int -> Int -> Int +forall a. Num a => a -> a -> a +* nInt +n +Int -> Int -> Int +forall a. Num a => a -> a -> a ++ unfooFoo -> Int +unfoo fooFoo +foo unnorfunnorf :: NorfNorf [FooFoo] unnorfunnorf :: Norf -> [Foo] +unnorf (NorfNorf (BarBar, xsxs :: [Foo] +xs, BarBar)= xs[Foo] +xs unnorfunnorf (NorfNorf (BazBaz, xsxs :: [Foo] +xs, BazBaz)= reverse[Foo] -> [Foo] +forall a. [a] -> [a] +reverse xs[Foo] +xs unnorfunnorf = undefined[Foo] +forall a. HasCallStack => a +undefined unnorf'unnorf' :: NorfNorf -> IntInt unnorf' xunnorf' :: Norf -> Int +unnorf' x :: Norf +x@(NorfNorf (f1f1 :: Foo +f1@(QuuxQuux _ nn :: Int +n), f2f2 :: Foo +f2@(QuuxQuux f3f3 :: Foo +f3 x'Int +x' +Int -> Int -> Int +forall a. Num a => a -> a -> a ++ nInt +n *Int -> Int -> Int +forall a. Num a => a -> a -> a +* unfooFoo -> Int +unfoo f1Foo +f1 +Int -> Int -> Int +forall a. Num a => a -> a -> a ++ auxFoo -> Int +aux f3Foo +f3 aux fxaux :: Foo -> Int +aux fx :: Foo +fx = unfooFoo -> Int +unfoo f2Foo +f2 *Int -> Int -> Int +forall a. Num a => a -> a -> a +* unfooFoo -> Int +unfoo fxFoo +fx *Int -> Int -> Int +forall a. Num a => a -> a -> a +* unfooFoo -> Int +unfoo f3Foo +f3 x'x' :: Int +x' = sum[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 +. map(Foo -> Int) -> [Foo] -> [Int] +forall a b. (a -> b) -> [a] -> [b] +map unfooFoo -> Int +unfoo .([Foo] -> [Int]) -> (Norf -> [Foo]) -> Norf -> [Int] +forall b c a. (b -> c) -> (a -> b) -> a -> c +. unnorfNorf -> [Foo] +unnorf $(Norf -> Int) -> Norf -> Int +forall a b. (a -> b) -> a -> b +$ xNorf +x foofoo, barbar, bazbaz :: IntInt -> IntInt -> IntInt foo x yfoo :: Int -> Int -> Int +foo x :: Int +x y :: Int +y = x + xInt +x *Int -> Int -> Int +forall a. Num a => a -> a -> a ++ barInt +x yInt -> Int -> Int +forall a. Num a => a -> a -> a +* xInt -> Int -> Int +bar *Int +y yInt +x +Int -> Int -> Int +forall a. Num a => a -> a -> a +* y + >Int bary xInt -> Int -> Int +forall a. Num a => a -> a -> a ++ Int +y +bar :: Int -> Int -> Int +bar x :: Int +x y :: Int +y = y + xInt +y -Int -> Int -> Int +forall a. Num a => a -> a -> a ++ bazInt +x xInt -> Int -> Int +forall a. Num a => a -> a -> a +- yInt -> Int -> Int +baz -Int +x xInt +y +Int -> Int -> Int +forall a. Num a => a -> a -> a +- y + >Int bazx xInt -> Int -> Int +forall a. Num a => a -> a -> a ++ Int +y +baz :: Int -> Int -> Int +baz x :: Int +x y :: Int +y = xInt +x *Int -> Int -> Int +forall a. Num a => a -> a -> a +* yInt +y *Int -> Int -> Int +forall a. Num a => a -> a -> a +* yInt +y *Int -> Int -> Int +forall a. Num a => a -> a -> a +* yInt +y *Int -> Int -> Int +forall a. Num a => a -> a -> a +* xInt +x quuxquux :: IntInt -> IntInt quux xquux :: Int -> Int +quux x :: Int +x = fooInt -> Int -> Int +foo (barInt -> Int -> Int +bar xInt +x xInt +x) (barInt -> Int -> Int +bar xInt +x xInt +x) norfnorf :: IntInt -> IntInt -> IntInt -> IntInt norf x y znorf :: Int -> Int -> Int -> Int +norf x :: Int +x y :: Int +y z :: Int +z | xInt +x <Int -> Int -> Bool +forall a. Ord a => a -> a -> Bool +< 00 = quuxInt -> Int +quux xInt +x | yInt +y <Int -> Int -> Bool +forall a. Ord a => a -> a -> Bool +< 00 = quuxInt -> Int +quux yInt +y | zInt +z <Int -> Int -> Bool +forall a. Ord a => a -> a -> Bool +< 00 = quuxInt -> Int +quux zInt +z | otherwiseBool +otherwise = norfInt -> Int -> Int -> Int +norf (-xInt +x)(-yInt +y)(-zInt +z) mainmain :: IOIO mainmain :: IO () +main putStrLnString -> IO () +putStrLn .(String -> IO ()) -> (Int -> String) -> Int -> IO () +forall b c a. (b -> c) -> (a -> b) -> a -> c +. showInt -> String +forall a. Show a => a -> String +show $(Int -> IO ()) -> Int -> IO () +forall a b. (a -> b) -> a -> b +$ fooInt -> Int -> Int +foo xInt +x yInt +y putStrLnString -> IO () +putStrLn .(String -> IO ()) -> (Int -> String) -> Int -> IO () +forall b c a. (b -> c) -> (a -> b) -> a -> c +. showInt -> String +forall a. Show a => a -> String +show $(Int -> IO ()) -> Int -> IO () +forall a b. (a -> b) -> a -> b +$ quuxInt -> Int +quux zInt +z putStrLnString -> IO () +putStrLn .(String -> IO ()) -> (Int -> String) -> Int -> IO () +forall b c a. (b -> c) -> (a -> b) -> a -> c +. showInt -> String +forall a. Show a => a -> String +show $(Int -> IO ()) -> Int -> IO () +forall a b. (a -> b) -> a -> b +$ Identifiers.norfInt -> Int -> Int -> Int +Identifiers.norf xInt +x yInt +y zInt +z xx :: Int +x = 1010 yy :: Int +y = 2020 zz :: Int +z = 3030 +> \ No newline at end of file diff --git a/hypsrc-test/ref/src/LinkingIdentifiers.html b/hypsrc-test/ref/src/LinkingIdentifiers.html new file mode 100644 index 0000000000..52b2020077 --- /dev/null +++ b/hypsrc-test/ref/src/LinkingIdentifiers.html @@ -0,0 +1,572 @@ +
    -- 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
+
    \ No newline at end of file diff --git a/hypsrc-test/ref/src/Literals.html b/hypsrc-test/ref/src/Literals.html index dfcefc9780..f0d05fbc0a 100644 --- 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] -> [a] +a :: [a] +a +++ :: [a] -> [a] -> [a] ++++ b :: [a] +b ->= [a] + >[a] a +++[a] -> [a] -> [a] +forall a. [a] -> [a] -> [a] +++ [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] +$$$ b :: [a] +b ->= [a] + >[a] ab $$$[a] -> [a] -> [a] +forall a. [a] -> [a] -> [a] ++++ b[a] +a = b +++ a (***) :: [a] -> [a] -> [a](***) :: [a] -> [a] -> [a] (***) a*** :: [a] -> [a] -> [a] +(***) a :: [a] +a = a[a] +a (***)(***) aa :: [a] +a (_:b:b :: [a] +b)= a[a] +a +++[a] -> [a] -> [a] +forall a. [a] -> [a] -> [a] ++++ (a[a] +a ***[a] -> [a] -> [a] +forall a. [a] -> [a] -> [a] +*** b[a] +b) (*/\*) :: [[a]] -> [a] -> [a](*/\*) :: [[a]] -> [a] -> [a] a */\* ba :: [[a]] +a */\* :: [[a]] -> [a] -> [a] +*/\* b :: [a] +b = concatMap([a] -> [a]) -> [[a]] -> [a] +forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] +concatMap (***[a] -> [a] -> [a] +forall a. [a] -> [a] -> [a] +*** b[a] +b) a[[a]] +a (**/\**)(**/\**) :: [[a]] -> [[a]] -> [[a]] :: [[a]] +a :: [[a]] +a **/\** :: [[a]] -> [[a]] -> [[a]] +**/\** b :: [[a]] +b ->= [[a]]([[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]] -> [[a]] +forall a. [a] -> [a] -> [a] ++++ [[a]] +b = zipWith (*/\*) [a +++ b] (a[[a]] +a $$$[[a]] -> [[a]] -> [[a]] +forall a. [a] -> [a] -> [a] +$$$ b[[a]] +b) (#.#) :: a -> b -> (c -> (a, b))(#.#) :: a -> b -> (c -> (a, b)) a #.# ba :: a +a #.# :: a -> b -> c -> (a, b) +#.# b :: b +b = const(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 +$ (aa +a, bb +b) {-# LANGUAGE ScopedTypeVariables #-} module - -foo :: a -> a -> a -foo + +foo :: a -> a -> a +foo :: a -> a -> a +foo = undefineda -> a -> a +forall a. HasCallStack => a +undefined foo'foo' forall aa. aa -> aa -> a -foo'a = undefined + >foo' :: a -> a -> a bar :: a -> bfoo' -> (a,= b) -bara -> a -> a +forall a. HasCallStack => a +undefined + +bar :: a -> b -> (a, b) +bar :: a -> b -> (a, b) +bar = undefineda -> b -> (a, b) +forall a. HasCallStack => a +undefined bar'bar' forall a ba b. aa -> bb (aa, bb) bar'bar' :: a -> b -> (a, b) +bar' = undefineda -> 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 bazbaz' :: forall a b. aa (aa [aa -> aa]-> bb)-> bb bazbaz' :: 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 = undefineda -> a +forall a. a -> a +f a +x baz'quux' forall a ba. aa (aforall ->a. [aa -> aa]) -> b)a +quux' :: a -> (forall a. a -> a) -> a +quux' x :: a +x f :: forall a. a -> a +f ->= ba -> a +forall a. a -> a +f + > a baz'x + + +num :: Num a => a -> a -> a +num :: a -> a -> a +num = undefineda -> a -> a +forall a. HasCallStack => a +undefined quuxnum' :: a -> (forall aa. a -> a) -> a -quux xNum fa = f x - -quux' :: forall=> a. a -> (forall a. a -> a) -> a -quux' x fa = f x - - num :: Num a => a -> a -> a + >num' :: a -> a -> a numnum' = undefined - -num' :: forall a. Num a => 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 = undefined + >[a] -> [b] -> (a, b) +forall a. HasCallStack => a undefined eq :: (Eq a, Eq b) => [a] -> [b] -> (a, b) eqeq' = undefined - -eq' forall a ba b. (Eq a, Eq b) => [a] -> [b] -> (a, b) -eq' = undefined - -mon :: Monad m => (a -> m a) -> m a -mon = undefined - -mon' :: forall m(Eq a., MonadEq mb) ([aa] -> [m ab)] -> (ma, ab) mon'eq' :: [a] -> [b] -> (a, b) +eq' = undefined[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 norfmon' :: a -> (forall am a. OrdMonad am => (aa -> am a)-> a -norfm xa +mon' :: (a -> m a) -> m a +mon' f= (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 = xa +x norf'norf' forall aa. aa forall aa. OrdOrd aa => aa -> aa)-> aa norf'norf' :: a -> (forall a. Ord a => a -> a) -> a +norf' xx :: a +x ff :: forall a. Ord a => a -> a +f = xa +x plughplugh forall aa. aa -> aa plughplugh :: a -> a +plugh xx :: a +x = xa +x :: aa thudthud forall a ba b. (aa -> bb)-> aa (aa, bb) thudthud :: (a -> b) -> a -> (a, b) +thud ff :: a -> b +f xx :: a +x (xa +x :: aa, yb +y) (aa, bb) yy :: b +y (fa -> b +f :: aa -> bb) xa +x :: bb 
    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 
+
+
    \ No newline at end of file diff --git a/hypsrc-test/ref/src/Records.html b/hypsrc-test/ref/src/Records.html index 7d23d114dd..5057b8a438 100644 --- a/hypsrc-test/ref/src/Records.html +++ b/hypsrc-test/ref/src/Records.html @@ -11,25 +11,25 @@ > {-# LANGUAGE RecordWildCards #-} module data PointPoint = PointPoint { xPoint -> Int +x !IntInt , yPoint -> Int +y !IntInt     pointpoint :: IntInt -> IntInt     -> PointPoint point x ypoint :: Int -> Int -> Point +point x :: Int +x y :: Int +y = Point$WPoint :: Int -> Int -> Point +Point { xx :: Int +x = xInt +x, yy :: Int +y = yInt +y lengthSqrlengthSqr :: PointPoint -> IntInt lengthSqrlengthSqr :: Point -> Int +lengthSqr (PointPoint { xx :: Point -> Int +x = xInt +x, yy :: Point -> Int +y = yInt +y = xInt +x *Int -> Int -> Int +forall a. Num a => a -> a -> a +* xInt +x +Int -> Int -> Int +forall a. Num a => a -> a -> a ++ yInt +y *Int -> Int -> Int +forall a. Num a => a -> a -> a +* yInt +y lengthSqr'lengthSqr' :: PointPoint -> IntInt lengthSqr'lengthSqr' :: Point -> Int +lengthSqr' (PointPoint { xInt +x :: Int +x :: Point -> Int +x, yInt +y :: Int +y :: Point -> Int +y = yInt +y *Int -> Int -> Int +forall a. Num a => a -> a -> a +* yInt +y +Int -> Int -> Int +forall a. Num a => a -> a -> a ++ xInt +x *Int -> Int -> Int +forall a. Num a => a -> a -> a +* xInt +x translateXtranslateX, translateYtranslateY :: PointPoint -> IntInt -> PointPoint translateX p dtranslateX :: Point -> Int -> Point +translateX p :: Point +p d :: Int +d = pPoint +p { xx :: Int +x = xPoint -> Int +x pPoint +p +Int -> Int -> Int +forall a. Num a => a -> a -> a ++ dInt +d translateY p dtranslateY :: Point -> Int -> Point +translateY p :: Point +p d :: Int +d = pPoint +p { yy :: Int +y = yPoint -> Int +y pPoint +p +Int -> Int -> Int +forall a. Num a => a -> a -> a ++ dInt +d translatetranslate :: IntInt -> IntInt -> PointPoint -> PointPoint translate x y ptranslate :: Int -> Int -> Point -> Point +translate x :: Int +x y :: Int +y p :: Point +p auxPoint -> Point +aux pPoint +p (dxdx :: Int +dx, dydy :: Int +dy) (xInt +x, yInt +y) aux Point{..}aux :: Point -> Point +aux Point{..} = pPoint +p { xx :: Int +x = xInt +x +Int -> Int -> Int +forall a. Num a => a -> a -> a ++ dxInt +dx, yy :: Int +y = yInt +y +Int -> Int -> Int +forall a. Num a => a -> a -> a ++ dyInt +dy module data QuuxQuux = BarBar | BazBaz newtype FooFoo = FooFoo type FooQuuxFooQuux (FooFoo, QuuxQuux) type QuuxFooQuuxFoo (QuuxQuux, FooFoo) datafamily NorfNorf aa bb datainstance NorfNorf FooFoo QuuxQuux = NFQNFQ FooFoo QuuxQuux datainstance NorfNorf QuuxQuux FooFoo = NQFNQF QuuxQuux FooFoo typefamily Norf'Norf' aa bb typeinstance Norf'Norf' FooFoo QuuxQuux (FooFoo, QuuxQuux) typeinstance Norf'Norf' QuuxQuux FooFoo (QuuxQuux, FooFoo) norf1norf1 :: NorfNorf FooFoo QuuxQuux -> IntInt norf1norf1 :: Norf Foo Quux -> Int +norf1 (NFQNFQ (FooFoo ) BarBar)= 00 norf1norf1 (NFQNFQ (FooFoo ) BazBaz)= 11 norf2norf2 :: NorfNorf QuuxQuux FooFoo -> IntInt norf2norf2 :: Norf Quux Foo -> Int +norf2 (NQFNQF BarBar (FooFoo = 00 norf2norf2 (NQFNQF BazBaz (FooFoo = 11 norf1'norf1' :: Norf'Norf' FooFoo QuuxQuux -> IntInt norf1'norf1' :: Norf' Foo Quux -> Int +norf1' (FooFoo , BarBar)= 00 norf1'norf1' (FooFoo , BazBaz)= 11 norf2'norf2' :: Norf'Norf' QuuxQuux FooFoo -> IntInt norf2'norf2' :: Norf' Quux Foo -> Int +norf2' (BarBar, FooFoo = 00 norf2'norf2' (BazBaz, FooFoo = 11 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 index 0000000000..907316fd8a --- /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 +