From b19a4bea999c684e092e0ea0feaf02ff8747d2a5 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 4 Apr 2012 16:32:11 +0200 Subject: Add an optional label to URLs --- src/Haddock/Backends/Hoogle.hs | 2 +- src/Haddock/Backends/LaTeX.hs | 6 +++++- src/Haddock/Backends/Xhtml/DocMarkup.hs | 3 ++- src/Haddock/Interface/LexParseRn.hs | 2 +- src/Haddock/Interface/Rename.hs | 2 +- src/Haddock/InterfaceFile.hs | 21 +++++++++++++++------ src/Haddock/Parse.y | 4 ++-- src/Haddock/Types.hs | 10 ++++++++-- src/Haddock/Utils.hs | 4 ++-- 9 files changed, 37 insertions(+), 17 deletions(-) (limited to 'src') diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index d27ca80f..25ca65e9 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -247,7 +247,7 @@ markupTag = 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 "", markupExample = box TagPre . str . unlines . map exampleToString } diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 31ba3b0b..ef72505c 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -1011,7 +1011,7 @@ 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, markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e } @@ -1020,6 +1020,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..e75cfaba 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,7 +47,7 @@ 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], markupExample = examplesToHtml diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index 56ed1b42..de006386 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -113,7 +113,7 @@ rename 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 DocExamples e -> DocExamples e diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index b703da0f..18e5f1d2 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -200,7 +200,7 @@ 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) DocExamples e -> return (DocExamples e) diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 970093df..ebe15325 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -66,13 +66,13 @@ binaryInterfaceMagic = 0xD0Cface -- we version our interface files accordingly. binaryInterfaceVersion :: Word16 #if __GLASGOW_HASKELL__ == 702 -binaryInterfaceVersion = 20 +binaryInterfaceVersion = 21 #elif __GLASGOW_HASKELL__ == 703 -binaryInterfaceVersion = 20 +binaryInterfaceVersion = 21 #elif __GLASGOW_HASKELL__ == 704 -binaryInterfaceVersion = 20 +binaryInterfaceVersion = 21 #elif __GLASGOW_HASKELL__ == 705 -binaryInterfaceVersion = 20 +binaryInterfaceVersion = 21 #else #error Unknown GHC version #endif @@ -413,6 +413,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 @@ -452,7 +461,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 @@ -511,7 +520,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) diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y index e36e8416..0cc783ee 100644 --- a/src/Haddock/Parse.y +++ b/src/Haddock/Parse.y @@ -10,7 +10,7 @@ module Haddock.Parse where import Haddock.Lex -import Haddock.Types (Doc(..), Example(Example)) +import Haddock.Types (Doc(..), Example(Example), Hyperlink(..)) import Haddock.Doc import HsSyn import RdrName @@ -107,7 +107,7 @@ seq1 :: { Doc RdrName } elem1 :: { Doc RdrName } : STRING { DocString $1 } | '/../' { DocEmphasis (DocString $1) } - | URL { DocURL $1 } + | URL { DocHyperlink (Hyperlink $1 Nothing) } | PIC { DocPic $1 } | ANAME { DocAName $1 } | IDENT { DocIdentifier $1 } diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 048a7ff7..f8890ebf 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -303,7 +303,7 @@ data Doc id | DocOrderedList [Doc id] | DocDefList [(Doc id, Doc id)] | DocCodeBlock (Doc id) - | DocURL String + | DocHyperlink Hyperlink | DocPic String | DocAName String | DocExamples [Example] @@ -315,6 +315,12 @@ instance Monoid (Doc id) where mappend = DocAppend +data Hyperlink = Hyperlink + { hyperlinkUrl :: String + , hyperlinkLabel :: Maybe String + } + + data Example = Example { exampleExpression :: String , exampleResult :: [String] @@ -341,7 +347,7 @@ 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 , markupExample :: [Example] -> a diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 3a2f1d28..ad61e88a 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -416,7 +416,7 @@ 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 (DocExamples e) = markupExample m e @@ -443,7 +443,7 @@ idMarkup = Markup { markupOrderedList = DocOrderedList, markupDefList = DocDefList, markupCodeBlock = DocCodeBlock, - markupURL = DocURL, + markupHyperlink = DocHyperlink, markupAName = DocAName, markupPic = DocPic, markupExample = DocExamples -- cgit v1.2.3 From b8dcf173c272ebf85bbf2b427f84522e1474d092 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 11 Apr 2012 07:54:33 +0200 Subject: Add support for hyperlink labels to parser --- src/Haddock/Parse.y | 11 ++++++++++- src/Haddock/Types.hs | 2 +- tests/unit-tests/parsetests.hs | 14 ++++++++++++++ 3 files changed, 25 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y index 0cc783ee..b34b14b9 100644 --- a/src/Haddock/Parse.y +++ b/src/Haddock/Parse.y @@ -107,7 +107,7 @@ seq1 :: { Doc RdrName } elem1 :: { Doc RdrName } : STRING { DocString $1 } | '/../' { DocEmphasis (DocString $1) } - | URL { DocHyperlink (Hyperlink $1 Nothing) } + | URL { DocHyperlink (makeHyperlink $1) } | PIC { DocPic $1 } | ANAME { DocAName $1 } | IDENT { DocIdentifier $1 } @@ -121,6 +121,15 @@ 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) + -- | 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 f8890ebf..0d486ae8 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -318,7 +318,7 @@ instance Monoid (Doc id) where data Hyperlink = Hyperlink { hyperlinkUrl :: String , hyperlinkLabel :: Maybe String - } + } deriving (Eq, Show) data Example = Example diff --git a/tests/unit-tests/parsetests.hs b/tests/unit-tests/parsetests.hs index 7180a79e..0192ebfc 100644 --- a/tests/unit-tests/parsetests.hs +++ b/tests/unit-tests/parsetests.hs @@ -9,6 +9,7 @@ import Haddock.Lex (tokenise) import Haddock.Parse (parseParas) import Haddock.Types import Outputable +import Data.Monoid instance Outputable a => Show a where show = showSDoc . ppr @@ -53,8 +54,21 @@ tests = [ input = ">>> putFooBar\nfoo\n\nbar" , result = Just $ DocExamples $ [Example "putFooBar" ["foo","","bar"]] } + + -- tests for links + , ParseTest { + input = "" + , result = Just . DocParagraph $ hyperlink "http://example.com/" Nothing `mappend` DocString "\n" + } + + , ParseTest { + input = "" + , result = Just . DocParagraph $ hyperlink "http://example.com/" (Just "some link") `mappend` DocString "\n" + } ] +hyperlink :: String -> Maybe String -> Doc RdrName +hyperlink url = DocHyperlink . Hyperlink url main :: IO () main = do -- cgit v1.2.3 From 1483f369caaacc25e07f9715b15e49c35205b417 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 16 May 2012 13:37:02 +0200 Subject: Use LANGUAGE pragmas instead of default-extensions in cabal file --- haddock.cabal | 4 ---- src/.ghci | 2 +- src/Haddock/Interface/AttachInstances.hs | 2 +- src/Haddock/InterfaceFile.hs | 2 +- src/Haddock/Utils.hs | 1 + src/Main.hs | 2 +- tests/unit-tests/.ghci | 2 +- 7 files changed, 6 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/haddock.cabal b/haddock.cabal index 9d6f1a9b..609df296 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -104,8 +104,6 @@ executable haddock main-is: Main.hs hs-source-dirs: src - default-extensions: CPP, DeriveDataTypeable, - ScopedTypeVariables, MagicHash ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs other-modules: @@ -165,8 +163,6 @@ library build-depends: QuickCheck >= 2.1 && < 3 hs-source-dirs: src - default-extensions: CPP, DeriveDataTypeable, - ScopedTypeVariables, MagicHash ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs exposed-modules: diff --git a/src/.ghci b/src/.ghci index f00e6d55..3e83f04c 100644 --- a/src/.ghci +++ b/src/.ghci @@ -1 +1 @@ -: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 +:set -i../dist/build/autogen -i../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../dist/build/autogen/cabal_macros.h diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index c012f2e0..d9f4350f 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 diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index ebe15325..7abb0583 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 #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index ad61e88a..ef1b0469 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Utils diff --git a/src/Main.hs b/src/Main.hs index 8c15661d..52406821 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Main diff --git a/tests/unit-tests/.ghci b/tests/unit-tests/.ghci index 10563664..dcc5b13d 100644 --- a/tests/unit-tests/.ghci +++ b/tests/unit-tests/.ghci @@ -1 +1 @@ -:set -i../../src -i../../dist/build/autogen -i../../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../../dist/build/autogen/cabal_macros.h -XCPP -XDeriveDataTypeable -XScopedTypeVariables -XMagicHash +:set -i../../src -i../../dist/build/autogen -i../../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../../dist/build/autogen/cabal_macros.h -- cgit v1.2.3 From 8344dcced9607de9f969ed2e226346e5ba57df03 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 16 May 2012 14:13:15 +0200 Subject: Fix typo in comment --- src/Haddock/Interface/Create.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 50f468db..6fa6c598 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -764,7 +764,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 -- cgit v1.2.3 From 0730c1b4088fd5d2c36671b0adf3c9e11222e233 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 16 May 2012 14:13:37 +0200 Subject: Add a type signature for a where-binding --- src/Haddock/Interface/Create.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'src') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 6fa6c598..32d187a5 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -690,6 +690,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 -- cgit v1.2.3 From 83a2a6ab67b25eec42c50b99b0b594313b8abe44 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 11 Jul 2012 17:15:05 +0100 Subject: Update dependencies. --- haddock.cabal | 4 ++-- src/Haddock/InterfaceFile.hs | 2 ++ 2 files changed, 4 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/haddock.cabal b/haddock.cabal index 1b7eb513..e133e51e 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -91,7 +91,7 @@ executable haddock array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, - ghc >= 7.4 && < 7.6 + ghc >= 7.4 && < 7.8 if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE @@ -153,7 +153,7 @@ library array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, - ghc >= 7.4 && < 7.6 + ghc >= 7.4 && < 7.8 if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 970093df..c2f1eb5c 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -73,6 +73,8 @@ binaryInterfaceVersion = 20 binaryInterfaceVersion = 20 #elif __GLASGOW_HASKELL__ == 705 binaryInterfaceVersion = 20 +#elif __GLASGOW_HASKELL__ == 706 +binaryInterfaceVersion = 20 #else #error Unknown GHC version #endif -- cgit v1.2.3 From 2cbeae0385bddcd294a5b80a4e2c86b66ff3e1cc Mon Sep 17 00:00:00 2001 From: Roman Cheplyaka Date: Wed, 13 Jun 2012 14:31:22 +0300 Subject: Hide "internal" instances This fixes #37 (http://trac.haskell.org/haddock/ticket/37) Precisely, we show an instance iff its class and all the types are exported by non-hidden modules. --- src/Haddock/Interface.hs | 7 +++- src/Haddock/Interface/AttachInstances.hs | 55 ++++++++++++++++++++++++++++---- 2 files changed, 55 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs index 09f01883..0003cba2 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 @@ -71,8 +72,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 c012f2e0..089f31b4 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -20,6 +20,7 @@ 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 @@ -36,21 +37,24 @@ 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 (unLoc (tcdLName d)) @@ -59,7 +63,8 @@ attachToExportItem iface ifaceMap instIfaceMap export = expItemInstances = case mb_info of Just (_, _, instances) -> - let insts = map (first synifyInstHead) $ sortImage (first instHead) + 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 ] @@ -140,3 +145,41 @@ 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 -- cgit v1.2.3 From ed9ff6c9ba93f0759d276715fd1162edc4d21ad7 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Mon, 13 Aug 2012 22:12:27 +0100 Subject: Improve haddock memory usage --- haddock.cabal | 1 + src/Haddock/Interface/Create.hs | 55 +++++++++++++++++----------- src/Haddock/Interface/LexParseRn.hs | 5 ++- src/Haddock/Interface/ParseModuleHeader.hs | 1 + src/Haddock/Types.hs | 58 +++++++++++++++--------------- 5 files changed, 69 insertions(+), 51 deletions(-) (limited to 'src') diff --git a/haddock.cabal b/haddock.cabal index 5c950f98..116ee00c 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -88,6 +88,7 @@ executable haddock directory, pretty, containers, + deepseq, array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 64995a5f..32f287f5 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections, BangPatterns #-} +{-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Create @@ -27,6 +28,7 @@ import Data.Maybe import Data.Monoid import Data.Ord import Control.Applicative +import Control.DeepSeq import Control.Monad import qualified Data.Traversable as T @@ -48,13 +50,13 @@ import FastString (unpackFS) createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface createInterface tm flags modMap instIfaceMap = do - let ms = pm_mod_summary . tm_parsed_module $ tm - mi = moduleInfo tm - safety = modInfoSafe mi - mdl = ms_mod ms - dflags = ms_hspp_opts ms - instances = modInfoInstances mi - exportedNames = modInfoExports mi + let ms = pm_mod_summary . tm_parsed_module $ tm + mi = moduleInfo tm + !safety = modInfoSafe mi + mdl = ms_mod ms + dflags = ms_hspp_opts ms + !instances = modInfoInstances mi + !exportedNames = modInfoExports mi (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, _) = tm_internals_ tm @@ -72,13 +74,13 @@ createInterface tm flags modMap instIfaceMap = do | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 - (info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader + (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom mdl . getName) instances - maps@(docMap, argMap, subMap, declMap) <- + maps@(!docMap, !argMap, !subMap, !declMap) <- liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs let exports0 = fmap (reverse . map unLoc) mayExports @@ -92,24 +94,25 @@ createInterface tm flags modMap instIfaceMap = do exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports instances instIfaceMap dflags - let visibleNames = mkVisibleNames exportItems opts + let !visibleNames = mkVisibleNames exportItems opts -- Measure haddock documentation coverage. let prunedExportItems0 = pruneExportItems exportItems - haddockable = 1 + length exportItems -- module + exports - haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 - coverage = (haddockable, haddocked) + !haddockable = 1 + length exportItems -- module + exports + !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 + !coverage = (haddockable, haddocked) -- Prune the export list to just those declarations that have -- documentation, if the 'prune' option is on. - let prunedExportItems + let prunedExportItems' | OptPrune `elem` opts = prunedExportItems0 | otherwise = exportItems + !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' - let aliases = + let !aliases = mkAliasMap dflags $ tm_renamed_source tm - return Interface { + return $! Interface { ifaceMod = mdl, ifaceOrigFilename = msHsFilePath ms, ifaceInfo = info, @@ -179,7 +182,7 @@ moduleWarning ws = case ws of NoWarnings -> Nothing WarnSome _ -> Nothing - WarnAll w -> Just (warnToDoc w) + WarnAll w -> Just $! warnToDoc w warnToDoc :: WarningTxt -> Doc id @@ -187,7 +190,8 @@ warnToDoc w = case w of (DeprecatedTxt msg) -> format "Deprecated: " msg (WarningTxt msg) -> format "Warning: " msg where - format x xs = DocWarning . DocParagraph . DocString . concat $ x : map unpackFS xs + format x xs = let !str = force $ concat (x : map unpackFS xs) + in DocWarning $ DocParagraph $ DocString str ------------------------------------------------------------------------------- @@ -254,7 +258,12 @@ mkMaps dflags gre instances decls = do am = [ (n, args) | n <- ns ] ++ zip subNs subArgs sm = [ (n, subNs) | n <- ns ] cm = [ (n, [ldecl]) | n <- ns ++ subNs ] - return (dm, am, sm, cm) + seqList ns `seq` + seqList subNs `seq` + doc `seq` + seqList subDocs `seq` + seqList subArgs `seq` + return (dm, am, sm, cm) instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] @@ -774,7 +783,8 @@ pruneExportItems = filter hasDoc mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name] mkVisibleNames exports opts | OptHide `elem` opts = [] - | otherwise = concatMap exportName exports + | otherwise = let ns = concatMap exportName exports + in seqList ns `seq` ns where exportName e@ExportDecl {} = getMainDeclBinder (unL $ expItemDecl e) ++ subs where subs = map fst (expItemSubDocs e) @@ -782,6 +792,9 @@ mkVisibleNames exports opts -- we don't want links to go to them. exportName _ = [] +seqList :: [a] -> () +seqList [] = () +seqList (x : xs) = x `seq` seqList xs -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index a5eb1143..3ad9719e 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.LexParseRn @@ -78,7 +80,8 @@ processModuleHeader dflags gre safety mayStr = do tell ["haddock module header parse failed: " ++ msg] return failure Right (hmi, doc) -> do - let hmi' = hmi { hmi_description = rename dflags gre <$> hmi_description hmi } + let !descr = rename dflags gre <$> hmi_description hmi + hmi' = hmi { hmi_description = descr } doc' = rename dflags gre doc return (hmi', Just doc') return (hmi { hmi_safety = Just $ showPpr dflags safety }, doc) 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/Types.hs b/src/Haddock/Types.hs index e1e7ce4b..fbd05fae 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -59,10 +59,10 @@ type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources data Interface = Interface { -- | The module behind this interface. - ifaceMod :: Module + ifaceMod :: !Module -- | Original file name of the module. - , ifaceOrigFilename :: FilePath + , ifaceOrigFilename :: !FilePath -- | Textual information about the module. , ifaceInfo :: !(HaddockModInfo Name) @@ -71,7 +71,7 @@ data Interface = Interface , ifaceDoc :: !(Documentation Name) -- | Documentation header with cross-reference information. - , ifaceRnDoc :: Documentation DocName + , ifaceRnDoc :: !(Documentation DocName) -- | Haddock options for this module (prune, ignore-exports, etc). , ifaceOptions :: ![DocOption] @@ -79,22 +79,22 @@ data Interface = Interface -- | Declarations originating from the module. Excludes declarations without -- names (instances and stand-alone documentation comments). Includes -- names of subordinate declarations mapped to their parent declarations. - , ifaceDeclMap :: Map Name [LHsDecl Name] + , ifaceDeclMap :: !(Map Name [LHsDecl Name]) -- | Documentation of declarations originating from the module (including -- subordinates). - , ifaceDocMap :: DocMap Name - , ifaceArgMap :: ArgMap Name + , ifaceDocMap :: !(DocMap Name) + , ifaceArgMap :: !(ArgMap Name) -- | Documentation of declarations originating from the module (including -- subordinates). - , ifaceRnDocMap :: DocMap DocName - , ifaceRnArgMap :: ArgMap DocName + , ifaceRnDocMap :: !(DocMap DocName) + , ifaceRnArgMap :: !(ArgMap DocName) - , ifaceSubMap :: Map Name [Name] + , ifaceSubMap :: !(Map Name [Name]) , ifaceExportItems :: ![ExportItem Name] - , ifaceRnExportItems :: [ExportItem DocName] + , ifaceRnExportItems :: ![ExportItem DocName] -- | All names exported by the module. , ifaceExports :: ![Name] @@ -105,14 +105,14 @@ data Interface = Interface , ifaceVisibleExports :: ![Name] -- | Aliases of module imports as in @import A.B.C as C@. - , ifaceModuleAliases :: AliasMap + , ifaceModuleAliases :: !AliasMap -- | Instances exported by the module. , ifaceInstances :: ![ClsInst] -- | 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) + , ifaceHaddockCoverage :: !(Int, Int) } @@ -172,51 +172,51 @@ data ExportItem name = ExportDecl { -- | A declaration. - expItemDecl :: LHsDecl name + expItemDecl :: !(LHsDecl name) -- | Maybe a doc comment, and possibly docs for arguments (if this -- decl is a function or type-synonym). - , expItemMbDoc :: DocForDecl name + , expItemMbDoc :: !(DocForDecl name) -- | Subordinate names, possibly with documentation. - , expItemSubDocs :: [(name, DocForDecl name)] + , expItemSubDocs :: ![(name, DocForDecl name)] -- | Instances relevant to this declaration, possibly with -- documentation. - , expItemInstances :: [DocInstance name] + , expItemInstances :: ![DocInstance name] } -- | An exported entity for which we have no documentation (perhaps because it -- resides in another package). | ExportNoDecl - { expItemName :: name + { expItemName :: !name -- | Subordinate names. - , expItemSubs :: [name] + , expItemSubs :: ![name] } -- | A section heading. | ExportGroup { -- | Section level (1, 2, 3, ...). - expItemSectionLevel :: Int + expItemSectionLevel :: !Int -- | Section id (for hyperlinks). - , expItemSectionId :: String + , expItemSectionId :: !String -- | Section heading text. - , expItemSectionText :: Doc name + , expItemSectionText :: !(Doc name) } -- | Some documentation. - | ExportDoc (Doc name) + | ExportDoc !(Doc name) -- | A cross-reference to another module. - | ExportModule Module + | ExportModule !Module data Documentation name = Documentation { documentationDoc :: Maybe (Doc name) - , documentationWarning :: Maybe (Doc name) + , documentationWarning :: !(Maybe (Doc name)) } deriving Functor @@ -355,11 +355,11 @@ data DocMarkup id a = Markup data HaddockModInfo name = HaddockModInfo - { hmi_description :: Maybe (Doc name) - , hmi_portability :: Maybe String - , hmi_stability :: Maybe String - , hmi_maintainer :: Maybe String - , hmi_safety :: Maybe String + { hmi_description :: (Maybe (Doc name)) + , hmi_portability :: (Maybe String) + , hmi_stability :: (Maybe String) + , hmi_maintainer :: (Maybe String) + , hmi_safety :: (Maybe String) } -- cgit v1.2.3 From 16cdfa33ce7a043465a653d87e04c746ab10a797 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 25 Aug 2012 13:50:52 +0200 Subject: Move .ghci to project root --- .ghci | 1 + src/.ghci | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) create mode 100644 .ghci delete mode 100644 src/.ghci (limited to 'src') diff --git a/.ghci b/.ghci new file mode 100644 index 00000000..ff2b6637 --- /dev/null +++ b/.ghci @@ -0,0 +1 @@ +:set -isrc -idist/build/autogen -idist/build/haddock/haddock-tmp/ -packageghc -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/src/.ghci b/src/.ghci deleted file mode 100644 index 3e83f04c..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 -- cgit v1.2.3 From 42422b76fd65dfd37ada0d4da5a85fdf30bf0fa2 Mon Sep 17 00:00:00 2001 From: David Waern Date: Fri, 7 Sep 2012 14:29:27 +0200 Subject: Follow changes in GHC. --- src/Haddock/Interface/AttachInstances.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'src') diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index 8fff4d7a..ebe62cb6 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -186,3 +186,4 @@ isInstanceHidden expInfo cls tys = TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args FunTy t1 t2 -> typeHidden t1 || typeHidden t2 ForAllTy _ ty -> typeHidden ty + LitTy _ -> False -- cgit v1.2.3 From d40f783dae503a194c036f5c8272563fcca187a4 Mon Sep 17 00:00:00 2001 From: David Waern Date: Fri, 28 Sep 2012 10:21:32 +0200 Subject: Make API buildable with GHC 7.6. --- src/Documentation/Haddock.hs | 2 +- src/Main.hs | 24 ++++++++++++++---------- 2 files changed, 15 insertions(+), 11 deletions(-) (limited to 'src') diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs index 60bb3147..cbdc4d61 100644 --- a/src/Documentation/Haddock.hs +++ b/src/Documentation/Haddock.hs @@ -70,6 +70,6 @@ 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/Main.hs index 31e2726c..abeda77f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -15,7 +15,7 @@ -- -- Program entry point and top-level code. ----------------------------------------------------------------------------- -module Main (main, readPackagesAndProcessModules) where +module Main (main, readPackagesAndProcessModules, withGhc') where import Haddock.Backends.Xhtml @@ -135,15 +135,7 @@ main = handleTopExceptions $ do 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 @@ -169,6 +161,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 -- cgit v1.2.3 From 6ccf78e15a525282fef61bc4f58a279aa9c21771 Mon Sep 17 00:00:00 2001 From: David Waern Date: Fri, 28 Sep 2012 19:50:20 +0200 Subject: Fix spurious superclass constraints bug. --- src/Haddock/Interface/AttachInstances.hs | 31 +++++++++++++++++++++++-------- 1 file changed, 23 insertions(+), 8 deletions(-) (limited to 'src') diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index ebe62cb6..4b5f159d 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -22,19 +22,20 @@ 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 @@ -65,7 +66,7 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = Just (_, _, instances) -> let insts = map (first synifyInstHead) $ sortImage (first instHead) $ filter (\((_,_,cls,tys),_) -> not $ isInstanceHidden expInfo cls tys) - [ (instanceHead i, getName i) | i <- instances ] + [ (instanceHead' i, getName i) | i <- instances ] in [ (inst, lookupInstDoc name iface ifaceMap instIfaceMap) | (inst, name) <- insts ] Nothing -> [] @@ -94,6 +95,20 @@ lookupInstDoc name iface ifaceMap instIfaceMap = modName = nameModule name +-- | Like GHC's 'instanceHead' but drops "silent" arguments. +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])) -- cgit v1.2.3 From ae3690c2349b595a1fb459a4374cfe2e668a04aa Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 2 Oct 2012 00:47:46 +0200 Subject: Export Haddock's main entry point from library --- driver/Main.hs | 7 + haddock.cabal | 6 +- src/Documentation/Haddock.hs | 7 +- src/Haddock.hs | 461 +++++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 458 ------------------------------------------ 5 files changed, 476 insertions(+), 463 deletions(-) create mode 100644 driver/Main.hs create mode 100644 src/Haddock.hs delete mode 100644 src/Main.hs (limited to 'src') diff --git a/driver/Main.hs b/driver/Main.hs new file mode 100644 index 00000000..42b99860 --- /dev/null +++ b/driver/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Documentation.Haddock (haddock) +import System.Environment (getArgs) + +main :: IO () +main = getArgs >>= haddock diff --git a/haddock.cabal b/haddock.cabal index 91c2e494..42dc9771 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -95,10 +95,12 @@ executable haddock build-depends: ghc-paths main-is: Main.hs - hs-source-dirs: src + hs-source-dirs: src, driver ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs other-modules: + Documentation.Haddock + Haddock Haddock.Interface Haddock.Interface.Rename Haddock.Interface.Create @@ -157,7 +159,7 @@ library Documentation.Haddock other-modules: - Main + Haddock Haddock.Interface Haddock.Interface.Rename Haddock.Interface.Create diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs index cbdc4d61..855cdc79 100644 --- a/src/Documentation/Haddock.hs +++ b/src/Documentation/Haddock.hs @@ -48,8 +48,10 @@ module Documentation.Haddock ( -- * Flags and options Flag(..), - DocOption(..) + DocOption(..), + -- * Program entry point + haddock, ) where @@ -58,7 +60,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 @@ -72,4 +74,3 @@ createInterfaces createInterfaces flags modules = do (_, ifaces, _) <- withGhc' flags (readPackagesAndProcessModules flags modules) return ifaces - diff --git a/src/Haddock.hs b/src/Haddock.hs new file mode 100644 index 00000000..f53e01a9 --- /dev/null +++ b/src/Haddock.hs @@ -0,0 +1,461 @@ +{-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Haddock - A Haskell Documentation Tool +-- +-- Program entry point and top-level code. +----------------------------------------------------------------------------- +module Haddock (haddock, readPackagesAndProcessModules, withGhc') where + + +import Haddock.Backends.Xhtml +import Haddock.Backends.Xhtml.Themes (getThemes) +import Haddock.Backends.LaTeX +import Haddock.Backends.Hoogle +import Haddock.Interface +import Haddock.Lex +import Haddock.Parse +import Haddock.Types +import Haddock.Version +import Haddock.InterfaceFile +import Haddock.Options +import Haddock.Utils +import Haddock.GhcUtils hiding (pretty) + +import Control.Monad +import Control.Exception +import Data.Maybe +import Data.IORef +import qualified Data.Map as Map +import System.IO +import System.Exit + +#if defined(mingw32_HOST_OS) +import Foreign +import Foreign.C +import Data.Int +#endif + +#ifdef IN_GHC_TREE +import System.FilePath +#else +import qualified GHC.Paths as GhcPaths +import Paths_haddock +#endif + +import GHC hiding (flags, verbosity) +import Config +import DynFlags hiding (flags, verbosity) +import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) +import Panic (panic, handleGhcException) +import Module + +import Control.Monad.Fix (MonadFix) + + +-------------------------------------------------------------------------------- +-- * Exception handling +-------------------------------------------------------------------------------- + + +handleTopExceptions :: IO a -> IO a +handleTopExceptions = + handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions + + +-- | Either returns normally or throws an ExitCode exception; +-- all other exceptions are turned into exit exceptions. +handleNormalExceptions :: IO a -> IO a +handleNormalExceptions inner = + (inner `onException` hFlush stdout) + `catches` + [ Handler (\(code :: ExitCode) -> exitWith code) + + , Handler (\(ex :: AsyncException) -> + case ex of + StackOverflow -> do + putStrLn "stack overflow: use -g +RTS -K to increase it" + exitFailure + _ -> do + putStrLn ("haddock: " ++ show ex) + exitFailure) + + , Handler (\(ex :: SomeException) -> do + putStrLn ("haddock: internal error: " ++ show ex) + exitFailure) + ] + + +handleHaddockExceptions :: IO a -> IO a +handleHaddockExceptions inner = + catches inner [Handler handler] + where + handler (e::HaddockException) = do + putStrLn $ "haddock: " ++ show e + exitFailure + + +handleGhcExceptions :: IO a -> IO a +handleGhcExceptions = + -- error messages propagated as exceptions + handleGhcException $ \e -> do + hFlush stdout + case e of + PhaseFailed _ code -> exitWith code + _ -> do + print (e :: GhcException) + exitFailure + + +------------------------------------------------------------------------------- +-- * Top level +------------------------------------------------------------------------------- + + +-- | 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. + (flags, files) <- parseHaddockOpts args + shortcutFlags flags + qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q} + + withGhc' flags $ do + + dflags <- getDynFlags + + if not (null files) then 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 () + + -- Render the interfaces. + liftIO $ renderStep dflags flags qual packages ifaces + + else do + when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ + throwE "No input file(s)." + + -- Get packages supplied with --read-interface. + packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) + + -- Render even though there are no input files (usually contents/index). + 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 + -- Get packages supplied with --read-interface. + packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) + + -- Create the interfaces -- this is the core part of Haddock. + let ifaceFiles = map snd packages + (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles + + return (packages, ifaces, homeLinks) + + +renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () +renderStep dflags flags qual pkgs interfaces = do + updateHTMLXRefs pkgs + let + ifaceFiles = map snd pkgs + installedIfaces = concatMap ifInstalledIfaces ifaceFiles + srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ] + render dflags flags qual interfaces installedIfaces srcMap + + +-- | Render the interfaces with whatever backend is specified in the flags. +render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () +render dflags flags qual ifaces installedIfaces srcMap = do + + let + title = fromMaybe "" (optTitle flags) + unicode = Flag_UseUnicode `elem` flags + pretty = Flag_PrettyHtml `elem` flags + opt_wiki_urls = wikiUrls flags + opt_contents_url = optContentsUrl flags + opt_index_url = optIndexUrl flags + odir = outputDir flags + opt_latex_style = optLaTeXStyle flags + + visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] + + -- /All/ visible interfaces including external package modules. + allIfaces = map toInstalledIface ifaces ++ installedIfaces + allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] + + pkgMod = ifaceMod (head ifaces) + pkgId = modulePackageId pkgMod + pkgStr = Just (packageIdString pkgId) + (pkgName,pkgVer) = modulePackageInfo pkgMod + + (srcBase, srcModule, srcEntity) = sourceUrls flags + srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity + sourceUrls' = (srcBase, srcModule, srcMap') + + libDir <- getHaddockLibDir flags + prologue <- getPrologue flags + themes <- getThemes libDir flags >>= either bye return + + when (Flag_GenIndex `elem` flags) $ do + ppHtmlIndex odir title pkgStr + themes opt_contents_url sourceUrls' opt_wiki_urls + allVisibleIfaces pretty + copyHtmlBits odir libDir themes + + when (Flag_GenContents `elem` flags) $ do + ppHtmlContents odir title pkgStr + themes opt_index_url sourceUrls' opt_wiki_urls + allVisibleIfaces True prologue pretty + (makeContentsQual qual) + copyHtmlBits odir libDir themes + + when (Flag_Html `elem` flags) $ do + ppHtml title pkgStr visibleIfaces odir + prologue + themes sourceUrls' opt_wiki_urls + opt_contents_url opt_index_url unicode qual + pretty + copyHtmlBits odir libDir themes + + when (Flag_Hoogle `elem` flags) $ do + let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName + ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir + + when (Flag_LaTeX `elem` flags) $ do + ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style + libDir + + +------------------------------------------------------------------------------- +-- * Reading and dumping interface files +------------------------------------------------------------------------------- + + +readInterfaceFiles :: (MonadFix m, MonadIO m) => + NameCacheAccessor m + -> [(DocPaths, FilePath)] -> + m [(DocPaths, InterfaceFile)] +readInterfaceFiles name_cache_accessor pairs = do + mbPackages <- mapM tryReadIface pairs + return (catMaybes mbPackages) + where + -- try to read an interface, warn if we can't + tryReadIface (paths, file) = do + eIface <- readInterfaceFile name_cache_accessor file + case eIface of + Left err -> liftIO $ do + putStrLn ("Warning: Cannot read " ++ file ++ ":") + putStrLn (" " ++ err) + putStrLn "Skipping this interface." + return Nothing + 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 +------------------------------------------------------------------------------- + + +-- | 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 = saveStaticFlagGlobals >>= \savedFlags -> do + -- TODO: handle warnings? + (restFlags, _) <- parseStaticFlags (map noLoc flags) + runGhc (Just libDir) $ do + dynflags <- getSessionDynFlags + let dynflags' = dopt_set dynflags Opt_Haddock + let dynflags'' = dynflags' { + hscTarget = HscNothing, + ghcMode = CompManager, + ghcLink = NoLink + } + dynflags''' <- parseGhcFlags dynflags'' restFlags flags + defaultCleanupHandler dynflags''' $ do + -- ignore the following return-value, which is a list of packages + -- that may need to be re-linked: Haddock doesn't do any + -- dynamic or static linking at all! + _ <- setSessionDynFlags dynflags''' + ghcActs dynflags''' + `finally` restoreStaticFlagGlobals savedFlags + where + parseGhcFlags :: Monad m => DynFlags -> [Located String] + -> [String] -> m DynFlags + parseGhcFlags dynflags flags_ origFlags = do + -- TODO: handle warnings? + (dynflags', rest, _) <- parseDynamicFlags dynflags flags_ + if not (null rest) + then throwE ("Couldn't parse GHC options: " ++ unwords origFlags) + else return dynflags' + + +------------------------------------------------------------------------------- +-- * Misc +------------------------------------------------------------------------------- + + +getHaddockLibDir :: [Flag] -> IO String +getHaddockLibDir flags = + case [str | Flag_Lib str <- flags] of + [] -> +#ifdef IN_GHC_TREE + getInTreeDir +#else + getDataDir -- provided by Cabal +#endif + fs -> return (last fs) + + +getGhcDirs :: [Flag] -> IO (String, String) +getGhcDirs flags = do + case [ dir | Flag_GhcLibDir dir <- flags ] of + [] -> do +#ifdef IN_GHC_TREE + libDir <- getInTreeDir + return (ghcPath, libDir) +#else + return (ghcPath, GhcPaths.libdir) +#endif + xs -> return (ghcPath, last xs) + where +#ifdef IN_GHC_TREE + ghcPath = "not available" +#else + ghcPath = GhcPaths.ghc +#endif + + +shortcutFlags :: [Flag] -> IO () +shortcutFlags flags = do + usage <- getUsage + + when (Flag_Help `elem` flags) (bye usage) + when (Flag_Version `elem` flags) byeVersion + when (Flag_InterfaceVersion `elem` flags) (bye (show binaryInterfaceVersion ++ "\n")) + when (Flag_GhcVersion `elem` flags) (bye (cProjectVersion ++ "\n")) + + when (Flag_PrintGhcPath `elem` flags) $ do + dir <- fmap fst (getGhcDirs flags) + bye $ dir ++ "\n" + + when (Flag_PrintGhcLibDir `elem` flags) $ do + dir <- fmap snd (getGhcDirs flags) + bye $ dir ++ "\n" + + when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $ + throwE "Unicode can only be enabled for HTML output." + + when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) + && Flag_Html `elem` flags) $ + throwE "-h cannot be used with --gen-index or --gen-contents" + + when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) + && Flag_Hoogle `elem` flags) $ + throwE "--hoogle cannot be used with --gen-index or --gen-contents" + + when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) + && Flag_LaTeX `elem` flags) $ + throwE "--latex cannot be used with --gen-index or --gen-contents" + where + byeVersion = bye $ + "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n" + ++ "Ported to use the GHC API by David Waern 2006-2008\n" + + +updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO () +updateHTMLXRefs packages = do + writeIORef html_xrefs_ref (Map.fromList mapping) + writeIORef html_xrefs_ref' (Map.fromList mapping') + where + mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages + , iface <- ifInstalledIfaces ifaces ] + mapping' = [ (moduleName m, html) | (m, html) <- mapping ] + + +getPrologue :: [Flag] -> IO (Maybe (Doc RdrName)) +getPrologue flags = + case [filename | Flag_Prologue filename <- flags ] of + [] -> return Nothing + [filename] -> do + str <- readFile filename + case parseParas (tokenise (defaultDynFlags (panic "No settings")) str + (1,0) {- TODO: real position -}) of + Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename + Just doc -> return (Just doc) + _otherwise -> throwE "multiple -p/--prologue options" + + +#ifdef IN_GHC_TREE + +getInTreeDir :: IO String +getInTreeDir = do + m <- getExecDir + case m of + Nothing -> error "No GhcDir found" + Just d -> return (d ".." "lib") + + +getExecDir :: IO (Maybe String) +#if defined(mingw32_HOST_OS) +getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. + where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf + | otherwise -> try_size (size * 2) + +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 +#else +getExecDir = return Nothing +#endif + +#endif + diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 index abeda77f..00000000 --- a/src/Main.hs +++ /dev/null @@ -1,458 +0,0 @@ -{-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE CPP, ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Main --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2010 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable --- --- Haddock - A Haskell Documentation Tool --- --- Program entry point and top-level code. ------------------------------------------------------------------------------ -module Main (main, readPackagesAndProcessModules, withGhc') where - - -import Haddock.Backends.Xhtml -import Haddock.Backends.Xhtml.Themes (getThemes) -import Haddock.Backends.LaTeX -import Haddock.Backends.Hoogle -import Haddock.Interface -import Haddock.Lex -import Haddock.Parse -import Haddock.Types -import Haddock.Version -import Haddock.InterfaceFile -import Haddock.Options -import Haddock.Utils -import Haddock.GhcUtils hiding (pretty) - -import Control.Monad -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 -import Foreign.C -import Data.Int -#endif - -#ifdef IN_GHC_TREE -import System.FilePath -#else -import qualified GHC.Paths as GhcPaths -import Paths_haddock -#endif - -import GHC hiding (flags, verbosity) -import Config -import DynFlags hiding (flags, verbosity) -import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) -import Panic (panic, handleGhcException) -import Module - -import Control.Monad.Fix (MonadFix) - - --------------------------------------------------------------------------------- --- * Exception handling --------------------------------------------------------------------------------- - - -handleTopExceptions :: IO a -> IO a -handleTopExceptions = - handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions - - --- | Either returns normally or throws an ExitCode exception; --- all other exceptions are turned into exit exceptions. -handleNormalExceptions :: IO a -> IO a -handleNormalExceptions inner = - (inner `onException` hFlush stdout) - `catches` - [ Handler (\(code :: ExitCode) -> exitWith code) - - , Handler (\(ex :: AsyncException) -> - case ex of - StackOverflow -> do - putStrLn "stack overflow: use -g +RTS -K to increase it" - exitFailure - _ -> do - putStrLn ("haddock: " ++ show ex) - exitFailure) - - , Handler (\(ex :: SomeException) -> do - putStrLn ("haddock: internal error: " ++ show ex) - exitFailure) - ] - - -handleHaddockExceptions :: IO a -> IO a -handleHaddockExceptions inner = - catches inner [Handler handler] - where - handler (e::HaddockException) = do - putStrLn $ "haddock: " ++ show e - exitFailure - - -handleGhcExceptions :: IO a -> IO a -handleGhcExceptions = - -- error messages propagated as exceptions - handleGhcException $ \e -> do - hFlush stdout - case e of - PhaseFailed _ code -> exitWith code - _ -> do - print (e :: GhcException) - exitFailure - - -------------------------------------------------------------------------------- --- * Top level -------------------------------------------------------------------------------- - - -main :: IO () -main = 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} - - withGhc' flags $ do - - dflags <- getDynFlags - - if not (null files) then 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 () - - -- Render the interfaces. - liftIO $ renderStep dflags flags qual packages ifaces - - else do - when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ - throwE "No input file(s)." - - -- Get packages supplied with --read-interface. - packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) - - -- Render even though there are no input files (usually contents/index). - 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 - -- Get packages supplied with --read-interface. - packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) - - -- Create the interfaces -- this is the core part of Haddock. - let ifaceFiles = map snd packages - (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles - - return (packages, ifaces, homeLinks) - - -renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags flags qual pkgs interfaces = do - updateHTMLXRefs pkgs - let - ifaceFiles = map snd pkgs - installedIfaces = concatMap ifInstalledIfaces ifaceFiles - srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ] - render dflags flags qual interfaces installedIfaces srcMap - - --- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () -render dflags flags qual ifaces installedIfaces srcMap = do - - let - title = fromMaybe "" (optTitle flags) - unicode = Flag_UseUnicode `elem` flags - pretty = Flag_PrettyHtml `elem` flags - opt_wiki_urls = wikiUrls flags - opt_contents_url = optContentsUrl flags - opt_index_url = optIndexUrl flags - odir = outputDir flags - opt_latex_style = optLaTeXStyle flags - - visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] - - -- /All/ visible interfaces including external package modules. - allIfaces = map toInstalledIface ifaces ++ installedIfaces - allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] - - pkgMod = ifaceMod (head ifaces) - pkgId = modulePackageId pkgMod - pkgStr = Just (packageIdString pkgId) - (pkgName,pkgVer) = modulePackageInfo pkgMod - - (srcBase, srcModule, srcEntity) = sourceUrls flags - srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity - sourceUrls' = (srcBase, srcModule, srcMap') - - libDir <- getHaddockLibDir flags - prologue <- getPrologue flags - themes <- getThemes libDir flags >>= either bye return - - when (Flag_GenIndex `elem` flags) $ do - ppHtmlIndex odir title pkgStr - themes opt_contents_url sourceUrls' opt_wiki_urls - allVisibleIfaces pretty - copyHtmlBits odir libDir themes - - when (Flag_GenContents `elem` flags) $ do - ppHtmlContents odir title pkgStr - themes opt_index_url sourceUrls' opt_wiki_urls - allVisibleIfaces True prologue pretty - (makeContentsQual qual) - copyHtmlBits odir libDir themes - - when (Flag_Html `elem` flags) $ do - ppHtml title pkgStr visibleIfaces odir - prologue - themes sourceUrls' opt_wiki_urls - opt_contents_url opt_index_url unicode qual - pretty - copyHtmlBits odir libDir themes - - when (Flag_Hoogle `elem` flags) $ do - let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName - ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir - - when (Flag_LaTeX `elem` flags) $ do - ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style - libDir - - -------------------------------------------------------------------------------- --- * Reading and dumping interface files -------------------------------------------------------------------------------- - - -readInterfaceFiles :: (MonadFix m, MonadIO m) => - NameCacheAccessor m - -> [(DocPaths, FilePath)] -> - m [(DocPaths, InterfaceFile)] -readInterfaceFiles name_cache_accessor pairs = do - mbPackages <- mapM tryReadIface pairs - return (catMaybes mbPackages) - where - -- try to read an interface, warn if we can't - tryReadIface (paths, file) = do - eIface <- readInterfaceFile name_cache_accessor file - case eIface of - Left err -> liftIO $ do - putStrLn ("Warning: Cannot read " ++ file ++ ":") - putStrLn (" " ++ err) - putStrLn "Skipping this interface." - return Nothing - 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 -------------------------------------------------------------------------------- - - --- | 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 = saveStaticFlagGlobals >>= \savedFlags -> do - -- TODO: handle warnings? - (restFlags, _) <- parseStaticFlags (map noLoc flags) - runGhc (Just libDir) $ do - dynflags <- getSessionDynFlags - let dynflags' = dopt_set dynflags Opt_Haddock - let dynflags'' = dynflags' { - hscTarget = HscNothing, - ghcMode = CompManager, - ghcLink = NoLink - } - dynflags''' <- parseGhcFlags dynflags'' restFlags flags - defaultCleanupHandler dynflags''' $ do - -- ignore the following return-value, which is a list of packages - -- that may need to be re-linked: Haddock doesn't do any - -- dynamic or static linking at all! - _ <- setSessionDynFlags dynflags''' - ghcActs dynflags''' - `finally` restoreStaticFlagGlobals savedFlags - where - parseGhcFlags :: Monad m => DynFlags -> [Located String] - -> [String] -> m DynFlags - parseGhcFlags dynflags flags_ origFlags = do - -- TODO: handle warnings? - (dynflags', rest, _) <- parseDynamicFlags dynflags flags_ - if not (null rest) - then throwE ("Couldn't parse GHC options: " ++ unwords origFlags) - else return dynflags' - - -------------------------------------------------------------------------------- --- * Misc -------------------------------------------------------------------------------- - - -getHaddockLibDir :: [Flag] -> IO String -getHaddockLibDir flags = - case [str | Flag_Lib str <- flags] of - [] -> -#ifdef IN_GHC_TREE - getInTreeDir -#else - getDataDir -- provided by Cabal -#endif - fs -> return (last fs) - - -getGhcDirs :: [Flag] -> IO (String, String) -getGhcDirs flags = do - case [ dir | Flag_GhcLibDir dir <- flags ] of - [] -> do -#ifdef IN_GHC_TREE - libDir <- getInTreeDir - return (ghcPath, libDir) -#else - return (ghcPath, GhcPaths.libdir) -#endif - xs -> return (ghcPath, last xs) - where -#ifdef IN_GHC_TREE - ghcPath = "not available" -#else - ghcPath = GhcPaths.ghc -#endif - - -shortcutFlags :: [Flag] -> IO () -shortcutFlags flags = do - usage <- getUsage - - when (Flag_Help `elem` flags) (bye usage) - when (Flag_Version `elem` flags) byeVersion - when (Flag_InterfaceVersion `elem` flags) (bye (show binaryInterfaceVersion ++ "\n")) - when (Flag_GhcVersion `elem` flags) (bye (cProjectVersion ++ "\n")) - - when (Flag_PrintGhcPath `elem` flags) $ do - dir <- fmap fst (getGhcDirs flags) - bye $ dir ++ "\n" - - when (Flag_PrintGhcLibDir `elem` flags) $ do - dir <- fmap snd (getGhcDirs flags) - bye $ dir ++ "\n" - - when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $ - throwE "Unicode can only be enabled for HTML output." - - when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) - && Flag_Html `elem` flags) $ - throwE "-h cannot be used with --gen-index or --gen-contents" - - when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) - && Flag_Hoogle `elem` flags) $ - throwE "--hoogle cannot be used with --gen-index or --gen-contents" - - when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) - && Flag_LaTeX `elem` flags) $ - throwE "--latex cannot be used with --gen-index or --gen-contents" - where - byeVersion = bye $ - "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n" - ++ "Ported to use the GHC API by David Waern 2006-2008\n" - - -updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO () -updateHTMLXRefs packages = do - writeIORef html_xrefs_ref (Map.fromList mapping) - writeIORef html_xrefs_ref' (Map.fromList mapping') - where - mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages - , iface <- ifInstalledIfaces ifaces ] - mapping' = [ (moduleName m, html) | (m, html) <- mapping ] - - -getPrologue :: [Flag] -> IO (Maybe (Doc RdrName)) -getPrologue flags = - case [filename | Flag_Prologue filename <- flags ] of - [] -> return Nothing - [filename] -> do - str <- readFile filename - case parseParas (tokenise (defaultDynFlags (panic "No settings")) str - (1,0) {- TODO: real position -}) of - Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename - Just doc -> return (Just doc) - _otherwise -> throwE "multiple -p/--prologue options" - - -#ifdef IN_GHC_TREE - -getInTreeDir :: IO String -getInTreeDir = do - m <- getExecDir - case m of - Nothing -> error "No GhcDir found" - Just d -> return (d ".." "lib") - - -getExecDir :: IO (Maybe String) -#if defined(mingw32_HOST_OS) -getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. - where - try_size size = allocaArray (fromIntegral size) $ \buf -> do - ret <- c_GetModuleFileName nullPtr buf size - case ret of - 0 -> return Nothing - _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf - | otherwise -> try_size (size * 2) - -foreign import stdcall unsafe "windows.h GetModuleFileNameW" - c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 -#else -getExecDir = return Nothing -#endif - -#endif - -- cgit v1.2.3 From 72675c1bf281b81041a19014b1b7df03a0de9488 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 9 Apr 2012 15:45:57 +0900 Subject: Add markup support for properties --- src/Haddock/Backends/Hoogle.hs | 1 + src/Haddock/Backends/LaTeX.hs | 1 + src/Haddock/Backends/Xhtml/DocMarkup.hs | 1 + src/Haddock/Interface/LexParseRn.hs | 1 + src/Haddock/Interface/Rename.hs | 1 + src/Haddock/InterfaceFile.hs | 6 ++++++ src/Haddock/Lex.x | 8 ++++++++ src/Haddock/Parse.y | 6 ++++++ src/Haddock/Types.hs | 2 ++ src/Haddock/Utils.hs | 2 ++ 10 files changed, 29 insertions(+) (limited to 'src') diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 4949daa1..28d35aca 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -256,6 +256,7 @@ markupTag dflags = Markup { markupCodeBlock = box TagPre, 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 68cf715a..bf1e6ac3 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -1003,6 +1003,7 @@ parLatexMarkup ppId = Markup { markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", markupHyperlink = \l _ -> markupLink l, markupAName = \_ _ -> empty, + markupProperty = \p _ -> quote $ verb $ text p, markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e } where diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index e75cfaba..aa4ba377 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -50,6 +50,7 @@ parHtmlMarkup qual ppId = Markup { 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/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index 3ad9719e..ced12d8d 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -121,6 +121,7 @@ rename dflags gre = rn 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/Rename.hs b/src/Haddock/Interface/Rename.hs index 0f702683..55c9a5da 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -202,6 +202,7 @@ renameDoc d = case d of 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) diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 8fa8ce95..59b83c70 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -481,6 +481,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 @@ -538,6 +541,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..35e6dd8a 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\> { strtoken TokPropertyPrompt `andBegin` propertyexpr } $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr } $ws* [\*\-] { token TokBullet `andBegin` string } $ws* \[ { token TokDefStart `andBegin` def } @@ -61,6 +62,7 @@ $ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:] -- beginning of a line { $ws* \> { begin birdtrack } + $ws* prop\> { strtoken TokPropertyPrompt `andBegin` propertyexpr } $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr } $ws* \n { token TokPara `andBegin` para } -- Here, we really want to be able to say @@ -84,6 +86,10 @@ $ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:] .* \n { strtokenNL TokExampleResult `andBegin` example } + .* \n { strtokenNL TokPropertyExpression `andBegin` property } + + () { token TokPara `andBegin` para } + { $special { strtoken $ \s -> TokSpecial (head s) } \<\< [^\>]* \>\> { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) } @@ -129,6 +135,8 @@ data Token | TokEmphasis String | TokAName String | TokBirdTrack String + | TokPropertyPrompt String + | TokPropertyExpression String | TokExamplePrompt String | TokExampleExpression String | TokExampleResult String diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y index b34b14b9..c8a1a558 100644 --- a/src/Haddock/Parse.y +++ b/src/Haddock/Parse.y @@ -35,6 +35,8 @@ import Data.List (stripPrefix) '-' { (TokBullet,_) } '(n)' { (TokNumber,_) } '>..' { (TokBirdTrack $$,_) } + PPROMPT { (TokPropertyPrompt $$,_) } + PEXP { (TokPropertyExpression $$,_) } PROMPT { (TokExamplePrompt $$,_) } RESULT { (TokExampleResult $$,_) } EXP { (TokExampleExpression $$,_) } @@ -73,12 +75,16 @@ defpara :: { (Doc RdrName, Doc RdrName) } para :: { Doc RdrName } : seq { docParagraph $1 } | codepara { DocCodeBlock $1 } + | property { DocProperty $1 } | examples { DocExamples $1 } codepara :: { Doc RdrName } : '>..' codepara { docAppend (DocString $1) $2 } | '>..' { DocString $1 } +property :: { String } + : PPROMPT PEXP { strip $2 } + examples :: { [Example] } : example examples { $1 : $2 } | example { [$1] } diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index fbd05fae..05fc9747 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -306,6 +306,7 @@ data Doc id | DocHyperlink Hyperlink | DocPic String | DocAName String + | DocProperty String | DocExamples [Example] deriving (Functor) @@ -350,6 +351,7 @@ data DocMarkup id a = Markup , 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 b8f32589..4424ad73 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -432,6 +432,7 @@ markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) markup m (DocHyperlink l) = markupHyperlink m l markup m (DocAName ref) = markupAName m ref markup m (DocPic img) = markupPic m img +markup m (DocProperty p) = markupProperty m p markup m (DocExamples e) = markupExample m e @@ -459,6 +460,7 @@ idMarkup = Markup { markupHyperlink = DocHyperlink, markupAName = DocAName, markupPic = DocPic, + markupProperty = DocProperty, markupExample = DocExamples } -- cgit v1.2.3 From dfbe1c45879d8ae32845c72e5ae241fb1c6fe502 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 9 Oct 2012 12:41:25 +0200 Subject: Simplify lexing/parsing of properties In contrast to what we do for examples, we do not really need to capture the "prompt" here. --- src/Haddock/Lex.x | 10 ++-------- src/Haddock/Parse.y | 16 +++++++++++----- 2 files changed, 13 insertions(+), 13 deletions(-) (limited to 'src') diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x index 35e6dd8a..aec4c647 100644 --- a/src/Haddock/Lex.x +++ b/src/Haddock/Lex.x @@ -50,7 +50,7 @@ $ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:] <0,para> { $ws* \n ; $ws* \> { begin birdtrack } - $ws* prop\> { strtoken TokPropertyPrompt `andBegin` propertyexpr } + $ws* prop \> .* \n { strtoken TokProperty } $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr } $ws* [\*\-] { token TokBullet `andBegin` string } $ws* \[ { token TokDefStart `andBegin` def } @@ -62,7 +62,6 @@ $ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:] -- beginning of a line { $ws* \> { begin birdtrack } - $ws* prop\> { strtoken TokPropertyPrompt `andBegin` propertyexpr } $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr } $ws* \n { token TokPara `andBegin` para } -- Here, we really want to be able to say @@ -86,10 +85,6 @@ $ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:] .* \n { strtokenNL TokExampleResult `andBegin` example } - .* \n { strtokenNL TokPropertyExpression `andBegin` property } - - () { token TokPara `andBegin` para } - { $special { strtoken $ \s -> TokSpecial (head s) } \<\< [^\>]* \>\> { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) } @@ -135,8 +130,7 @@ data Token | TokEmphasis String | TokAName String | TokBirdTrack String - | TokPropertyPrompt String - | TokPropertyExpression String + | TokProperty String | TokExamplePrompt String | TokExampleExpression String | TokExampleResult String diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y index c8a1a558..0befe395 100644 --- a/src/Haddock/Parse.y +++ b/src/Haddock/Parse.y @@ -35,8 +35,7 @@ import Data.List (stripPrefix) '-' { (TokBullet,_) } '(n)' { (TokNumber,_) } '>..' { (TokBirdTrack $$,_) } - PPROMPT { (TokPropertyPrompt $$,_) } - PEXP { (TokPropertyExpression $$,_) } + PROP { (TokProperty $$,_) } PROMPT { (TokExamplePrompt $$,_) } RESULT { (TokExampleResult $$,_) } EXP { (TokExampleExpression $$,_) } @@ -75,15 +74,15 @@ defpara :: { (Doc RdrName, Doc RdrName) } para :: { Doc RdrName } : seq { docParagraph $1 } | codepara { DocCodeBlock $1 } - | property { DocProperty $1 } + | property { $1 } | examples { DocExamples $1 } codepara :: { Doc RdrName } : '>..' codepara { docAppend (DocString $1) $2 } | '>..' { DocString $1 } -property :: { String } - : PPROMPT PEXP { strip $2 } +property :: { Doc RdrName } + : PROP { makeProperty $1 } examples :: { [Example] } : example examples { $1 : $2 } @@ -136,6 +135,13 @@ 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 = -- cgit v1.2.3 From d9c5e0eea99dccf85bfa6f29b70b64ddd916d86c Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 9 Oct 2012 12:50:39 +0200 Subject: Bump interface version --- src/Haddock/InterfaceFile.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 59b83c70..78ab892b 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -66,15 +66,15 @@ binaryInterfaceMagic = 0xD0Cface -- we version our interface files accordingly. binaryInterfaceVersion :: Word16 #if __GLASGOW_HASKELL__ == 702 -binaryInterfaceVersion = 21 +binaryInterfaceVersion = 22 #elif __GLASGOW_HASKELL__ == 703 -binaryInterfaceVersion = 21 +binaryInterfaceVersion = 22 #elif __GLASGOW_HASKELL__ == 704 -binaryInterfaceVersion = 21 +binaryInterfaceVersion = 22 #elif __GLASGOW_HASKELL__ == 705 -binaryInterfaceVersion = 21 +binaryInterfaceVersion = 22 #elif __GLASGOW_HASKELL__ == 706 -binaryInterfaceVersion = 21 +binaryInterfaceVersion = 22 #else #error Unknown GHC version #endif -- cgit v1.2.3 From 9d46da45a53678469d5fe4ef33f37bba45294633 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 9 Oct 2012 15:15:04 +0200 Subject: Fix parser bug --- src/Haddock/Lex.x | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x index aec4c647..0d8dd954 100644 --- a/src/Haddock/Lex.x +++ b/src/Haddock/Lex.x @@ -50,7 +50,7 @@ $ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:] <0,para> { $ws* \n ; $ws* \> { begin birdtrack } - $ws* prop \> .* \n { strtoken TokProperty } + $ws* prop \> .* \n { strtoken TokProperty `andBegin` property} $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr } $ws* [\*\-] { token TokBullet `andBegin` string } $ws* \[ { token TokDefStart `andBegin` def } @@ -75,6 +75,8 @@ $ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:] .* \n? { strtokenNL TokBirdTrack `andBegin` line } + () { token TokPara `andBegin` para } + { $ws* \n { token TokPara `andBegin` para } $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr } -- cgit v1.2.3 From 409b25a0e9821687eeffde3d6bdb87f0fd9c73f9 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 9 Oct 2012 15:31:06 +0200 Subject: Allow to load interface files with compatible versions --- src/Haddock/InterfaceFile.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 78ab892b..1f6b489d 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -79,6 +79,9 @@ binaryInterfaceVersion = 22 #error Unknown GHC version #endif +binaryInterfaceVersionCompatibility :: [Word16] +binaryInterfaceVersionCompatibility = [21, 22] + initBinMemSize :: Int initBinMemSize = 1024*1024 @@ -187,7 +190,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 -- cgit v1.2.3 From 59fe0a2dcd1b816ab66802d18239dc88f335f6c8 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 10 Oct 2012 10:30:42 +0200 Subject: Export more types from Documentation.Haddock (fixes #216) --- src/Documentation/Haddock.hs | 2 ++ 1 file changed, 2 insertions(+) (limited to 'src') diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs index 855cdc79..e8ff9160 100644 --- a/src/Documentation/Haddock.hs +++ b/src/Documentation/Haddock.hs @@ -35,7 +35,9 @@ module Documentation.Haddock ( -- * Documentation comments Doc(..), Example(..), + Hyperlink(..), DocMarkup(..), + Documentation(..), HaddockModInfo(..), markup, -- cgit v1.2.3 From 6d490e93ec83dd5ee0fae86724f62c54801f4053 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 11 Oct 2012 10:49:04 +0200 Subject: Remove redundant if-defs, more source documentation --- src/Haddock/InterfaceFile.hs | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 1f6b489d..79818625 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -61,27 +61,28 @@ 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. +#if __GLASGOW_HASKELL__ == 706 +-- 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 adapt this code to work with a newer versions of GHC *you* need to +-- follow those steps: +-- +-- (1) increase `binaryInterfaceVersion` +-- +-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] +-- binaryInterfaceVersion :: Word16 -#if __GLASGOW_HASKELL__ == 702 -binaryInterfaceVersion = 22 -#elif __GLASGOW_HASKELL__ == 703 -binaryInterfaceVersion = 22 -#elif __GLASGOW_HASKELL__ == 704 -binaryInterfaceVersion = 22 -#elif __GLASGOW_HASKELL__ == 705 binaryInterfaceVersion = 22 -#elif __GLASGOW_HASKELL__ == 706 -binaryInterfaceVersion = 22 -#else -#error Unknown GHC version -#endif binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [21, 22] +#else +#error Unsupported GHC version +#endif + initBinMemSize :: Int initBinMemSize = 1024*1024 -- cgit v1.2.3 From 36c2c37136ac26b19c6e869a537abbd990ebbc46 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Fri, 12 Oct 2012 09:49:31 +0200 Subject: Improve note about `binaryInterfaceVersion` (thanks David) --- src/Haddock/InterfaceFile.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 79818625..a25b734a 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -66,8 +66,9 @@ binaryInterfaceMagic = 0xD0Cface -- versions, and because we store GHC datatypes in our interface files, we need -- to make sure we version our interface files accordingly. -- --- If you adapt this code to work with a newer versions of GHC *you* need to --- follow those steps: +-- 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` -- -- cgit v1.2.3 From c542021275f740d716d57c4c9b6135b39a4ccc38 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 13 Oct 2012 14:40:33 +0200 Subject: Remove unused MonadFix constraint --- src/Haddock.hs | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/Haddock.hs b/src/Haddock.hs index f53e01a9..3ac2115d 100644 --- a/src/Haddock.hs +++ b/src/Haddock.hs @@ -60,9 +60,6 @@ import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) import Panic (panic, handleGhcException) import Module -import Control.Monad.Fix (MonadFix) - - -------------------------------------------------------------------------------- -- * Exception handling -------------------------------------------------------------------------------- @@ -267,10 +264,10 @@ 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) -- cgit v1.2.3 From 4dc9c211ccb6274b6663d71cf6f768d09ae76d66 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 13 Oct 2012 15:15:38 +0200 Subject: Minor code simplification --- src/Haddock.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/Haddock.hs b/src/Haddock.hs index 3ac2115d..f3535fb1 100644 --- a/src/Haddock.hs +++ b/src/Haddock.hs @@ -32,7 +32,8 @@ 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 @@ -143,9 +144,8 @@ haddock args = 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) $ \f -> do + liftIO $ dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks -- Render the interfaces. liftIO $ renderStep dflags flags qual packages ifaces -- cgit v1.2.3 From fa3a688967255a5d7f7dba8430de467dc0b9e57b Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 13 Oct 2012 15:33:43 +0200 Subject: Increase code locality --- src/Haddock.hs | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) (limited to 'src') diff --git a/src/Haddock.hs b/src/Haddock.hs index f3535fb1..c53b4543 100644 --- a/src/Haddock.hs +++ b/src/Haddock.hs @@ -144,8 +144,11 @@ haddock args = handleTopExceptions $ do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files -- Dump an "interface file" (.haddock file), if requested. - forM_ (optDumpInterfaceFile flags) $ \f -> do - liftIO $ dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks + 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 @@ -284,15 +287,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 ------------------------------------------------------------------------------- -- cgit v1.2.3 From e8c6e9beca2564016cacc4e85921f5ae99fa3dfd Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 13 Oct 2012 16:03:12 +0200 Subject: Minor code simplification --- src/Haddock.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'src') diff --git a/src/Haddock.hs b/src/Haddock.hs index c53b4543..f79f3470 100644 --- a/src/Haddock.hs +++ b/src/Haddock.hs @@ -272,8 +272,7 @@ readInterfaceFiles :: MonadIO 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 -- cgit v1.2.3 From 2107860036788651c8286f9e1435472b3e799736 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 13 Oct 2012 19:02:16 +0200 Subject: Handle HsExplicitListTy in renameer (fixes #213) --- src/Haddock/Interface/Rename.hs | 2 + tests/html-tests/tests/AdvanceTypes.hs | 9 +++ tests/html-tests/tests/AdvanceTypes.html.ref | 97 +++++++++++++++++++++++ tests/html-tests/tests/mini_AdvanceTypes.html.ref | 33 ++++++++ 4 files changed, 141 insertions(+) create mode 100644 tests/html-tests/tests/AdvanceTypes.hs create mode 100644 tests/html-tests/tests/AdvanceTypes.html.ref create mode 100644 tests/html-tests/tests/mini_AdvanceTypes.html.ref (limited to 'src') diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 55c9a5da..4bdbcb76 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -271,6 +271,8 @@ renameType t = case t of HsTyLit x -> return (HsTyLit x) + HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b + _ -> error "renameType" diff --git a/tests/html-tests/tests/AdvanceTypes.hs b/tests/html-tests/tests/AdvanceTypes.hs new file mode 100644 index 00000000..939fdf07 --- /dev/null +++ b/tests/html-tests/tests/AdvanceTypes.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +module AdvanceTypes where + +data Pattern :: [*] -> * where + Nil :: Pattern '[] + Cons :: Maybe h -> Pattern t -> Pattern (h ': t) diff --git a/tests/html-tests/tests/AdvanceTypes.html.ref b/tests/html-tests/tests/AdvanceTypes.html.ref new file mode 100644 index 00000000..bac545be --- /dev/null +++ b/tests/html-tests/tests/AdvanceTypes.html.ref @@ -0,0 +1,97 @@ + +AdvanceTypes
Safe HaskellNone

