diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,26 @@ +Changes in version 2.16.1 + + * Don't default to type constructors for out-of-scope names (#253 and + #375) + + * Fix Hoogle display of constructors (#361) + + * Fully qualify names in Hoogle instances output (#263) + + * Output method documentation in Hoogle backend (#259) + + * Don't print instance safety information in Hoogle (#168) + + * Expand response files in arguments (#285) + + * Build the main executable with -threaded (#399) + + * Use SrcSpan of declarations for inferred type sigs (#207) + + * Fix cross-module instance locations (#383) + + * Fix alignment of Source link for instances in Firefox (#384) + Changes in version 2.16.0 * Experimental collapsible header support (#335) diff --git a/README b/README --- a/README +++ b/README @@ -0,0 +1,72 @@ +# Haddock, a Haskell Documentation Tool + + +#### About haddock + +This is Haddock, a tool for automatically generating documentation +from annotated Haskell source code. It is primary intended for +documenting library interfaces, but it should be useful for any kind +of Haskell code. + +Haddock lets you write documentation annotations next to the +definitions of functions and types in the source code, in a syntax +that is easy on the eye when writing the source code (no heavyweight +mark-up). The documentation generated by Haddock is fully hyperlinked +- click on a type name in a type signature to go straight to the +definition, and documentation, for that type. + +Haddock understands Haskell's module system, so you can structure your +code however you like without worrying that internal structure will be +exposed in the generated documentation. For example, it is common to +implement a library in several modules, but define the external API by +having a single module which re-exports parts of these implementation +modules. Using Haddock, you can still write documentation annotations +next to the actual definitions of the functions and types in the +library, but the documentation annotations from the implementation +will be propagated to the external API when the documentation is +generated. Abstract types and classes are handled correctly. In +fact, even without any documentation annotations, Haddock can generate +useful documentation from your source code. + + +#### Documentation formats + +Haddock can generate documentation in multiple formats; currently HTML +is implemented, and there is partial support for generating LaTeX and +Hoogle. + + +#### Source code documentation + +Full documentation can be found in the doc/ subdirectory, in DocBook +format. + + +#### Contributing + +Please create issues when you have any problems and pull requests if you have some code. + +###### Hacking + +To get started you'll need a latest GHC release installed. Below is an +example setup using cabal sandboxes. + +```bash + git clone https://github.com/haskell/haddock.git + cd haddock + cabal sandbox init + cabal sandbox add-source haddock-library + cabal sandbox add-source haddock-api + # adjust -j to the number of cores you want to use + cabal install -j4 --dependencies-only --enable-tests + cabal configure --enable-tests + cabal build -j4 + # run the test suite + cabal test +``` + +If you're a GHC developer and want to update Haddock to work with your +changes, you should be working on `ghc-head` branch instead of master. +See instructions at +https://ghc.haskell.org/trac/ghc/wiki/WorkingConventions/Git/Submodules +for an example workflow. diff --git a/doc/haddock.xml b/doc/haddock.xml --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -12,7 +12,7 @@ - 2004-08-02 + 2015-06-02 Haddock User Guide Simon @@ -24,12 +24,21 @@ Waern
david.waern@gmail.com
+ + Mateusz + Kowalczyk + +
fuuzetsu@fuuzetsu.co.uk
2010 Simon Marlow, David Waern + + 2013-2015 + Mateusz Kowalczyk + - This document describes Haddock version 2.15.1, a Haskell + This document describes Haddock version 2.16.1, a Haskell documentation tool. @@ -2029,7 +2038,18 @@ 2. No newline separation even in indented lists. -} + The indentation of the first list item is honoured. That is, + in the following example the items are on the same level. Before + Haddock 2.16.1, the second item would have been nested under the + first item which was unexpected. + + +{-| + * foo + * bar +-} +
diff --git a/driver/Main.hs b/driver/Main.hs --- a/driver/Main.hs +++ b/driver/Main.hs @@ -1,7 +1,29 @@ +{-# LANGUAGE ScopedTypeVariables #-} module Main where -import Documentation.Haddock (haddock) -import System.Environment (getArgs) +import Control.Exception +import Documentation.Haddock (haddock) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO main :: IO () -main = getArgs >>= haddock +main = getArgs >>= expandResponse >>= haddock + + +-- | Arguments which look like '@foo' will be replaced with the +-- contents of file @foo@. The contents will be passed through 'words' +-- and blanks filtered out first. +-- +-- We quit if the file is not found or reading somehow fails. +expandResponse :: [String] -> IO [String] +expandResponse = fmap concat . mapM expand + where + expand :: String -> IO [String] + expand ('@':f) = readFileExc f >>= return . filter (not . null) . words + expand x = return [x] + + readFileExc f = + readFile f `catch` \(e :: IOException) -> do + hPutStrLn stderr $ "Error while expanding response file: " ++ show e + exitFailure diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -39,6 +39,7 @@ import Haddock.Utils import Control.Monad hiding (forM_) +import Control.Applicative import Data.Foldable (forM_) import Data.List (isPrefixOf) import Control.Exception @@ -250,9 +251,9 @@ allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = ifaceMod (head ifaces) - pkgKey = modulePackageKey pkgMod + pkgKey = modulePackageKey pkgMod pkgStr = Just (packageKeyString pkgKey) - (pkgName,pkgVer) = modulePackageInfo dflags flags pkgMod + pkgNameVer = modulePackageInfo dflags flags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity @@ -288,12 +289,20 @@ -- TODO: we throw away Meta for both Hoogle and LaTeX right now, -- might want to fix that if/when these two get some work on them when (Flag_Hoogle `elem` flags) $ do - let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] - = title - | otherwise = unpackFS pkgNameFS - where PackageName pkgNameFS = pkgName - ppHoogle dflags pkgNameStr pkgVer title (fmap _doc prologue) visibleIfaces - odir + case pkgNameVer of + Nothing -> putStrLn . unlines $ + [ "haddock: Unable to find a package providing module " + ++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle." + , "" + , " Perhaps try specifying the desired package explicitly" + ++ " using the --package-name" + , " and --package-version arguments." + ] + Just (PackageName pkgNameFS, pkgVer) -> + let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title + | otherwise = unpackFS pkgNameFS + in ppHoogle dflags pkgNameStr pkgVer title (fmap _doc prologue) + visibleIfaces odir when (Flag_LaTeX `elem` flags) $ do ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style @@ -312,12 +321,12 @@ -- contain the package name or version -- provided by the user which we -- prioritise - -> Module -> (PackageName, Data.Version.Version) + -> Module -> Maybe (PackageName, Data.Version.Version) modulePackageInfo dflags flags modu = - (fromMaybe (packageName pkg) (optPackageName flags), - fromMaybe (packageVersion pkg) (optPackageVersion flags)) + cmdline <|> pkgDb where - pkg = getPackageDetails dflags (modulePackageKey modu) + cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags + pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (modulePackageKey modu) ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -15,7 +15,8 @@ ppHoogle ) where - +import BasicTypes (OverlapFlag(..), OverlapMode(..)) +import InstEnv (ClsInst(..)) import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) @@ -95,18 +96,22 @@ dropComment [] = [] -out :: Outputable a => DynFlags -> a -> String -out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr +outWith :: Outputable a => (SDoc -> String) -> a -> [Char] +outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr where f xs | " " `isPrefixOf` xs = f $ drop 19 xs f (x:xs) = x : f xs f [] = [] +out :: Outputable a => DynFlags -> a -> String +out dflags = outWith $ showSDocUnqual dflags operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x +commaSeparate :: Outputable a => DynFlags -> [a] -> String +commaSeparate dflags = showSDocUnqual dflags . interpp'SP --------------------------------------------------------------------- -- How to print each export @@ -119,30 +124,38 @@ where f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = ppSynonym dflags d - f (TyClD d@ClassDecl{}) = ppClass dflags d + f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] f (SigD sig) = ppSig dflags sig f _ = [] ppExport _ _ = [] - -ppSig :: DynFlags -> Sig Name -> [String] -ppSig dflags (TypeSig names sig _) - = [operator prettyNames ++ " :: " ++ outHsType dflags typ] +ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String] +ppSigWithDoc dflags (TypeSig names sig _) subdocs + = concatMap mkDocSig names where - prettyNames = intercalate ", " $ map (out dflags) names + mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n) + ++ [mkSig n] + mkSig n = operator (out dflags n) ++ " :: " ++ outHsType dflags typ + + getDoc :: Located Name -> [Documentation Name] + getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs) + typ = case unL sig of HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d x -> x -ppSig _ _ = [] +ppSigWithDoc _ _ _ = [] +ppSig :: DynFlags -> Sig Name -> [String] +ppSig dflags x = ppSigWithDoc dflags x [] + -- note: does not yet output documentation for class methods -ppClass :: DynFlags -> TyClDecl Name -> [String] -ppClass dflags x = out dflags x{tcdSigs=[]} : - concatMap (ppSig dflags . addContext . unL) (tcdSigs x) +ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppClass dflags x subdocs = out dflags x{tcdSigs=[]} : + concatMap (flip (ppSigWithDoc dflags) subdocs . addContext . unL) (tcdSigs x) where addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs addContext (MinimalSig src sig) = MinimalSig src sig @@ -156,8 +169,16 @@ ppInstance :: DynFlags -> ClsInst -> [String] -ppInstance dflags x = [dropComment $ out dflags x] - +ppInstance dflags x = + [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls] + where + -- As per #168, we don't want safety information about the class + -- in Hoogle output. The easiest way to achieve this is to set the + -- safety information to a state where the Outputable instance + -- produces no output which means no overlap and unsafe (or [safe] + -- is generated). + cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap mempty + , isSafeOverlap = False } } ppSynonym :: DynFlags -> TyClDecl Name -> [String] ppSynonym dflags x = [out dflags x] @@ -198,7 +219,10 @@ apps = foldl1 (\x y -> reL $ HsAppTy x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) - name = out dflags $ map unL $ con_names con + + -- We print the constructors as comma-separated list. See GHC + -- docs for con_names on why it is a list to begin with. + name = commaSeparate dflags . map unL $ con_names con resType = case con_res con of ResTyH98 -> apps $ map (reL . HsTyVar) $ diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -544,14 +544,14 @@ (is, rest') = spanWith isUndocdInstance rest isUndocdInstance :: DocInstance a -> Maybe (InstHead a) -isUndocdInstance (L _ i,Nothing) = Just i +isUndocdInstance (i,Nothing,_) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. ppDocInstance :: Bool -> DocInstance DocName -> LaTeX -ppDocInstance unicode (L _ instHead, doc) = +ppDocInstance unicode (instHead, doc, _) = declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -36,7 +36,6 @@ import Control.Monad ( when, unless ) import Data.Char ( toUpper ) -import Data.Functor ( (<$>) ) import Data.List ( sortBy, groupBy, intercalate, isPrefixOf ) import Data.Maybe import System.FilePath hiding ( () ) @@ -289,7 +288,7 @@ mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html -mkNode qual ss p (Node s leaf pkg short ts) = +mkNode qual ss p (Node s leaf pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of @@ -313,7 +312,7 @@ mdl = intercalate "." (reverse (s:ss)) shortDescr = maybe noHtml (origDocToHtml qual) short - htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg + htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True "" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -27,7 +27,6 @@ import Haddock.Types import Haddock.Doc (combineDocumentation) -import Control.Applicative import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe @@ -498,12 +497,12 @@ ppInstances :: LinksInfo -> [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html ppInstances links instances baseName unicode qual - = subInstances qual instName links True baseName (map instDecl instances) + = subInstances qual instName links True (map instDecl instances) -- force Splice = True to use line URLs where instName = getOccString $ getName baseName - instDecl :: DocInstance DocName -> (SubDecl,SrcSpan) - instDecl (L l inst, maybeDoc) = ((instHead inst, maybeDoc, []),l) + instDecl :: DocInstance DocName -> (SubDecl,Located DocName) + instDecl (inst, maybeDoc,l) = ((instHead inst, maybeDoc, []),l) instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual <+> ppAppNameTypes n ks ts unicode qual instHead (n, ks, ts, TypeInst rhs) = keyword "type" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -19,8 +19,6 @@ docElement, docSection, docSection_, ) where -import Control.Applicative ((<$>)) - import Data.List import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils @@ -64,7 +62,10 @@ then anchor ! [href url] << fromMaybe url mLabel else toHtml $ fromMaybe url mLabel, - markupAName = \aname -> namedAnchor aname << "", + markupAName = \aname + -> if insertAnchors + then namedAnchor aname << "" + else noHtml, markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), markupProperty = pre . toHtml, markupExample = examplesToHtml, diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -44,7 +44,6 @@ import Haddock.Backends.Xhtml.Utils import Haddock.Types import Haddock.Utils (makeAnchorId) - import qualified Data.Map as Map import Text.XHtml hiding ( name, title, p, quote ) @@ -148,20 +147,22 @@ docElement td << fmap (docToHtml Nothing qual) mdoc) : map (cell . (td <<)) subs + -- | Sub table with source information (optional). -subTableSrc :: Qualification -> LinksInfo -> Bool -> DocName -> [(SubDecl,SrcSpan)] -> Maybe Html -subTableSrc _ _ _ _ [] = Nothing -subTableSrc qual lnks splice dn decls = Just $ table << aboves (concatMap subRow decls) +subTableSrc :: Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Maybe Html +subTableSrc _ _ _ [] = Nothing +subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) where - subRow ((decl, mdoc, subs),loc) = - (td ! [theclass "src"] << decl - <+> linkHtml loc + subRow ((decl, mdoc, subs),L loc dn) = + (td ! [theclass "src clearfix"] << + (thespan ! [theclass "inst-left"] << decl) + <+> linkHtml loc dn <-> docElement td << fmap (docToHtml Nothing qual) mdoc ) : map (cell . (td <<)) subs - linkHtml loc@(RealSrcSpan _) = links lnks loc splice dn - linkHtml _ = noHtml + linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn + linkHtml _ _ = noHtml subBlock :: [Html] -> Maybe Html subBlock [] = Nothing @@ -191,12 +192,12 @@ -- | Generate sub table for instance declarations, with source subInstances :: Qualification -> String -- ^ Class name, used for anchor generation - -> LinksInfo -> Bool -> DocName - -> [(SubDecl,SrcSpan)] -> Html -subInstances qual nm lnks splice dn = maybe noHtml wrap . instTable + -> LinksInfo -> Bool + -> [(SubDecl,Located DocName)] -> Html +subInstances qual nm lnks splice = maybe noHtml wrap . instTable where wrap = (subSection <<) . (subCaption +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice dn + instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice subSection = thediv ! [theclass "subs instances"] subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -18,7 +18,6 @@ import Haddock.Options -import Control.Applicative import Control.Monad (liftM) import Data.Char (toLower) import Data.Either (lefts, rights) @@ -206,4 +205,3 @@ concatEither :: [Either a [b]] -> Either a [b] concatEither = liftEither concat . sequenceEither - diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -16,7 +16,6 @@ module Haddock.GhcUtils where -import Control.Applicative ( (<$>) ) import Control.Arrow import Data.Function diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -38,6 +38,7 @@ import Name import Outputable (text, sep, (<+>)) import PrelNames +import SrcLoc import TcRnDriver (tcRnGetInfo) import TcType (tcSplitSigmaTy) import TyCon @@ -68,11 +69,11 @@ -> Ghc (ExportItem Name) attachToExportItem expInfo iface ifaceMap instIfaceMap export = case attachFixities export of - e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do + e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do mb_info <- getAllInfo (tcdName d) insts <- case mb_info of Just (_, _, cls_instances, fam_instances) -> - let fam_insts = [ (L (getSrcSpan n) $ synifyFamInst i opaque, doc) + let fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) ) | i <- sortBy (comparing instFam) fam_instances , let n = getName i , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap @@ -80,14 +81,14 @@ , not $ any (isTypeHidden expInfo) (fi_tys i) , let opaque = isTypeHidden expInfo (fi_rhs i) ] - cls_insts = [ (L (getSrcSpan n) $ synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap) + cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d))) | let is = [ (instanceHead' i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys ] -- fam_insts but with failing type fams filtered out - cleanFamInsts = [ (L l fi, n) | (L l (Right fi), n) <- fam_insts ] - famInstErrs = [ errm | (L _ (Left errm), _) <- fam_insts ] + cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ] + famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ] in do dfs <- getDynFlags let mkBug = (text "haddock-bug:" <+>) . text @@ -106,6 +107,18 @@ ] } attachFixities e = e + -- spanName: attach the location to the name that is the same file as the instance location + spanName s (clsn,_,_,_) (L instL instn) = + let s1 = getSrcSpan s + sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL + then instn + else clsn + in L (getSrcSpan s) sn + -- spanName on Either + spanNameE s (Left e) _ = L (getSrcSpan s) (Left e) + spanNameE s (Right ok) linst = + let L l r = spanName s ok linst + in L l (Right r) instLookup :: (InstalledInterface -> Map.Map Name a) -> Name diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -517,7 +517,7 @@ case findDecl t of ([L l (ValD _)], (doc, _)) -> do -- Top-level binding without type signature - export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap + export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) @@ -620,13 +620,19 @@ O.text "-- Please report this on Haddock issue tracker!" bugWarn = O.showSDoc dflags . warnLine -hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) -hiValExportItem dflags name doc splice fixity = do +-- | This function is called for top-level bindings without type signatures. +-- It gets the type signature from GHC and that means it's not going to +-- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the +-- declaration and use it instead - 'nLoc' here. +hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool + -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) +hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of Nothing -> return (ExportNoDecl name []) - Just decl -> return (ExportDecl decl doc [] [] fixities splice) + Just decl -> return (ExportDecl (fixSpan decl) doc [] [] fixities splice) where + fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t fixities = case fixity of Just f -> [(name, f)] Nothing -> [] @@ -737,7 +743,7 @@ | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. let (doc, _) = lookupDocs name warnings docMap argMap subMap in - fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap) + fmap Just (hiValExportItem dflags name l doc (l `elem` splices) $ M.lookup name fixMap) | otherwise = return Nothing mkExportItem decl@(L l (InstD d)) | Just name <- M.lookup (getInstLoc d) instMap = diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -18,7 +18,6 @@ , processModuleHeader ) where -import Control.Applicative import Data.IntSet (toList) import Data.List import Documentation.Haddock.Doc (metaDocConcat) @@ -31,6 +30,7 @@ import Name import Outputable (showPpr) import RdrName +import RnEnv (dataTcOccs) processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (MDoc Name) @@ -74,7 +74,13 @@ where failure = (emptyHaddockModInfo, Nothing) - +-- | Takes a 'GlobalRdrEnv' which (hopefully) contains all the +-- definitions and a parsed comment and we attempt to make sense of +-- where the identifiers in the comment point to. We're in effect +-- trying to convert 'RdrName's to 'Name's, with some guesswork and +-- fallbacks in case we can't locate the identifiers. +-- +-- See the comments in the source for implementation commentary. rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name rename dflags gre = rn where @@ -82,19 +88,36 @@ DocAppend a b -> DocAppend (rn a) (rn b) DocParagraph doc -> DocParagraph (rn doc) DocIdentifier x -> do - let choices = dataTcOccs' x + -- Generate the choices for the possible kind of thing this + -- is. + let choices = dataTcOccs x + -- Try to look up all the names in the GlobalRdrEnv that match + -- the names. let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices + case names of + -- We found no names in the env so we start guessing. [] -> case choices of [] -> DocMonospaced (DocString (showPpr dflags x)) - [a] -> outOfScope dflags a - a:b:_ | isRdrTc a -> outOfScope dflags a - | otherwise -> outOfScope dflags b + -- There was nothing in the environment so we need to + -- pick some default from what's available to us. We + -- diverge here from the old way where we would default + -- to type constructors as we're much more likely to + -- actually want anchors to regular definitions than + -- type constructor names (such as in #253). So now we + -- only get type constructor links if they are actually + -- in scope. + a:_ -> outOfScope dflags a + + -- There is only one name in the environment that matches so + -- use it. [a] -> DocIdentifier a - a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b - -- If an id can refer to multiple things, we give precedence to type - -- constructors. + -- But when there are multiple names available, default to + -- type constructors: somewhat awfully GHC returns the + -- values in the list positionally. + a:b:_ | isTyConName a -> DocIdentifier a + | otherwise -> DocIdentifier b DocWarning doc -> DocWarning (rn doc) DocEmphasis doc -> DocEmphasis (rn doc) @@ -115,21 +138,14 @@ DocString str -> DocString str DocHeader (Header l t) -> DocHeader $ Header l (rn t) -dataTcOccs' :: RdrName -> [RdrName] --- If the input is a data constructor, return both it and a type --- constructor. This is useful when we aren't sure which we are --- looking at. --- --- We use this definition instead of the GHC's to provide proper linking to --- functions accross modules. See ticket #253 on Haddock Trac. -dataTcOccs' rdr_name - | isDataOcc occ = [rdr_name, rdr_name_tc] - | otherwise = [rdr_name] - where - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName - - +-- | Wrap an identifier that's out of scope (i.e. wasn't found in +-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently +-- we simply monospace the identifier in most cases except when the +-- identifier is qualified: if the identifier is qualified then we can +-- still try to guess and generate anchors accross modules but the +-- users shouldn't rely on this doing the right thing. See tickets +-- #253 and #375 on the confusion this causes depending on which +-- default we pick in 'rename'. outOfScope :: DynFlags -> RdrName -> Doc a outOfScope dflags x = case x of diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -11,7 +11,6 @@ ----------------------------------------------------------------------------- module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where -import Control.Applicative ((<$>)) import Control.Monad (mplus) import Data.Char import DynFlags diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -498,10 +498,11 @@ decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs - instances' <- forM instances $ \(L l inst, idoc) -> do + instances' <- forM instances $ \(inst, idoc, L l n) -> do inst' <- renameInstHead inst + n' <- rename n idoc' <- mapM renameDoc idoc - return (L l inst', idoc') + return (inst', idoc',L l n') fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity) diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -25,7 +25,6 @@ import Control.Monad import Data.Array -import Data.Functor ((<$>)) import Data.IORef import Data.List import qualified Data.Map as Map diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -15,41 +15,44 @@ import Haddock.Types ( MDoc ) import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageKey ) +import Module ( Module, moduleNameString, moduleName, modulePackageKey, packageKeyString ) import DynFlags ( DynFlags ) import Packages ( lookupPackage ) import PackageConfig ( sourcePackageIdString ) -data ModuleTree = Node String Bool (Maybe String) (Maybe (MDoc Name)) [ModuleTree] +data ModuleTree = Node String Bool (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] mkModuleTree dflags showPkgs mods = - foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] + foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod_ | showPkgs = fmap sourcePackageIdString - (lookupPackage dflags (modulePackageKey mod_)) + modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_)) | otherwise = Nothing - fn (mod_,pkg,short) = addToTrees mod_ pkg short + modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString + (lookupPackage dflags (modulePackageKey mod_)) + | otherwise = Nothing + fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short -addToTrees :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] -addToTrees [] _ _ ts = ts -addToTrees ss pkg short [] = mkSubTree ss pkg short -addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) - | s1 > s2 = t : addToTrees (s1:ss) pkg short ts - | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts - | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts +addToTrees :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] +addToTrees [] _ _ _ ts = ts +addToTrees ss pkg srcPkg short [] = mkSubTree ss pkg srcPkg short +addToTrees (s1:ss) pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts) + | s1 > s2 = t : addToTrees (s1:ss) pkg srcPkg short ts + | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_srcPkg this_short (addToTrees ss pkg srcPkg short subs) : ts + | otherwise = mkSubTree (s1:ss) pkg srcPkg short ++ t : ts where this_pkg = if null ss then pkg else node_pkg + this_srcPkg = if null ss then srcPkg else node_srcPkg this_short = if null ss then short else node_short -mkSubTree :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -mkSubTree [] _ _ = [] -mkSubTree [s] pkg short = [Node s True pkg short []] -mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)] +mkSubTree :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] +mkSubTree [] _ _ _ = [] +mkSubTree [s] pkg srcPkg short = [Node s True pkg srcPkg short []] +mkSubTree (s:ss) pkg srcPkg short = [Node s (null ss) Nothing Nothing Nothing (mkSubTree ss pkg srcPkg short)] splitModule :: Module -> [String] diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -300,7 +300,7 @@ ppr (DataInst a) = text "DataInst" <+> ppr a -- | An instance head that may have documentation and a source location. -type DocInstance name = (Located (InstHead name), Maybe (MDoc name)) +type DocInstance name = (InstHead name, Maybe (MDoc name), Located name) -- | The head of an instance. Consists of a class name, a list of kind -- parameters, a list of type parameters and an instance type diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -231,18 +231,20 @@ -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier) -paragraph = examples <|> skipSpace *> ( - since - <|> unorderedList - <|> orderedList - <|> birdtracks - <|> codeblock - <|> property - <|> header - <|> textParagraphThatStartsWithMarkdownLink - <|> definitionList - <|> docParagraph <$> textParagraph - ) +paragraph = examples <|> do + indent <- takeIndent + choice + [ since + , unorderedList indent + , orderedList indent + , birdtracks + , codeblock + , property + , header + , textParagraphThatStartsWithMarkdownLink + , definitionList indent + , docParagraph <$> textParagraph + ] since :: Parser (DocH mod a) since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince >> return DocEmpty @@ -283,16 +285,16 @@ | otherwise = " " -- | Parses unordered (bullet) lists. -unorderedList :: Parser (DocH mod Identifier) -unorderedList = DocUnorderedList <$> p +unorderedList :: BS.ByteString -> Parser (DocH mod Identifier) +unorderedList indent = DocUnorderedList <$> p where - p = ("*" <|> "-") *> innerList p + p = ("*" <|> "-") *> innerList indent p -- | Parses ordered lists (numbered or dashed). -orderedList :: Parser (DocH mod Identifier) -orderedList = DocOrderedList <$> p +orderedList :: BS.ByteString -> Parser (DocH mod Identifier) +orderedList indent = DocOrderedList <$> p where - p = (paren <|> dot) *> innerList p + p = (paren <|> dot) *> innerList indent p dot = (decimal :: Parser Int) <* "." paren = "(" *> decimal <* ")" @@ -301,23 +303,24 @@ -- same paragraph. Usually used as -- -- > someListFunction = listBeginning *> innerList someListFunction -innerList :: Parser [DocH mod Identifier] -> Parser [DocH mod Identifier] -innerList item = do +innerList :: BS.ByteString -> Parser [DocH mod Identifier] + -> Parser [DocH mod Identifier] +innerList indent item = do c <- takeLine - (cs, items) <- more item + (cs, items) <- more indent item let contents = docParagraph . parseString . dropNLs . unlines $ c : cs return $ case items of Left p -> [contents `docAppend` p] Right i -> contents : i -- | Parses definition lists. -definitionList :: Parser (DocH mod Identifier) -definitionList = DocDefList <$> p +definitionList :: BS.ByteString -> Parser (DocH mod Identifier) +definitionList indent = DocDefList <$> p where p = do label <- "[" *> (parseStringBS <$> takeWhile1 (`notElem` ("]\n" :: String))) <* ("]" <* optional ":") c <- takeLine - (cs, items) <- more p + (cs, items) <- more indent p let contents = parseString . dropNLs . unlines $ c : cs return $ case items of Left x -> [(label, contents `docAppend` x)] @@ -330,32 +333,40 @@ -- | Main worker for 'innerList' and 'definitionList'. -- We need the 'Either' here to be able to tell in the respective functions -- whether we're dealing with the next list or a nested paragraph. -more :: Monoid a => Parser a +more :: Monoid a => BS.ByteString -> Parser a -> Parser ([String], Either (DocH mod Identifier) a) -more item = innerParagraphs <|> moreListItems item - <|> moreContent item <|> pure ([], Right mempty) +more indent item = innerParagraphs indent + <|> moreListItems indent item + <|> moreContent indent item + <|> pure ([], Right mempty) -- | Used by 'innerList' and 'definitionList' to parse any nested paragraphs. -innerParagraphs :: Parser ([String], Either (DocH mod Identifier) a) -innerParagraphs = (,) [] . Left <$> ("\n" *> indentedParagraphs) +innerParagraphs :: BS.ByteString + -> Parser ([String], Either (DocH mod Identifier) a) +innerParagraphs indent = (,) [] . Left <$> ("\n" *> indentedParagraphs indent) -- | Attempts to fetch the next list if possibly. Used by 'innerList' and -- 'definitionList' to recursively grab lists that aren't separated by a whole -- paragraph. -moreListItems :: Parser a +moreListItems :: BS.ByteString -> Parser a -> Parser ([String], Either (DocH mod Identifier) a) -moreListItems item = (,) [] . Right <$> (skipSpace *> item) +moreListItems indent item = (,) [] . Right <$> indentedItem + where + indentedItem = string indent *> skipSpace *> item -- | Helper for 'innerList' and 'definitionList' which simply takes -- a line of text and attempts to parse more list content with 'more'. -moreContent :: Monoid a => Parser a +moreContent :: Monoid a => BS.ByteString -> Parser a -> Parser ([String], Either (DocH mod Identifier) a) -moreContent item = first . (:) <$> nonEmptyLine <*> more item +moreContent indent item = first . (:) <$> nonEmptyLine <*> more indent item -- | Parses an indented paragraph. -- The indentation is 4 spaces. -indentedParagraphs :: Parser (DocH mod Identifier) -indentedParagraphs = (concat <$> dropFrontOfPara " ") >>= parseParagraphs +indentedParagraphs :: BS.ByteString -> Parser (DocH mod Identifier) +indentedParagraphs indent = + (concat <$> dropFrontOfPara indent') >>= parseParagraphs + where + indent' = string $ BS.append indent " " -- | Grab as many fully indented paragraphs as we can. dropFrontOfPara :: Parser BS.ByteString -> Parser [String] @@ -381,6 +392,15 @@ takeNonEmptyLine :: Parser String takeNonEmptyLine = do (++ "\n") . decodeUtf8 <$> (takeWhile1 (/= '\n') >>= nonSpace) <* "\n" + +-- | Takes indentation of first non-empty line. +-- +-- More precisely: skips all whitespace-only lines and returns indentation +-- (horizontal space, might be empty) of that non-empty line. +takeIndent :: Parser BS.ByteString +takeIndent = do + indent <- takeHorizontalSpace + "\n" *> takeIndent <|> return indent -- | Blocks of text of the form: -- diff --git a/haddock.cabal b/haddock.cabal --- a/haddock.cabal +++ b/haddock.cabal @@ -1,5 +1,5 @@ name: haddock -version: 2.16.0 +version: 2.16.1 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -42,7 +42,7 @@ default-language: Haskell2010 main-is: Main.hs hs-source-dirs: driver - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 + ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded build-depends: base >= 4.3 && < 4.9 @@ -57,7 +57,7 @@ array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, - ghc >= 7.9 && < 7.11, + ghc >= 7.9 && < 7.12, bytestring, transformers @@ -110,7 +110,7 @@ Haddock.GhcUtils Haddock.Convert else - build-depends: haddock-api == 2.16.0 + build-depends: haddock-api == 2.16.* test-suite html-test type: exitcode-stdio-1.0 diff --git a/html-test/ref/Bug253.html b/html-test/ref/Bug253.html new file mode 100644 --- /dev/null +++ b/html-test/ref/Bug253.html @@ -0,0 +1,99 @@ + +Bug253
Safe HaskellSafe

Bug253

Description

This module tests that if we're trying to link to a qualified + identifier that's not in scope, we get an anchor as if it was a + variable. Previous behaviour was to treat it as a type constructor + so issue like #253 arose. Also see rename function comments in + source.

Synopsis

Documentation

foo :: ()

This link should generate #v anchor: fakeFakeFake

diff --git a/html-test/ref/Bug26.html b/html-test/ref/Bug26.html --- a/html-test/ref/Bug26.html +++ b/html-test/ref/Bug26.html @@ -145,10 +145,12 @@ >
C ()C ()

instance for ()

Produced by Haddock version 2.15.1

version 2.16.1

data DP A = ProblemCtor' Adata DP A = ProblemCtor' A 
data TP A = ProblemCtor Adata TP A = ProblemCtor A 

Produced by Haddock version 2.15.0

version 2.16.1

+Bug387
data DP A = ProblemCtor' Adata DP A = ProblemCtor' A 
Safe HaskellSafe

Bug387

Synopsis

Section1

test1 :: Int

Section2

test2 :: Int

diff --git a/html-test/ref/Bug7.html b/html-test/ref/Bug7.html --- a/html-test/ref/Bug7.html +++ b/html-test/ref/Bug7.html @@ -104,13 +104,15 @@ >
Bar Foo FooBar Foo Foo

Bar Foo FooBar Foo Foo

Produced by Haddock version 2.15.0

version 2.16.1

Produced by Haddock version 2.15.0

version 2.16.1

Hash FloatHash Float 
Hash IntHash Int 
(Hash a, Hash b) => Hash (a, b)(Hash a, Hash b) => Hash (a, b) 
VisibleClass IntVisibleClass Int

VisibleClass VisibleDataVisibleClass VisibleData

Num VisibleDataNum VisibleData

VisibleClass VisibleDataVisibleClass VisibleData

Produced by Haddock version 2.15.0

version 2.16.1

Foo BarFoo Bar

Foo BarFoo Bar

Produced by Haddock version 2.15.0

version 2.16.1

j :: t
  • k :: t
    • No newline separation even in indented lists. We can have any paragraph level element that we normally - can, like headers

    Level 3 header

    with some content…

    • and even more lists inside

    Level 3 header

    with some content…

    • and even more lists inside

    k :: t

    • list may start at arbitrary depth
    • and consecutive items at that depth + belong to the same list

    • of course we can still

      • nest items like we are used to
    • and then get back to initial list
    Show ExprShow Expr 

    Produced by Haddock version 2.15.0

    version 2.16.1

    Show BinOpShow BinOp 

    Produced by Haddock version 2.15.0

    version 2.16.1

    Functor (SomeType f)Functor (SomeType f) 
    Applicative f => Applicative (SomeType f)Applicative f => Applicative (SomeType f) 

    Produced by Haddock version 2.16.0

    version 2.16.1

    +Threaded
    D FloatD Float 
    D IntD Int 
    Safe HaskellNone

    Threaded

    Description

    Ensures haddock built with -threaded.

    Synopsis

    Documentation

    f :: Integer

    $(forkTH) fails at compile time if haddock isn't using the + threaded RTS.

    diff --git a/html-test/ref/Ticket253_1.html b/html-test/ref/Ticket253_1.html deleted file mode 100644 --- a/html-test/ref/Ticket253_1.html +++ /dev/null @@ -1,91 +0,0 @@ - -Ticket253_1
    Safe HaskellSafe

    Ticket253_1

    Synopsis

    Documentation

    foo :: Int

    See bar.

    Also see Baz

    diff --git a/html-test/ref/Ticket253_2.html b/html-test/ref/Ticket253_2.html deleted file mode 100644 --- a/html-test/ref/Ticket253_2.html +++ /dev/null @@ -1,111 +0,0 @@ - -Ticket253_2
    Safe HaskellSafe

    Ticket253_2

    Synopsis

    Documentation

    bar :: Int

    Comment

    data Baz

    Constructors

    Baz 
    diff --git a/html-test/ref/TypeFamilies.html b/html-test/ref/TypeFamilies.html --- a/html-test/ref/TypeFamilies.html +++ b/html-test/ref/TypeFamilies.html @@ -211,11 +211,13 @@ >
    Assoc * XAssoc * X

    Test * XTest * X

    (><) X XX XXX(><) X XX XXX 
    type Foo X = Ytype Foo X = Y

    data AssocD * X = AssocXdata AssocD * X = AssocX 
    type AssocT * X = Foo * Xtype AssocT * X = Foo * X 
    data Bat * X data Bat * X }

    type Foo * X = Ytype Foo * X = Y

    type (<>) * X a = Xtype (<>) * X a = X 
    type (<>) X XXX XX = Xtype (<>) X XXX XX = X 
    Assoc * YAssoc * Y

    Test * YTest * Y

    data Bar Ydata Bar Y 
    data AssocD * Y = AssocYdata AssocD * Y = AssocY 
    type AssocT * Y = Bat * Ytype AssocT * Y = Bat * Y 
    data Bat * Y = BatY Ydata Bat * Y = BatY Y

    type Foo * Y = Xtype Foo * Y = X

    type (<>) * Y a = atype (<>) * Y a = a 
    data Bat Z wheredata Bat Z where } -> Bat Z ZB

    Test * YTest * Y

    Test * XTest * X

    type Foo * Y = Xtype Foo * Y = X

    type Foo * X = Ytype Foo * X = Y

    data Bat Z wheredata Bat Z where } -> Bat Z ZB

    data Bat * Y = BatY Ydata Bat * Y = BatY Y

    data Bat * X data Bat * X }

    Assoc * YAssoc * Y

    Assoc * XAssoc * X

    type (<>) * Y a = atype (<>) * Y a = a 
    type (<>) * X a = Xtype (<>) * X a = X 
    type (<>) X XXX XX = Xtype (<>) X XXX XX = X 

    Produced by Haddock version 2.15.0

    version 2.16.1

    (><) X XX XXX(><) X XX XXX 
    data Bar W = BarX Zdata Bar W = BarX Z

    Shown because BarX is still exported despite Z being hidden

    type Foo Wtype Foo W

    type Foo Wtype Foo W

    type Foo X = Ytype Foo X = Y

    Produced by Haddock version 2.15.0

    version 2.16.1

    "src" @@ -112,11 +111,11 @@ then do out <- readFile outfile ref <- readFile reffile - if not $ haddockEq out ref + if not $ haddockEq (outfile, out) (reffile, ref) then do putStrLn $ "Output for " ++ mod ++ " has changed! Exiting with diff:" - let ref' = stripLinks ref - out' = stripLinks out + let ref' = maybeStripLinks outfile ref + out' = maybeStripLinks reffile out let reffile' = outDir takeFileName reffile ++ ".nolinks" outfile' = outDir takeFileName outfile ++ ".ref.nolinks" writeFile reffile' ref' @@ -134,6 +133,10 @@ else do putStrLn $ "Pass: " ++ mod ++ " (no .ref file)" +-- | List of modules in which we don't 'stripLinks' +preserveLinksModules :: [String] +preserveLinksModules = map (++ ".html") ["Bug253"] + -- | A rather nasty way to drop the Haddock version string from the -- end of the generated HTML files so that we don't have to change -- every single test every time we change versions. We rely on the the @@ -146,9 +149,16 @@ dropTillP ('p':'<':xs) = xs dropTillP (_:xs) = dropTillP xs -haddockEq :: String -> String -> Bool -haddockEq file1 file2 = - stripLinks (dropVersion file1) == stripLinks (dropVersion file2) +haddockEq :: (FilePath, String) -> (FilePath, String) -> Bool +haddockEq (fn1, file1) (fn2, file2) = + maybeStripLinks fn1 (dropVersion file1) + == maybeStripLinks fn2 (dropVersion file2) + +maybeStripLinks :: String -- ^ Module we're considering for stripping + -> String -> String +maybeStripLinks m = if any (`isSuffixOf` m) preserveLinksModules + then id + else stripLinks stripLinks :: String -> String stripLinks str = diff --git a/html-test/src/Bug253.hs b/html-test/src/Bug253.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Bug253.hs @@ -0,0 +1,10 @@ +-- | This module tests that if we're trying to link to a /qualified/ +-- identifier that's not in scope, we get an anchor as if it was a +-- variable. Previous behaviour was to treat it as a type constructor +-- so issue like #253 arose. Also see @rename@ function comments in +-- source. +module Bug253 where + +-- | This link should generate @#v@ anchor: 'DoesNotExist.fakeFakeFake' +foo :: () +foo = () diff --git a/html-test/src/Bug387.hs b/html-test/src/Bug387.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Bug387.hs @@ -0,0 +1,12 @@ +module Bug387 + ( -- * Section1#a:section1# + test1 + -- * Section2#a:section2# + , test2 + ) where + +test1 :: Int +test1 = 223 + +test2 :: Int +test2 = 42 diff --git a/html-test/src/Nesting.hs b/html-test/src/Nesting.hs --- a/html-test/src/Nesting.hs +++ b/html-test/src/Nesting.hs @@ -119,3 +119,18 @@ -} j :: t j = undefined + +{-| + - list may start at arbitrary depth + + - and consecutive items at that depth + belong to the same list + + - of course we can still + + * nest items like we are used to + + - and then get back to initial list +-} +k :: t +k = undefined diff --git a/html-test/src/Threaded.hs b/html-test/src/Threaded.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Threaded.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Ensures haddock built with @-threaded@. +module Threaded where + +import Threaded_TH + +-- | @$(forkTH)@ fails at compile time if haddock isn't using the +-- threaded RTS. +f = $(forkTH) diff --git a/html-test/src/Threaded_TH.hs b/html-test/src/Threaded_TH.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Threaded_TH.hs @@ -0,0 +1,13 @@ +-- | Imported by 'Threaded', since a TH splice can't be used in the +-- module where it is defined. +module Threaded_TH where + +import Control.Concurrent (forkOS) +import Language.Haskell.TH.Syntax (Exp (LitE), Lit (IntegerL), Q, runIO) + +-- | forkOS requires the threaded RTS, so this TH fails if haddock was +-- built without @-threaded@. +forkTH :: Q Exp +forkTH = do + _ <- runIO (forkOS (return ())) + return (LitE (IntegerL 0)) diff --git a/html-test/src/Ticket253_1.hs b/html-test/src/Ticket253_1.hs deleted file mode 100644 --- a/html-test/src/Ticket253_1.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Ticket253_1 where --- | See 'Ticket253_2.bar'. --- --- Also see 'Ticket253_2.Baz' -foo :: Int -foo = 0 diff --git a/html-test/src/Ticket253_2.hs b/html-test/src/Ticket253_2.hs deleted file mode 100644 --- a/html-test/src/Ticket253_2.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Ticket253_2 where --- | Comment -bar :: Int -bar = 0 - -data Baz = Baz
    data Bar W = BarX Zdata Bar W = BarX Z

    Shown because BarX is still exported despite Z being hidden

    data Bar Ydata Bar Y