aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/.ghci1
-rw-r--r--src/Documentation/Haddock.hs15
-rw-r--r--src/Haddock.hs (renamed from src/Main.hs)73
-rw-r--r--src/Haddock/Backends/Hoogle.hs3
-rw-r--r--src/Haddock/Backends/LaTeX.hs7
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs4
-rw-r--r--src/Haddock/Interface.hs7
-rw-r--r--src/Haddock/Interface/AttachInstances.hs91
-rw-r--r--src/Haddock/Interface/Create.hs100
-rw-r--r--src/Haddock/Interface/LexParseRn.hs4
-rw-r--r--src/Haddock/Interface/ParseModuleHeader.hs1
-rw-r--r--src/Haddock/Interface/Rename.hs63
-rw-r--r--src/Haddock/InterfaceFile.hs45
-rw-r--r--src/Haddock/Lex.x4
-rw-r--r--src/Haddock/Parse.y27
-rw-r--r--src/Haddock/Types.hs56
-rw-r--r--src/Haddock/Utils.hs7
17 files changed, 360 insertions, 148 deletions
diff --git a/src/.ghci b/src/.ghci
deleted file mode 100644
index f00e6d55..00000000
--- a/src/.ghci
+++ /dev/null
@@ -1 +0,0 @@
-:set -i../dist/build/autogen -i../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../dist/build/autogen/cabal_macros.h -XCPP -XDeriveDataTypeable -XScopedTypeVariables -XMagicHash
diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs
index 60bb3147..36115a2a 100644
--- a/src/Documentation/Haddock.hs
+++ b/src/Documentation/Haddock.hs
@@ -35,7 +35,13 @@ module Documentation.Haddock (
-- * Documentation comments
Doc(..),
Example(..),
+ Hyperlink(..),
DocMarkup(..),
+ Documentation(..),
+ ArgMap,
+ AliasMap,
+ WarningMap,
+ DocMap,
HaddockModInfo(..),
markup,
@@ -48,8 +54,10 @@ module Documentation.Haddock (
-- * Flags and options
Flag(..),
- DocOption(..)
+ DocOption(..),
+ -- * Program entry point
+ haddock,
) where
@@ -58,7 +66,7 @@ import Haddock.Interface
import Haddock.Types
import Haddock.Options
import Haddock.Utils
-import Main
+import Haddock
-- | Create 'Interface' structures from a given list of Haddock command-line
@@ -70,6 +78,5 @@ createInterfaces
-> [String] -- ^ File or module names
-> IO [Interface] -- ^ Resulting list of interfaces
createInterfaces flags modules = do
- (_, ifaces, _) <- readPackagesAndProcessModules flags modules
+ (_, ifaces, _) <- withGhc' flags (readPackagesAndProcessModules flags modules)
return ifaces
-
diff --git a/src/Main.hs b/src/Haddock.hs
index dc5a49d2..3b31c756 100644
--- a/src/Main.hs
+++ b/src/Haddock.hs
@@ -1,8 +1,8 @@
{-# OPTIONS_GHC -Wwarn #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
--- Module : Main
+-- Module : Haddock
-- Copyright : (c) Simon Marlow 2003-2006,
-- David Waern 2006-2010
-- License : BSD-like
@@ -15,7 +15,7 @@
--
-- Program entry point and top-level code.
-----------------------------------------------------------------------------
-module Main (main, readPackagesAndProcessModules) where
+module Haddock (haddock, readPackagesAndProcessModules, withGhc') where
import Haddock.Backends.Xhtml
@@ -32,14 +32,14 @@ import Haddock.Options
import Haddock.Utils
import Haddock.GhcUtils hiding (pretty)
-import Control.Monad
+import Control.Monad hiding (forM_)
+import Data.Foldable (forM_)
import Control.Exception
import Data.Maybe
import Data.IORef
import qualified Data.Map as Map
import System.IO
import System.Exit
-import System.Environment
#if defined(mingw32_HOST_OS)
import Foreign
@@ -61,9 +61,6 @@ import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals)
import Panic (handleGhcException)
import Module
-import Control.Monad.Fix (MonadFix)
-
-
--------------------------------------------------------------------------------
-- * Exception handling
--------------------------------------------------------------------------------
@@ -123,27 +120,23 @@ handleGhcExceptions =
-------------------------------------------------------------------------------
-main :: IO ()
-main = handleTopExceptions $ do
+-- | Run Haddock with given list of arguments.
+--
+-- Haddock's own main function is defined in terms of this:
+--
+-- > main = getArgs >>= haddock
+haddock :: [String] -> IO ()
+haddock args = handleTopExceptions $ do
-- Parse command-line flags and handle some of them initially.
-- TODO: unify all of this (and some of what's in the 'render' function),
-- into one function that returns a record with a field for each option,
-- or which exits with an error or help message.
- args <- getArgs
(flags, files) <- parseHaddockOpts args
shortcutFlags flags
qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}
- libDir <- fmap snd (getGhcDirs flags)
-
- -- Catches all GHC source errors, then prints and re-throws them.
- let handleSrcErrors action' = flip handleSourceError action' $ \err -> do
- printException err
- liftIO exitFailure
-
- -- Initialize GHC.
- withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do
+ withGhc' flags $ do
dflags <- getDynFlags
@@ -151,9 +144,11 @@ main = handleTopExceptions $ do
(packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
-- Dump an "interface file" (.haddock file), if requested.
- case optDumpInterfaceFile flags of
- Just f -> liftIO $ dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
- Nothing -> return ()
+ forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do
+ writeInterfaceFile path InterfaceFile {
+ ifInstalledIfaces = map toInstalledIface ifaces
+ , ifLinkEnv = homeLinks
+ }
-- Render the interfaces.
liftIO $ renderStep dflags flags qual packages ifaces
@@ -169,6 +164,18 @@ main = handleTopExceptions $ do
liftIO $ renderStep dflags flags qual packages []
+withGhc' :: [Flag] -> Ghc a -> IO a
+withGhc' flags action = do
+ libDir <- fmap snd (getGhcDirs flags)
+
+ -- Catches all GHC source errors, then prints and re-throws them.
+ let handleSrcErrors action' = flip handleSourceError action' $ \err -> do
+ printException err
+ liftIO exitFailure
+
+ withGhc libDir (ghcFlags flags) (\_ -> handleSrcErrors action)
+
+
readPackagesAndProcessModules :: [Flag] -> [String]
-> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
readPackagesAndProcessModules flags files = do
@@ -260,13 +267,12 @@ render dflags flags qual ifaces installedIfaces srcMap = do
-------------------------------------------------------------------------------
-readInterfaceFiles :: (MonadFix m, MonadIO m) =>
- NameCacheAccessor m
- -> [(DocPaths, FilePath)] ->
- m [(DocPaths, InterfaceFile)]
+readInterfaceFiles :: MonadIO m
+ => NameCacheAccessor m
+ -> [(DocPaths, FilePath)]
+ -> m [(DocPaths, InterfaceFile)]
readInterfaceFiles name_cache_accessor pairs = do
- mbPackages <- mapM tryReadIface pairs
- return (catMaybes mbPackages)
+ catMaybes `liftM` mapM tryReadIface pairs
where
-- try to read an interface, warn if we can't
tryReadIface (paths, file) = do
@@ -280,15 +286,6 @@ readInterfaceFiles name_cache_accessor pairs = do
Right f -> return $ Just (paths, f)
-dumpInterfaceFile :: FilePath -> [InstalledInterface] -> LinkEnv -> IO ()
-dumpInterfaceFile path ifaces homeLinks = writeInterfaceFile path ifaceFile
- where
- ifaceFile = InterfaceFile {
- ifInstalledIfaces = ifaces,
- ifLinkEnv = homeLinks
- }
-
-
-------------------------------------------------------------------------------
-- * Creating a GHC session
-------------------------------------------------------------------------------
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 4417dc52..64905a37 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -253,8 +253,9 @@ markupTag dflags = Markup {
markupOrderedList = box (TagL 'o'),
markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
markupCodeBlock = box TagPre,
- markupURL = box (TagInline "a") . str,
+ markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel),
markupAName = const $ str "",
+ markupProperty = box TagPre . str,
markupExample = box TagPre . str . unlines . map exampleToString
}
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 6df9062e..5d0fabe9 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -1002,8 +1002,9 @@ parLatexMarkup ppId = Markup {
markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "",
markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "",
- markupURL = \u _ -> text "\\url" <> braces (text u),
+ markupHyperlink = \l _ -> markupLink l,
markupAName = \_ _ -> empty,
+ markupProperty = \p _ -> quote $ verb $ text p,
markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e
}
where
@@ -1011,6 +1012,10 @@ parLatexMarkup ppId = Markup {
fixString Verb s = s
fixString Mono s = latexMonoFilter s
+ markupLink (Hyperlink url mLabel) = case mLabel of
+ Just label -> text "\\href" <> braces (text url) <> braces (text label)
+ Nothing -> text "\\url" <> braces (text url)
+
markupId ppId_ id v =
case v of
Verb -> theid
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 052116ee..aa4ba377 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -25,6 +25,7 @@ import Haddock.Types
import Haddock.Utils
import Text.XHtml hiding ( name, title, p, quote )
+import Data.Maybe (fromMaybe)
import GHC
@@ -46,9 +47,10 @@ parHtmlMarkup qual ppId = Markup {
markupOrderedList = ordList,
markupDefList = defList,
markupCodeBlock = pre,
- markupURL = \url -> anchor ! [href url] << url,
+ markupHyperlink = \(Hyperlink url mLabel) -> anchor ! [href url] << fromMaybe url mLabel,
markupAName = \aname -> namedAnchor aname << "",
markupPic = \path -> image ! [src path],
+ markupProperty = pre . toHtml,
markupExample = examplesToHtml
}
where
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index e1e65d18..ea1f42e5 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -43,6 +43,7 @@ import Haddock.Utils
import Control.Monad
import Data.List
import qualified Data.Map as Map
+import qualified Data.Set as Set
import Distribution.Verbosity
import System.Directory
import System.FilePath
@@ -72,8 +73,12 @@ processModules verbosity modules flags extIfaces = do
, iface <- ifInstalledIfaces ext ]
interfaces <- createIfaces0 verbosity modules flags instIfaceMap
+ let exportedNames =
+ Set.unions $ map (Set.fromList . ifaceExports) $
+ filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces
+ mods = Set.fromList $ map ifaceMod interfaces
out verbosity verbose "Attaching instances..."
- interfaces' <- attachInstances interfaces instIfaceMap
+ interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap
out verbosity verbose "Building cross-linking environment..."
-- Combine the link envs of the external packages into one
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 427ef84d..04c4e5e1 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE CPP, MagicHash #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.AttachInstances
@@ -20,37 +20,42 @@ import Haddock.Convert
import Control.Arrow
import Data.List
import qualified Data.Map as Map
+import qualified Data.Set as Set
-import GHC
-import Name
-import InstEnv
import Class
+import FastString
+import GHC
import GhcMonad (withSession)
-import TysPrim( funTyCon )
+import Id
+import InstEnv
import MonadUtils (liftIO)
+import Name
+import PrelNames
import TcRnDriver (tcRnGetInfo)
+import TyCon
import TypeRep
+import TysPrim( funTyCon )
import Var hiding (varName)
-import TyCon
-import PrelNames
-import FastString
#define FSLIT(x) (mkFastString# (x#))
+type ExportedNames = Set.Set Name
+type Modules = Set.Set Module
+type ExportInfo = (ExportedNames, Modules)
-attachInstances :: [Interface] -> InstIfaceMap -> Ghc [Interface]
-attachInstances ifaces instIfaceMap = mapM attach ifaces
+attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]
+attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces
where
-- TODO: take an IfaceMap as input
ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]
attach iface = do
- newItems <- mapM (attachToExportItem iface ifaceMap instIfaceMap)
+ newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap)
(ifaceExportItems iface)
return $ iface { ifaceExportItems = newItems }
-attachToExportItem :: Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name)
-attachToExportItem iface ifaceMap instIfaceMap export =
+attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name)
+attachToExportItem expInfo iface ifaceMap instIfaceMap export =
case export of
ExportDecl { expItemDecl = L _ (TyClD d) } -> do
mb_info <- getAllInfo (tcdName d)
@@ -61,6 +66,11 @@ attachToExportItem iface ifaceMap instIfaceMap export =
Just (_, _, instances) ->
let insts = map (first synifyInstHead) $ sortImage (first instHead)
[ (instanceSig i, getName i) | i <- instances ]
+{- FIXME
+ let insts = map (first synifyInstHead) $ sortImage (first instHead) $
+ filter (\((_,_,cls,tys),_) -> not $ isInstanceHidden expInfo cls tys)
+ [ (instanceHead' i, getName i) | i <- instances ]
+-}
in [ (inst, lookupInstDoc name iface ifaceMap instIfaceMap)
| (inst, name) <- insts ]
Nothing -> []
@@ -89,6 +99,22 @@ lookupInstDoc name iface ifaceMap instIfaceMap =
modName = nameModule name
+-- | Like GHC's 'instanceHead' but drops "silent" arguments.
+{- FIXME
+instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type])
+instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys)
+ where
+ dfun = is_dfun ispec
+ (tvs, theta, cls, tys) = instanceHead ispec
+-}
+
+
+-- | Drop "silent" arguments. See GHC Note [Silent superclass
+-- arguments].
+dropSilentArgs :: DFunId -> ThetaType -> ThetaType
+dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta
+
+
-- | Like GHC's getInfo but doesn't cut things out depending on the
-- interative context, which we don't set sufficiently anyway.
getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst]))
@@ -143,3 +169,42 @@ funTyConName = mkWiredInName gHC_PRIM
funTyConKey
(ATyCon funTyCon) -- Relevant TyCon
BuiltInSyntax
+
+--------------------------------------------------------------------------------
+-- Filtering hidden instances
+--------------------------------------------------------------------------------
+
+-- | A class or data type is hidden iff
+--
+-- * it is defined in one of the modules that are being processed
+--
+-- * and it is not exported by any non-hidden module
+isNameHidden :: ExportInfo -> Name -> Bool
+isNameHidden (names, modules) name =
+ nameModule name `Set.member` modules &&
+ not (name `Set.member` names)
+
+-- | We say that an instance is «hidden» iff its class or any (part)
+-- of its type(s) is hidden.
+isInstanceHidden :: ExportInfo -> Class -> [Type] -> Bool
+isInstanceHidden expInfo cls tys =
+ instClassHidden || instTypeHidden
+ where
+ instClassHidden :: Bool
+ instClassHidden = isNameHidden expInfo $ getName cls
+
+ instTypeHidden :: Bool
+ instTypeHidden = any typeHidden tys
+
+ nameHidden :: Name -> Bool
+ nameHidden = isNameHidden expInfo
+
+ typeHidden :: Type -> Bool
+ typeHidden t =
+ case t of
+ TyVarTy {} -> False
+ AppTy t1 t2 -> typeHidden t1 || typeHidden t2
+ TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args
+ FunTy t1 t2 -> typeHidden t1 || typeHidden t2
+ ForAllTy _ ty -> typeHidden ty
+ LitTy _ -> False
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 8f429d9c..40016a0b 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TupleSections, BangPatterns #-}
+{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.Create
@@ -40,7 +41,7 @@ import Name
import Bag
import RdrName
import TcRnTypes
-import FastString (unpackFS)
+import FastString (unpackFS, concatFS)
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -89,8 +90,11 @@ createInterface tm flags modMap instIfaceMap = do
liftErrMsg $ warnAboutFilteredDecls dflags mdl decls
- let warningMap = mkWarningMap warnings gre exportedNames
- exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports
+ warningMap <- liftErrMsg $ mkWarningMap dflags warnings gre exportedNames
+
+ let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
+
+ exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls maps exports
instances instIfaceMap dflags
let !visibleNames = mkVisibleNames exportItems opts
@@ -111,26 +115,29 @@ createInterface tm flags modMap instIfaceMap = do
let !aliases =
mkAliasMap dflags $ tm_renamed_source tm
+ modWarn <- liftErrMsg $ moduleWarning dflags gre warnings
+
return $! Interface {
- ifaceMod = mdl,
- ifaceOrigFilename = msHsFilePath ms,
- ifaceInfo = info,
- ifaceDoc = Documentation mbDoc (moduleWarning warnings),
- ifaceRnDoc = Documentation Nothing Nothing,
- ifaceOptions = opts,
- ifaceDocMap = docMap,
- ifaceArgMap = argMap,
- ifaceRnDocMap = M.empty,
- ifaceRnArgMap = M.empty,
- ifaceExportItems = prunedExportItems,
- ifaceRnExportItems = [],
- ifaceExports = exportedNames,
- ifaceVisibleExports = visibleNames,
- ifaceDeclMap = declMap,
- ifaceSubMap = subMap,
- ifaceModuleAliases = aliases,
- ifaceInstances = instances,
- ifaceHaddockCoverage = coverage
+ ifaceMod = mdl
+ , ifaceOrigFilename = msHsFilePath ms
+ , ifaceInfo = info
+ , ifaceDoc = Documentation mbDoc modWarn
+ , ifaceRnDoc = Documentation Nothing Nothing
+ , ifaceOptions = opts
+ , ifaceDocMap = docMap
+ , ifaceArgMap = argMap
+ , ifaceRnDocMap = M.empty
+ , ifaceRnArgMap = M.empty
+ , ifaceExportItems = prunedExportItems
+ , ifaceRnExportItems = []
+ , ifaceExports = exportedNames
+ , ifaceVisibleExports = visibleNames
+ , ifaceDeclMap = declMap
+ , ifaceSubMap = subMap
+ , ifaceModuleAliases = aliases
+ , ifaceInstances = instances
+ , ifaceHaddockCoverage = coverage
+ , ifaceWarningMap = warningMap
}
mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
@@ -166,31 +173,35 @@ lookupModuleDyn dflags Nothing mdlName =
-- Warnings
-------------------------------------------------------------------------------
-type WarningMap = DocMap Name
-
-mkWarningMap :: Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
-mkWarningMap NoWarnings _ _ = M.empty
-mkWarningMap (WarnAll _) _ _ = M.empty
-mkWarningMap (WarnSome ws) gre exps = M.fromList
- [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
- , let n = gre_name elt, n `elem` exps ]
+mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
+mkWarningMap dflags warnings gre exps = case warnings of
+ NoWarnings -> return M.empty
+ WarnAll _ -> return M.empty
+ WarnSome ws -> do
+ let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
+ , let n = gre_name elt, n `elem` exps ]
+ M.fromList <$> mapM parse ws'
+ where
+ parse (n, w) = (,) n <$> parseWarning dflags gre w
-moduleWarning :: Warnings -> Maybe (Doc id)
-moduleWarning ws =
+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
+moduleWarning dflags gre ws =
case ws of
- NoWarnings -> Nothing
- WarnSome _ -> Nothing
- WarnAll w -> Just $! warnToDoc w
-
-
-warnToDoc :: WarningTxt -> Doc id
-warnToDoc w = case w of
- (DeprecatedTxt msg) -> format "Deprecated: " msg
- (WarningTxt msg) -> format "Warning: " msg
+ NoWarnings -> return Nothing
+ WarnSome _ -> return Nothing
+ WarnAll w -> Just <$> parseWarning dflags gre w
+
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
+parseWarning dflags gre w = do
+ r <- case w of
+ (DeprecatedTxt msg) -> format "Deprecated: " (concatFS msg)
+ (WarningTxt msg) -> format "Warning: " (concatFS msg)
+ r `deepseq` return r
where
- format x xs = let !str = force $ concat (x : map unpackFS xs)
- in DocWarning $ DocParagraph $ DocString str
+ format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
+ . fromMaybe (DocString . unpackFS $ xs)
+ <$> processDocString dflags gre (HsDocString xs)
-------------------------------------------------------------------------------
@@ -703,6 +714,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
f x xs = x : xs
+ mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
mbDoc <- liftErrMsg $ processDocString dflags gre docStr
return $ fmap (ExportGroup lev "") mbDoc
@@ -777,7 +789,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)
--- | Keep exprt items with docs.
+-- | Keep export items with docs.
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
pruneExportItems = filter hasDoc
where
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index 8070b137..ced12d8d 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE BangPatterns #-}
-----------------------------------------------------------------------------
-- |
@@ -117,9 +118,10 @@ rename dflags gre = rn
DocCodeBlock doc -> DocCodeBlock (rn doc)
DocIdentifierUnchecked x -> DocIdentifierUnchecked x
DocModule str -> DocModule str
- DocURL str -> DocURL str
+ DocHyperlink l -> DocHyperlink l
DocPic str -> DocPic str
DocAName str -> DocAName str
+ DocProperty p -> DocProperty p
DocExamples e -> DocExamples e
DocEmpty -> DocEmpty
DocString str -> DocString str
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
index 411b6661..18f4c768 100644
--- a/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.ParseModuleHeader
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index b384886c..a2499726 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -82,42 +82,41 @@ renameInterface dflags renamingEnv warnings iface =
--------------------------------------------------------------------------------
-newtype GenRnM n a =
- RnM { unRn :: (n -> (Bool, DocName)) -- name lookup function
- -> (a,[n])
+newtype RnM a =
+ RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function
+ -> (a,[Name])
}
-type RnM a = GenRnM Name a
-
-instance Monad (GenRnM n) where
+instance Monad RnM where
(>>=) = thenRn
return = returnRn
-instance Functor (GenRnM n) where
+instance Functor RnM where
fmap f x = do a <- x; return (f a)
-instance Applicative (GenRnM n) where
+instance Applicative RnM where
pure = return
(<*>) = ap
-returnRn :: a -> GenRnM n a
+returnRn :: a -> RnM a
returnRn a = RnM (const (a,[]))
-thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b
+thenRn :: RnM a -> (a -> RnM b) -> RnM b
m `thenRn` k = RnM (\lkp -> case unRn m lkp of
(a,out1) -> case unRn (k a) lkp of
(b,out2) -> (b,out1++out2))
getLookupRn :: RnM (Name -> (Bool, DocName))
getLookupRn = RnM (\lkp -> (lkp,[]))
+
outRn :: Name -> RnM ()
outRn name = RnM (const ((),[name]))
-lookupRn :: (DocName -> a) -> Name -> RnM a
-lookupRn and_then name = do
+lookupRn :: Name -> RnM DocName
+lookupRn name = do
lkp <- getLookupRn
case lkp name of
- (False,maps_to) -> do outRn name; return (and_then maps_to)
- (True, maps_to) -> return (and_then maps_to)
+ (False,maps_to) -> do outRn name; return maps_to
+ (True, maps_to) -> return maps_to
runRnFM :: LinkEnv -> RnM a -> (a,[Name])
@@ -134,7 +133,7 @@ runRnFM env rn = unRn rn lkp
rename :: Name -> RnM DocName
-rename = lookupRn id
+rename = lookupRn
renameL :: Located Name -> RnM (Located DocName)
@@ -199,9 +198,10 @@ renameDoc d = case d of
DocCodeBlock doc -> do
doc' <- renameDoc doc
return (DocCodeBlock doc')
- DocURL str -> return (DocURL str)
+ DocHyperlink l -> return (DocHyperlink l)
DocPic str -> return (DocPic str)
DocAName str -> return (DocAName str)
+ DocProperty p -> return (DocProperty p)
DocExamples e -> return (DocExamples e)
@@ -270,8 +270,16 @@ renameType t = case t of
HsTyLit x -> return (HsTyLit x)
- _ -> error "renameType"
+ HsWrapTy a b -> HsWrapTy a <$> renameType b
+ HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a
+ HsCoreTy a -> pure (HsCoreTy a)
+ HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b
+ HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
+ HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a
+ HsSpliceTy _ _ _ -> error "renameType: HsSpliceTy"
+renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName)
+renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c
renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)
renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
@@ -402,22 +410,25 @@ renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
, con_details = details', con_res = restype', con_doc = mbldoc' })
where
- renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields
+ renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields
renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
renameDetails (InfixCon a b) = do
a' <- renameLType a
b' <- renameLType b
return (InfixCon a' b')
- renameField (ConDeclField name t doc) = do
- name' <- renameL name
- t' <- renameLType t
- doc' <- mapM renameLDocHsSyn doc
- return (ConDeclField name' t' doc')
-
renameResType (ResTyH98) = return ResTyH98
renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
+
+renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName)
+renameConDeclFieldField (ConDeclField name t doc) = do
+ name' <- renameL name
+ t' <- renameLType t
+ doc' <- mapM renameLDocHsSyn doc
+ return (ConDeclField name' t' doc')
+
+
renameSig :: Sig Name -> RnM (Sig DocName)
renameSig sig = case sig of
TypeSig lnames ltype -> do
@@ -498,8 +509,8 @@ renameExportItem item = case item of
return (inst', idoc')
return (ExportDecl decl' doc' subs' instances')
ExportNoDecl x subs -> do
- x' <- lookupRn id x
- subs' <- mapM (lookupRn id) subs
+ x' <- lookupRn x
+ subs' <- mapM lookupRn subs
return (ExportNoDecl x' subs')
ExportDoc doc -> do
doc' <- renameDoc doc
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index a07b1b03..ec7272e7 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
@@ -61,9 +61,18 @@ binaryInterfaceMagic :: Word32
binaryInterfaceMagic = 0xD0Cface
--- Since datatypes in the GHC API might change between major versions, and
--- because we store GHC datatypes in our interface files, we need to make sure
--- we version our interface files accordingly.
+-- IMPORTANT: Since datatypes in the GHC API might change between major
+-- versions, and because we store GHC datatypes in our interface files, we need
+-- to make sure we version our interface files accordingly.
+--
+-- If you change the interface file format or adapt Haddock to work with a new
+-- major version of GHC (so that the format changes indirectly) *you* need to
+-- follow these steps:
+--
+-- (1) increase `binaryInterfaceVersion`
+--
+-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
+--
binaryInterfaceVersion :: Word16
#if __GLASGOW_HASKELL__ == 702
binaryInterfaceVersion = 20
@@ -76,9 +85,12 @@ binaryInterfaceVersion = 20
#elif __GLASGOW_HASKELL__ == 706
binaryInterfaceVersion = 20
#elif __GLASGOW_HASKELL__ == 707
-binaryInterfaceVersion = 20
+binaryInterfaceVersion = 22
+
+binaryInterfaceVersionCompatibility :: [Word16]
+binaryInterfaceVersionCompatibility = [21, 22]
#else
-#error Unknown GHC version
+#error Unsupported GHC version
#endif
@@ -189,7 +201,7 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do
case () of
_ | magic /= binaryInterfaceMagic -> return . Left $
"Magic number mismatch: couldn't load interface file: " ++ filename
- | version /= binaryInterfaceVersion -> return . Left $
+ | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $
"Interface file is of wrong version: " ++ filename
| otherwise -> with_name_cache $ \update_nc -> do
@@ -417,6 +429,15 @@ instance Binary Example where
result <- get bh
return (Example expression result)
+instance Binary Hyperlink where
+ put_ bh (Hyperlink url label) = do
+ put_ bh url
+ put_ bh label
+ get bh = do
+ url <- get bh
+ label <- get bh
+ return (Hyperlink url label)
+
{-* Generated by DrIFT : Look, but Don't Touch. *-}
instance (Binary id) => Binary (Doc id) where
@@ -456,7 +477,7 @@ instance (Binary id) => Binary (Doc id) where
put_ bh (DocCodeBlock al) = do
putByte bh 11
put_ bh al
- put_ bh (DocURL am) = do
+ put_ bh (DocHyperlink am) = do
putByte bh 12
put_ bh am
put_ bh (DocPic x) = do
@@ -474,6 +495,9 @@ instance (Binary id) => Binary (Doc id) where
put_ bh (DocWarning ag) = do
putByte bh 17
put_ bh ag
+ put_ bh (DocProperty x) = do
+ putByte bh 18
+ put_ bh x
get bh = do
h <- getByte bh
case h of
@@ -515,7 +539,7 @@ instance (Binary id) => Binary (Doc id) where
return (DocCodeBlock al)
12 -> do
am <- get bh
- return (DocURL am)
+ return (DocHyperlink am)
13 -> do
x <- get bh
return (DocPic x)
@@ -531,6 +555,9 @@ instance (Binary id) => Binary (Doc id) where
17 -> do
ag <- get bh
return (DocWarning ag)
+ 18 -> do
+ x <- get bh
+ return (DocProperty x)
_ -> fail "invalid binary data found"
diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x
index b9ebe688..0d8dd954 100644
--- a/src/Haddock/Lex.x
+++ b/src/Haddock/Lex.x
@@ -50,6 +50,7 @@ $ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:]
<0,para> {
$ws* \n ;
$ws* \> { begin birdtrack }
+ $ws* prop \> .* \n { strtoken TokProperty `andBegin` property}
$ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr }
$ws* [\*\-] { token TokBullet `andBegin` string }
$ws* \[ { token TokDefStart `andBegin` def }
@@ -74,6 +75,8 @@ $ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:]
<birdtrack> .* \n? { strtokenNL TokBirdTrack `andBegin` line }
+<property> () { token TokPara `andBegin` para }
+
<example> {
$ws* \n { token TokPara `andBegin` para }
$ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr }
@@ -129,6 +132,7 @@ data Token
| TokEmphasis String
| TokAName String
| TokBirdTrack String
+ | TokProperty String
| TokExamplePrompt String
| TokExampleExpression String
| TokExampleResult String
diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y
index e36e8416..f40ff521 100644
--- a/src/Haddock/Parse.y
+++ b/src/Haddock/Parse.y
@@ -7,10 +7,10 @@
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
-module Haddock.Parse where
+module Haddock.Parse (parseString, parseParas) where
import Haddock.Lex
-import Haddock.Types (Doc(..), Example(Example))
+import Haddock.Types (Doc(..), Example(Example), Hyperlink(..))
import Haddock.Doc
import HsSyn
import RdrName
@@ -35,6 +35,7 @@ import Data.List (stripPrefix)
'-' { (TokBullet,_) }
'(n)' { (TokNumber,_) }
'>..' { (TokBirdTrack $$,_) }
+ PROP { (TokProperty $$,_) }
PROMPT { (TokExamplePrompt $$,_) }
RESULT { (TokExampleResult $$,_) }
EXP { (TokExampleExpression $$,_) }
@@ -73,12 +74,16 @@ defpara :: { (Doc RdrName, Doc RdrName) }
para :: { Doc RdrName }
: seq { docParagraph $1 }
| codepara { DocCodeBlock $1 }
+ | property { $1 }
| examples { DocExamples $1 }
codepara :: { Doc RdrName }
: '>..' codepara { docAppend (DocString $1) $2 }
| '>..' { DocString $1 }
+property :: { Doc RdrName }
+ : PROP { makeProperty $1 }
+
examples :: { [Example] }
: example examples { $1 : $2 }
| example { [$1] }
@@ -107,7 +112,7 @@ seq1 :: { Doc RdrName }
elem1 :: { Doc RdrName }
: STRING { DocString $1 }
| '/../' { DocEmphasis (DocString $1) }
- | URL { DocURL $1 }
+ | URL { DocHyperlink (makeHyperlink $1) }
| PIC { DocPic $1 }
| ANAME { DocAName $1 }
| IDENT { DocIdentifier $1 }
@@ -121,6 +126,22 @@ strings :: { String }
happyError :: [LToken] -> Maybe a
happyError toks = Nothing
+-- | Create a `Hyperlink` from given string.
+--
+-- A hyperlink consists of a URL and an optional label. The label is separated
+-- from the url by one or more whitespace characters.
+makeHyperlink :: String -> Hyperlink
+makeHyperlink input = case break isSpace $ strip input of
+ (url, "") -> Hyperlink url Nothing
+ (url, label) -> Hyperlink url (Just . dropWhile isSpace $ label)
+
+makeProperty :: String -> Doc RdrName
+makeProperty s = case strip s of
+ 'p':'r':'o':'p':'>':xs ->
+ DocProperty (dropWhile isSpace xs)
+ xs ->
+ error $ "makeProperty: invalid input " ++ show xs
+
-- | Create an 'Example', stripping superfluous characters as appropriate
makeExample :: String -> String -> [String] -> Example
makeExample prompt expression result =
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 8ea5b930..181ea026 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -1,5 +1,5 @@
-{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Types
@@ -22,6 +22,7 @@ module Haddock.Types (
import Control.Exception
import Control.Arrow
+import Control.DeepSeq
import Data.Typeable
import Data.Map (Map)
import Data.Maybe
@@ -113,8 +114,13 @@ data Interface = Interface
-- | The number of haddockable and haddocked items in the module, as a
-- tuple. Haddockable items are the exports and the module itself.
, ifaceHaddockCoverage :: !(Int, Int)
+
+ -- | Warnings for things defined in this module.
+ , ifaceWarningMap :: !WarningMap
}
+type WarningMap = DocMap Name
+
-- | A subset of the fields of 'Interface' that we store in the interface
-- files.
@@ -303,9 +309,10 @@ data Doc id
| DocOrderedList [Doc id]
| DocDefList [(Doc id, Doc id)]
| DocCodeBlock (Doc id)
- | DocURL String
+ | DocHyperlink Hyperlink
| DocPic String
| DocAName String
+ | DocProperty String
| DocExamples [Example]
deriving (Functor)
@@ -315,12 +322,54 @@ instance Monoid (Doc id) where
mappend = DocAppend
+instance NFData a => NFData (Doc a) where
+ rnf doc = case doc of
+ DocEmpty -> ()
+ DocAppend a b -> a `deepseq` b `deepseq` ()
+ DocString a -> a `deepseq` ()
+ DocParagraph a -> a `deepseq` ()
+ DocIdentifier a -> a `deepseq` ()
+ DocIdentifierUnchecked a -> a `deepseq` ()
+ DocModule a -> a `deepseq` ()
+ DocWarning a -> a `deepseq` ()
+ DocEmphasis a -> a `deepseq` ()
+ DocMonospaced a -> a `deepseq` ()
+ DocUnorderedList a -> a `deepseq` ()
+ DocOrderedList a -> a `deepseq` ()
+ DocDefList a -> a `deepseq` ()
+ DocCodeBlock a -> a `deepseq` ()
+ DocHyperlink a -> a `deepseq` ()
+ DocPic a -> a `deepseq` ()
+ DocAName a -> a `deepseq` ()
+ DocProperty a -> a `deepseq` ()
+ DocExamples a -> a `deepseq` ()
+
+
+instance NFData Name
+instance NFData OccName
+instance NFData ModuleName
+
+
+data Hyperlink = Hyperlink
+ { hyperlinkUrl :: String
+ , hyperlinkLabel :: Maybe String
+ } deriving (Eq, Show)
+
+
+instance NFData Hyperlink where
+ rnf (Hyperlink a b) = a `deepseq` b `deepseq` ()
+
+
data Example = Example
{ exampleExpression :: String
, exampleResult :: [String]
} deriving (Eq, Show)
+instance NFData Example where
+ rnf (Example a b) = a `deepseq` b `deepseq` ()
+
+
exampleToString :: Example -> String
exampleToString (Example expression result) =
">>> " ++ expression ++ "\n" ++ unlines result
@@ -341,9 +390,10 @@ data DocMarkup id a = Markup
, markupOrderedList :: [a] -> a
, markupDefList :: [(a,a)] -> a
, markupCodeBlock :: a -> a
- , markupURL :: String -> a
+ , markupHyperlink :: Hyperlink -> a
, markupAName :: String -> a
, markupPic :: String -> a
+ , markupProperty :: String -> a
, markupExample :: [Example] -> a
}
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 20f45c95..e0b86350 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Utils
@@ -426,9 +427,10 @@ markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)
markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
-markup m (DocURL url) = markupURL m url
+markup m (DocHyperlink l) = markupHyperlink m l
markup m (DocAName ref) = markupAName m ref
markup m (DocPic img) = markupPic m img
+markup m (DocProperty p) = markupProperty m p
markup m (DocExamples e) = markupExample m e
@@ -453,9 +455,10 @@ idMarkup = Markup {
markupOrderedList = DocOrderedList,
markupDefList = DocDefList,
markupCodeBlock = DocCodeBlock,
- markupURL = DocURL,
+ markupHyperlink = DocHyperlink,
markupAName = DocAName,
markupPic = DocPic,
+ markupProperty = DocProperty,
markupExample = DocExamples
}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 06:55:36 +0000