AdvanceTypes

Documentation

data Pattern where

Constructors

Nil :: Pattern `[]` 
Cons :: Maybe h -> Pattern t -> Pattern (h : t) 
diff --git a/tests/html-tests/tests/mini_AdvanceTypes.html.ref b/tests/html-tests/tests/mini_AdvanceTypes.html.ref new file mode 100644 index 00000000..59d8dcb1 --- /dev/null +++ b/tests/html-tests/tests/mini_AdvanceTypes.html.ref @@ -0,0 +1,33 @@ + +AdvanceTypes

AdvanceTypes

data Pattern

-- cgit v1.2.3 From 401dd8302ddc3c1716762278f2d23fd354e1d1d4 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 13 Oct 2012 20:46:31 +0200 Subject: Better error messages --- src/Haddock/Interface/Rename.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 4bdbcb76..358fb964 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -273,8 +273,12 @@ renameType t = case t of HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b - _ -> error "renameType" - + HsQuasiQuoteTy _ -> error "renameType: HsQuasiQuoteTy" + HsSpliceTy _ _ _ -> error "renameType: HsSpliceTy" + HsRecTy _ -> error "renameType: HsRecTy" + HsCoreTy _ -> error "renameType: HsCoreTy" + HsExplicitTupleTy _ _ -> error "renameType: HsExplicitTupleTy" + HsWrapTy _ _ -> error "renameType: HsWrapTy" renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) -- cgit v1.2.3 From 80666e9b384277eb208fa99476634ee1559b3a7c Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 00:21:07 +0200 Subject: Simplify RnM type --- src/Haddock/Interface/Rename.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 358fb964..792e571a 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -82,33 +82,32 @@ 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])) -- cgit v1.2.3 From 3ba97f8470f401c968a2ea6f5fd1e7cae1c69028 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 00:23:35 +0200 Subject: Simplify lookupRn --- src/Haddock/Interface/Rename.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 792e571a..6e80da86 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -111,12 +111,12 @@ 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]) @@ -133,7 +133,7 @@ runRnFM env rn = unRn rn lkp rename :: Name -> RnM DocName -rename = lookupRn id +rename = lookupRn renameL :: Located Name -> RnM (Located DocName) @@ -476,8 +476,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 -- cgit v1.2.3 From 91335e5044b6c09bbe8d28e2e9443378e5ddbd90 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 10:34:58 +0200 Subject: Handle more cases in renameType --- src/Haddock/Interface/Rename.hs | 33 +++++++++++++++++++-------------- 1 file changed, 19 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 6e80da86..9f3a4155 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -270,14 +270,16 @@ renameType t = case t of HsTyLit x -> return (HsTyLit x) - HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b - - HsQuasiQuoteTy _ -> error "renameType: HsQuasiQuoteTy" + 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" - HsRecTy _ -> error "renameType: HsRecTy" - HsCoreTy _ -> error "renameType: HsCoreTy" - HsExplicitTupleTy _ _ -> error "renameType: HsExplicitTupleTy" - HsWrapTy _ _ -> error "renameType: HsWrapTy" + +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 }) @@ -403,22 +405,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 -- cgit v1.2.3 From dfc2cb4e31d6756b2d6ca7f87e80d8913751a4b7 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 11:58:13 +0200 Subject: Allow haddock markup in deprecation messages --- haddock.cabal | 1 + src/Haddock/Interface/Create.hs | 49 +++++++++++++--------- src/Haddock/Parse.y | 2 +- src/Haddock/Types.hs | 39 ++++++++++++++++- tests/html-tests/tests/BugDeprecated.html.ref | 18 +++++--- tests/html-tests/tests/BugExportHeadings.html.ref | 9 ++-- tests/html-tests/tests/DeprecatedClass.html.ref | 12 ++++-- tests/html-tests/tests/DeprecatedData.html.ref | 18 +++++--- tests/html-tests/tests/DeprecatedFunction.hs | 8 +++- tests/html-tests/tests/DeprecatedFunction.html.ref | 28 ++++++++++++- .../html-tests/tests/DeprecatedFunction2.html.ref | 3 +- .../html-tests/tests/DeprecatedFunction3.html.ref | 3 +- tests/html-tests/tests/DeprecatedModule.hs | 2 +- tests/html-tests/tests/DeprecatedModule.html.ref | 5 ++- tests/html-tests/tests/DeprecatedModule2.html.ref | 3 +- tests/html-tests/tests/DeprecatedNewtype.html.ref | 12 ++++-- tests/html-tests/tests/DeprecatedRecord.html.ref | 3 +- .../html-tests/tests/DeprecatedTypeFamily.html.ref | 6 ++- .../tests/DeprecatedTypeSynonym.html.ref | 6 ++- tests/html-tests/tests/ModuleWithWarning.hs | 2 +- tests/html-tests/tests/ModuleWithWarning.html.ref | 5 ++- .../tests/mini_DeprecatedFunction.html.ref | 6 +++ 22 files changed, 179 insertions(+), 61 deletions(-) (limited to 'src') diff --git a/haddock.cabal b/haddock.cabal index b77fc5ac..88c18cd3 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -189,6 +189,7 @@ test-suite spec base , ghc , containers + , deepseq , array -- NOTE: As of this writing, Cabal does not properly handle alex/happy for diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 32f287f5..fca1a00e 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -41,7 +41,7 @@ import Name import Bag import RdrName import TcRnTypes -import FastString (unpackFS) +import FastString (concatFS) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -90,7 +90,8 @@ createInterface tm flags modMap instIfaceMap = do liftErrMsg $ warnAboutFilteredDecls dflags mdl decls - let warningMap = mkWarningMap warnings gre exportedNames + warningMap <- liftErrMsg $ mkWarningMap dflags warnings gre exportedNames + exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports instances instIfaceMap dflags @@ -112,11 +113,13 @@ 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), + ifaceDoc = Documentation mbDoc modWarn, ifaceRnDoc = Documentation Nothing Nothing, ifaceOptions = opts, ifaceDocMap = docMap, @@ -169,29 +172,35 @@ lookupModuleDyn dflags Nothing mdlName = 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 . catMaybes <$> mapM parse ws' + where + parse (n, w) = (fmap $ (,) 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 + NoWarnings -> return Nothing + WarnSome _ -> return Nothing + WarnAll w -> parseWarning dflags gre w -warnToDoc :: WarningTxt -> Doc id -warnToDoc w = case w of - (DeprecatedTxt msg) -> format "Deprecated: " msg - (WarningTxt msg) -> format "Warning: " msg +parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Maybe (Doc Name)) +parseWarning dflags gre w = do + r <- case w of + (DeprecatedTxt msg) -> format "Deprecated: " msg + (WarningTxt msg) -> format "Warning: " 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 = fmap (DocWarning . DocParagraph . DocAppend (DocString x)) + <$> processDocString dflags gre (HsDocString $ concatFS xs) ------------------------------------------------------------------------------- diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y index 0befe395..f40ff521 100644 --- a/src/Haddock/Parse.y +++ b/src/Haddock/Parse.y @@ -7,7 +7,7 @@ -- 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), Hyperlink(..)) diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 05fc9747..9be46748 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 @@ -316,18 +317,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 diff --git a/tests/html-tests/tests/BugDeprecated.html.ref b/tests/html-tests/tests/BugDeprecated.html.ref index f632d670..913b189d 100644 --- a/tests/html-tests/tests/BugDeprecated.html.ref +++ b/tests/html-tests/tests/BugDeprecated.html.ref @@ -96,7 +96,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_BugDeprecated.html");} >

Deprecated: for foo

Deprecated: for foo +

Deprecated: for baz

Deprecated: for baz +

Deprecated: for bar

Deprecated: for bar +

Deprecated: for one

Deprecated: for one +

some documentation for one, two and three @@ -155,7 +159,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_BugDeprecated.html");} >

Deprecated: for three

Deprecated: for three +

some documentation for one, two and three @@ -172,7 +177,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_BugDeprecated.html");} >

Deprecated: for two

Deprecated: for two +

some documentation for one, two and three diff --git a/tests/html-tests/tests/BugExportHeadings.html.ref b/tests/html-tests/tests/BugExportHeadings.html.ref index d3298b2e..457e2c50 100644 --- a/tests/html-tests/tests/BugExportHeadings.html.ref +++ b/tests/html-tests/tests/BugExportHeadings.html.ref @@ -166,7 +166,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_BugExportHeadings.html >

Deprecated: for one

Deprecated: for one +

Deprecated: for two

Deprecated: for two +

Deprecated: for three

Deprecated: for three +

Deprecated: SomeClass

Deprecated: SomeClass +

some class @@ -106,7 +107,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedClass.html") >

Deprecated: foo

Deprecated: foo +

documentation for foo @@ -126,7 +128,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedClass.html") >

Deprecated: SomeOtherClass

Deprecated: SomeOtherClass +

Deprecated: bar

Deprecated: bar +

Deprecated: Foo

Deprecated: Foo +

type Foo @@ -110,7 +111,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedData.html"); >

Deprecated: Foo

Deprecated: Foo +

constructor Foo @@ -125,7 +127,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedData.html"); >

Deprecated: Bar

Deprecated: Bar +

constructor Bar @@ -145,7 +148,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedData.html"); >

Deprecated: One

Deprecated: One +

Deprecated: One

Deprecated: One +

Deprecated: Two

Deprecated: Two +

:: Int
  • bar :: Int

    • Deprecated: use bar instead

    Deprecated: use bar instead +

    some documentation foo + >some documentation for foo +

    bar :: Int

    some documentation for bar

    Deprecated: use bar instead

    Deprecated: use bar instead +

    Deprecated: use bar instead

    Deprecated: use bar instead +

    Deprecated: Use Foo instead

    Deprecated: Use Foo instead +

    Documentation for

    Deprecated: Use Foo instead

    Deprecated: Use Foo instead +

    Deprecated: SomeNewType

    Deprecated: SomeNewType +

    some documentation @@ -100,7 +101,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedNewtype.html >

    Deprecated: SomeNewTypeConst

    Deprecated: SomeNewTypeConst +

    constructor docu @@ -120,7 +122,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedNewtype.html >

    Deprecated: SomeOtherNewType

    Deprecated: SomeOtherNewType +

    Deprecated: SomeOtherNewTypeConst

    Deprecated: SomeOtherNewTypeConst +

    Deprecated: do not use this

    Deprecated: do not use this +

    some value diff --git a/tests/html-tests/tests/DeprecatedTypeFamily.html.ref b/tests/html-tests/tests/DeprecatedTypeFamily.html.ref index cd091802..ffc069a6 100644 --- a/tests/html-tests/tests/DeprecatedTypeFamily.html.ref +++ b/tests/html-tests/tests/DeprecatedTypeFamily.html.ref @@ -72,7 +72,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedTypeFamily.h >

    Deprecated: SomeTypeFamily

    Deprecated: SomeTypeFamily +

    some documentation @@ -89,7 +90,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedTypeFamily.h >

    Deprecated: SomeOtherTypeFamily

    Deprecated: SomeOtherTypeFamily +

    Deprecated: TypeSyn

    Deprecated: TypeSyn +

    some documentation @@ -97,7 +98,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedTypeSynonym. >

    Deprecated: OtherTypeSyn

    Deprecated: OtherTypeSyn +

    Warning: This is an unstable interface.

    Warning: This is an unstable interface. Prefer functions from Prelude instead! +

    Documentation for foo

    bar

    Date: Sun, 14 Oct 2012 13:55:09 +0200 Subject: If parsing of deprecation message fails, include it verbatim --- src/Haddock/Interface/Create.hs | 19 ++-- .../tests/DeprecationMessageParseError.hs | 12 +++ .../tests/DeprecationMessageParseError.html.ref | 101 +++++++++++++++++++++ .../mini_DeprecationMessageParseError.html.ref | 31 +++++++ 4 files changed, 154 insertions(+), 9 deletions(-) create mode 100644 tests/html-tests/tests/DeprecationMessageParseError.hs create mode 100644 tests/html-tests/tests/DeprecationMessageParseError.html.ref create mode 100644 tests/html-tests/tests/mini_DeprecationMessageParseError.html.ref (limited to 'src') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index fca1a00e..3eb5205c 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -41,7 +41,7 @@ import Name import Bag import RdrName import TcRnTypes -import FastString (concatFS) +import FastString (unpackFS, concatFS) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -179,9 +179,9 @@ mkWarningMap dflags warnings gre exps = case warnings of WarnSome ws -> do let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ , let n = gre_name elt, n `elem` exps ] - M.fromList . catMaybes <$> mapM parse ws' + M.fromList <$> mapM parse ws' where - parse (n, w) = (fmap $ (,) n) <$> parseWarning dflags gre w + parse (n, w) = (,) n <$> parseWarning dflags gre w moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name)) @@ -189,18 +189,19 @@ moduleWarning dflags gre ws = case ws of NoWarnings -> return Nothing WarnSome _ -> return Nothing - WarnAll w -> parseWarning dflags gre w + WarnAll w -> Just <$> parseWarning dflags gre w -parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Maybe (Doc Name)) +parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name) parseWarning dflags gre w = do r <- case w of - (DeprecatedTxt msg) -> format "Deprecated: " msg - (WarningTxt msg) -> format "Warning: " msg + (DeprecatedTxt msg) -> format "Deprecated: " (concatFS msg) + (WarningTxt msg) -> format "Warning: " (concatFS msg) r `deepseq` return r where - format x xs = fmap (DocWarning . DocParagraph . DocAppend (DocString x)) - <$> processDocString dflags gre (HsDocString $ concatFS xs) + format x xs = DocWarning . DocParagraph . DocAppend (DocString x) + . fromMaybe (DocString . unpackFS $ xs) + <$> processDocString dflags gre (HsDocString xs) ------------------------------------------------------------------------------- diff --git a/tests/html-tests/tests/DeprecationMessageParseError.hs b/tests/html-tests/tests/DeprecationMessageParseError.hs new file mode 100644 index 00000000..5f0b8713 --- /dev/null +++ b/tests/html-tests/tests/DeprecationMessageParseError.hs @@ -0,0 +1,12 @@ +-- | +-- What is tested here: +-- +-- * if parsing of a deprecation message fails, the message is included +-- verbatim +-- +module DeprecationMessageParseError where + +-- | some documentation for foo +foo :: Int +foo = 23 +{-# DEPRECATED foo "use @bar instead" #-} diff --git a/tests/html-tests/tests/DeprecationMessageParseError.html.ref b/tests/html-tests/tests/DeprecationMessageParseError.html.ref new file mode 100644 index 00000000..b4ea426e --- /dev/null +++ b/tests/html-tests/tests/DeprecationMessageParseError.html.ref @@ -0,0 +1,101 @@ + +DeprecationMessageParseError
    Safe HaskellNone

    DeprecationMessageParseError

    Description

    What is tested here: +

    • if parsing of a deprecation message fails, the message is included + verbatim +

    Synopsis

    Documentation

    foo :: Int

    Deprecated: use @bar instead

    some documentation for foo +

    diff --git a/tests/html-tests/tests/mini_DeprecationMessageParseError.html.ref b/tests/html-tests/tests/mini_DeprecationMessageParseError.html.ref new file mode 100644 index 00000000..e52f487f --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecationMessageParseError.html.ref @@ -0,0 +1,31 @@ + +DeprecationMessageParseError

    DeprecationMessageParseError

    -- cgit v1.2.3 From 4334a1657865b5a745ac0e8c56de4318fcd54bac Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 15:40:53 +0200 Subject: Minor formatting change --- src/Haddock/Interface/Create.hs | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) (limited to 'src') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 3eb5205c..2ffe8de8 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -116,25 +116,25 @@ createInterface tm flags modMap instIfaceMap = do modWarn <- liftErrMsg $ moduleWarning dflags gre warnings return $! Interface { - 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 + 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 } mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName -- cgit v1.2.3 From 37a4e2c3b71280fdee7b217dd9ddff090ed34873 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 16:03:43 +0200 Subject: Properly handle deprecation messages for re-exported things (fixes #220) --- src/Haddock/Interface/Create.hs | 7 +- src/Haddock/Types.hs | 5 ++ tests/html-tests/tests/DeprecatedReExport.hs | 3 + tests/html-tests/tests/DeprecatedReExport.html.ref | 91 ++++++++++++++++++++++ .../tests/mini_DeprecatedReExport.html.ref | 31 ++++++++ 5 files changed, 134 insertions(+), 3 deletions(-) create mode 100644 tests/html-tests/tests/DeprecatedReExport.hs create mode 100644 tests/html-tests/tests/DeprecatedReExport.html.ref create mode 100644 tests/html-tests/tests/mini_DeprecatedReExport.html.ref (limited to 'src') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 2ffe8de8..6c121ad4 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -92,7 +92,9 @@ createInterface tm flags modMap instIfaceMap = do warningMap <- liftErrMsg $ mkWarningMap dflags warnings gre exportedNames - exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports + 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 @@ -135,6 +137,7 @@ createInterface tm flags modMap instIfaceMap = do , ifaceModuleAliases = aliases , ifaceInstances = instances , ifaceHaddockCoverage = coverage + , ifaceWarningMap = warningMap } mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName @@ -170,8 +173,6 @@ lookupModuleDyn dflags Nothing mdlName = -- Warnings ------------------------------------------------------------------------------- -type WarningMap = DocMap Name - mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap mkWarningMap dflags warnings gre exps = case warnings of NoWarnings -> return M.empty diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 9be46748..181ea026 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -114,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. diff --git a/tests/html-tests/tests/DeprecatedReExport.hs b/tests/html-tests/tests/DeprecatedReExport.hs new file mode 100644 index 00000000..10a8c6a2 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedReExport.hs @@ -0,0 +1,3 @@ +module DeprecatedReExport (foo) where + +import DeprecatedFunction diff --git a/tests/html-tests/tests/DeprecatedReExport.html.ref b/tests/html-tests/tests/DeprecatedReExport.html.ref new file mode 100644 index 00000000..17988951 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedReExport.html.ref @@ -0,0 +1,91 @@ + +DeprecatedReExport
    Safe HaskellNone

    DeprecatedReExport

    Synopsis

    Documentation

    foo :: Int

    Deprecated: use bar instead +

    some documentation for foo +

    diff --git a/tests/html-tests/tests/mini_DeprecatedReExport.html.ref b/tests/html-tests/tests/mini_DeprecatedReExport.html.ref new file mode 100644 index 00000000..de5dcf95 --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecatedReExport.html.ref @@ -0,0 +1,31 @@ + +DeprecatedReExport

    DeprecatedReExport

    -- cgit v1.2.3 From 1d480b49a2d9098993889ca29dd82ef228ae5c0d Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 28 Nov 2012 09:54:35 +0100 Subject: Export missing types from Documentation.Haddock --- src/Documentation/Haddock.hs | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'src') diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs index e8ff9160..36115a2a 100644 --- a/src/Documentation/Haddock.hs +++ b/src/Documentation/Haddock.hs @@ -38,6 +38,10 @@ module Documentation.Haddock ( Hyperlink(..), DocMarkup(..), Documentation(..), + ArgMap, + AliasMap, + WarningMap, + DocMap, HaddockModInfo(..), markup, -- cgit v1.2.3