From c836dd4cb47d457b066b51b61a08f583a8c4466e Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Sat, 13 May 2017 12:48:10 +0200 Subject: Consequently use inClass and notInClass in haddock-library (#617) These allow attoparsec to do some clever lookup optimization --- haddock-library/src/Documentation/Haddock/Parser.hs | 21 +++++++++++++-------- .../src/Documentation/Haddock/Parser/Util.hs | 9 ++++++--- 2 files changed, 19 insertions(+), 11 deletions(-) (limited to 'haddock-library/src/Documentation/Haddock') diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 123f5612..ddea2b9b 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -143,7 +143,7 @@ specialChar = "_/<@\"&'`# " -- to ensure that we have already given a chance to more meaningful parsers -- before capturing their characers. string' :: Parser (DocH mod a) -string' = DocString . unescape . decodeUtf8 <$> takeWhile1_ (`notElem` specialChar) +string' = DocString . unescape . decodeUtf8 <$> takeWhile1_ (notInClass specialChar) where unescape "" = "" unescape ('\\':x:xs) = x : unescape xs @@ -153,7 +153,7 @@ string' = DocString . unescape . decodeUtf8 <$> takeWhile1_ (`notElem` specialCh -- This is done to skip over any special characters belonging to other -- elements but which were not deemed meaningful at their positions. skipSpecialChar :: Parser (DocH mod a) -skipSpecialChar = DocString . return <$> satisfy (`elem` specialChar) +skipSpecialChar = DocString . return <$> satisfy (inClass specialChar) -- | Emphasis parser. -- @@ -215,7 +215,7 @@ moduleName = DocModule <$> (char '"' *> modid <* char '"') -- accept {small | large | digit | ' } here. But as we can't -- match on unicode characters, this is currently not possible. -- Note that we allow ‘#’ to suport anchors. - <*> (decodeUtf8 <$> takeWhile (`notElem` (" .&[{}(=*)+]!|@/;,^?\"\n"::String))) + <*> (decodeUtf8 <$> takeWhile (notInClass " .&[{}(=*)+]!|@/;,^?\"\n")) -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture. @@ -338,7 +338,7 @@ definitionList :: BS.ByteString -> Parser (DocH mod Identifier) definitionList indent = DocDefList <$> p where p = do - label <- "[" *> (parseStringBS <$> takeWhile1 (`notElem` ("]\n" :: String))) <* ("]" <* optional ":") + label <- "[" *> (parseStringBS <$> takeWhile1 (notInClass "]\n")) <* ("]" <* optional ":") c <- takeLine (cs, items) <- more indent p let contents = parseString . dropNLs . unlines $ c : cs @@ -561,7 +561,7 @@ autoUrl = mkLink <$> url url = mappend <$> ("http://" <|> "https://" <|> "ftp://") <*> takeWhile1 (not . isSpace) mkLink :: BS.ByteString -> DocH mod a mkLink s = case unsnoc s of - Just (xs, x) | x `elem` (",.!?" :: String) -> DocHyperlink (Hyperlink (decodeUtf8 xs) Nothing) `docAppend` DocString [x] + Just (xs, x) | inClass ",.!?" x -> DocHyperlink (Hyperlink (decodeUtf8 xs) Nothing) `docAppend` DocString [x] _ -> DocHyperlink (Hyperlink (decodeUtf8 s) Nothing) -- | Parses strings between identifier delimiters. Consumes all input that it @@ -570,8 +570,13 @@ autoUrl = mkLink <$> url parseValid :: Parser String parseValid = p some where - idChar = satisfy (`elem` ("_.!#$%&*+/<=>?@\\|-~:^"::String)) - <|> digit <|> letter_ascii + idChar = + satisfy (\c -> isAlpha_ascii c + || isDigit c + -- N.B. '-' is placed first otherwise attoparsec thinks + -- it belongs to a character class + || inClass "-_.!#$%&*+/<=>?@\\|~:^" c) + p p' = do vs' <- p' $ utf8String "⋆" <|> return <$> idChar let vs = concat vs' @@ -594,4 +599,4 @@ identifier = do e <- idDelim return $ DocIdentifier (o, vid, e) where - idDelim = char '\'' <|> char '`' + idDelim = satisfy (\c -> c == '\'' || c == '`') diff --git a/haddock-library/src/Documentation/Haddock/Parser/Util.hs b/haddock-library/src/Documentation/Haddock/Parser/Util.hs index d908ce18..ab5e5e9e 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Util.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Util.hs @@ -22,7 +22,7 @@ module Documentation.Haddock.Parser.Util ( import Control.Applicative import Control.Monad (mfilter) -import Documentation.Haddock.Parser.Monad +import Documentation.Haddock.Parser.Monad hiding (isHorizontalSpace) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS import Prelude hiding (takeWhile) @@ -40,11 +40,14 @@ unsnoc bs strip :: String -> String strip = (\f -> f . f) $ dropWhile isSpace . reverse +isHorizontalSpace :: Char -> Bool +isHorizontalSpace = inClass " \t\f\v\r" + skipHorizontalSpace :: Parser () -skipHorizontalSpace = skipWhile (`elem` " \t\f\v\r") +skipHorizontalSpace = skipWhile isHorizontalSpace takeHorizontalSpace :: Parser BS.ByteString -takeHorizontalSpace = takeWhile (`elem` " \t\f\v\r") +takeHorizontalSpace = takeWhile isHorizontalSpace makeLabeled :: (String -> Maybe String -> a) -> String -> a makeLabeled f input = case break isSpace $ removeEscapes $ strip input of -- cgit v1.2.3 From fdf1b017b07e12769a7ca605b41dc76842838855 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Tue, 30 May 2017 19:02:12 +0200 Subject: Make haddock-library and haddock-api warning free (#626) --- haddock-api/src/Haddock.hs | 12 ++++++------ haddock-api/src/Haddock/GhcUtils.hs | 4 ---- haddock-api/src/Haddock/Interface/Specialize.hs | 1 - haddock-library/src/Documentation/Haddock/Types.hs | 4 +++- 4 files changed, 9 insertions(+), 12 deletions(-) (limited to 'haddock-library/src/Documentation/Haddock') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index f0e7e6c7..57ea5fea 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -398,12 +398,12 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do ghcLink = NoLink } let dynflags'' = updOptLevel 0 $ gopt_unset dynflags' Opt_SplitObjs - 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'' + + -- 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'' where parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags parseGhcFlags dynflags = do diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index c8e5ea8b..dcc1d834 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -17,17 +17,13 @@ module Haddock.GhcUtils where import Control.Arrow -import Data.Function import Exception import Outputable import Name import Lexeme import Module -import RdrName (GlobalRdrEnv) -import GhcMonad (withSession) import HscTypes -import UniqFM import GHC import Class diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 8c28cd5a..da8c3e7b 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -27,7 +27,6 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set -import Data.Foldable -- | Instantiate all occurrences of given names with corresponding types. specialize :: forall name a. (Ord name, DataId name, NamedThing name) diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 4d5bb68a..660878ff 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -- | -- Module : Documentation.Haddock.Types @@ -14,8 +14,10 @@ -- Exposes documentation data types used for (some) of Haddock. module Documentation.Haddock.Types where +#if !MIN_VERSION_base(4,8,0) import Data.Foldable import Data.Traversable +#endif -- | With the advent of 'Version', we may want to start attaching more -- meta-data to comments. We make a structure for this ahead of time -- cgit v1.2.3 From 3d3166d75c0012112a49fee4c2f6cbf82de383fa Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Mon, 31 Jul 2017 20:15:32 +0200 Subject: Move `DocMarkup` from haddock-api to haddock-library (#659) * Move `DocMarkup` from haddock-api to haddock-library * Move more markup related functions * Markup module * CHANGELOG --- CHANGES.md | 2 + haddock-api/haddock-api.cabal | 2 +- haddock-api/src/Documentation/Haddock.hs | 6 +- haddock-api/src/Haddock/Backends/Hoogle.hs | 1 + haddock-api/src/Haddock/Backends/LaTeX.hs | 1 + .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 1 + haddock-api/src/Haddock/Types.hs | 32 +---------- haddock-api/src/Haddock/Utils.hs | 67 ---------------------- haddock-library/haddock-library.cabal | 3 +- .../src/Documentation/Haddock/Markup.hs | 59 +++++++++++++++++++ haddock-library/src/Documentation/Haddock/Types.hs | 27 +++++++++ 11 files changed, 100 insertions(+), 101 deletions(-) create mode 100644 haddock-library/src/Documentation/Haddock/Markup.hs (limited to 'haddock-library/src/Documentation/Haddock') diff --git a/CHANGES.md b/CHANGES.md index aa8789c0..bf60817a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,8 @@ * to be released + * Move markup related data types to haddock-library + ## Changes in version 2.18.1 * Synopsis is working again (#599) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index de959955..6cde7266 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -42,7 +42,7 @@ library , Cabal ^>= 2.0.0 , ghc ^>= 8.2 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.4.4 + , haddock-library ^>= 1.4.5 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs index 14605e92..10d6849a 100644 --- a/haddock-api/src/Documentation/Haddock.hs +++ b/haddock-api/src/Documentation/Haddock.hs @@ -39,7 +39,8 @@ module Documentation.Haddock ( DocH(..), Example(..), Hyperlink(..), - DocMarkup(..), + DocMarkup, + DocMarkupH(..), Documentation(..), ArgMap, AliasMap, @@ -69,12 +70,11 @@ module Documentation.Haddock ( withGhc ) where - +import Documentation.Haddock.Markup (markup) import Haddock.InterfaceFile import Haddock.Interface import Haddock.Types import Haddock.Options -import Haddock.Utils import Haddock diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 183b669e..3a9f6e43 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -18,6 +18,7 @@ module Haddock.Backends.Hoogle ( import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..)) import InstEnv (ClsInst(..)) +import Documentation.Haddock.Markup import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 18660b3f..1b248d2e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -16,6 +16,7 @@ module Haddock.Backends.LaTeX ( ) where +import Documentation.Haddock.Markup import Haddock.Types import Haddock.Utils import Haddock.GhcUtils diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index e36f9528..18c8a0ff 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -20,6 +20,7 @@ module Haddock.Backends.Xhtml.DocMarkup ( ) where import Data.List +import Documentation.Haddock.Markup import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils import Haddock.Types diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index bfc8e32b..de599bd8 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -189,7 +189,7 @@ data InstalledInterface = InstalledInterface , instSubMap :: Map Name [Name] , instBundledPatSynMap :: Map Name [Name] - + , instFixMap :: Map Name Fixity } @@ -443,6 +443,8 @@ type LDoc id = Located (Doc id) type Doc id = DocH (ModuleName, OccName) id type MDoc id = MetaDoc (ModuleName, OccName) id +type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a + instance (NFData a, NFData mod) => NFData (DocH mod a) where rnf doc = case doc of @@ -494,34 +496,6 @@ exampleToString :: Example -> String exampleToString (Example expression result) = ">>> " ++ expression ++ "\n" ++ unlines result - -data DocMarkup id a = Markup - { markupEmpty :: a - , markupString :: String -> a - , markupParagraph :: a -> a - , markupAppend :: a -> a -> a - , markupIdentifier :: id -> a - , markupIdentifierUnchecked :: (ModuleName, OccName) -> a - , markupModule :: String -> a - , markupWarning :: a -> a - , markupEmphasis :: a -> a - , markupBold :: a -> a - , markupMonospaced :: a -> a - , markupUnorderedList :: [a] -> a - , markupOrderedList :: [a] -> a - , markupDefList :: [(a,a)] -> a - , markupCodeBlock :: a -> a - , markupHyperlink :: Hyperlink -> a - , markupAName :: String -> a - , markupPic :: Picture -> a - , markupMathInline :: String -> a - , markupMathDisplay :: String -> a - , markupProperty :: String -> a - , markupExample :: [Example] -> a - , markupHeader :: Header a -> a - } - - data HaddockModInfo name = HaddockModInfo { hmi_description :: Maybe (Doc name) , hmi_copyright :: Maybe String diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 404cfcf6..7a9d65a4 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -37,8 +37,6 @@ module Haddock.Utils ( html_xrefs_ref, html_xrefs_ref', -- * Doc markup - markup, - idMarkup, mkMeta, -- * List utilities @@ -448,71 +446,6 @@ spanWith p xs@(a:as) | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs) | otherwise = ([],xs) - ------------------------------------------------------------------------------ --- * Put here temporarily ------------------------------------------------------------------------------ - - -markup :: DocMarkup id a -> Doc id -> a -markup m DocEmpty = markupEmpty m -markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) -markup m (DocString s) = markupString m s -markup m (DocParagraph d) = markupParagraph m (markup m d) -markup m (DocIdentifier x) = markupIdentifier m x -markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x -markup m (DocModule mod0) = markupModule m mod0 -markup m (DocWarning d) = markupWarning m (markup m d) -markup m (DocEmphasis d) = markupEmphasis m (markup m d) -markup m (DocBold d) = markupBold m (markup m d) -markup m (DocMonospaced d) = markupMonospaced m (markup m d) -markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) -markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) -markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) -markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocHyperlink l) = markupHyperlink m l -markup m (DocAName ref) = markupAName m ref -markup m (DocPic img) = markupPic m img -markup m (DocMathInline mathjax) = markupMathInline m mathjax -markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax -markup m (DocProperty p) = markupProperty m p -markup m (DocExamples e) = markupExample m e -markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) - - -markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a) -markupPair m (a,b) = (markup m a, markup m b) - - --- | The identity markup -idMarkup :: DocMarkup a (Doc a) -idMarkup = Markup { - markupEmpty = DocEmpty, - markupString = DocString, - markupParagraph = DocParagraph, - markupAppend = DocAppend, - markupIdentifier = DocIdentifier, - markupIdentifierUnchecked = DocIdentifierUnchecked, - markupModule = DocModule, - markupWarning = DocWarning, - markupEmphasis = DocEmphasis, - markupBold = DocBold, - markupMonospaced = DocMonospaced, - markupUnorderedList = DocUnorderedList, - markupOrderedList = DocOrderedList, - markupDefList = DocDefList, - markupCodeBlock = DocCodeBlock, - markupHyperlink = DocHyperlink, - markupAName = DocAName, - markupPic = DocPic, - markupMathInline = DocMathInline, - markupMathDisplay = DocMathDisplay, - markupProperty = DocProperty, - markupExample = DocExamples, - markupHeader = DocHeader - } - - ----------------------------------------------------------------------------- -- * System tools ----------------------------------------------------------------------------- diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 2e720d7b..44834aa9 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -31,10 +31,11 @@ library ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 exposed-modules: + Documentation.Haddock.Doc + Documentation.Haddock.Markup Documentation.Haddock.Parser Documentation.Haddock.Parser.Monad Documentation.Haddock.Types - Documentation.Haddock.Doc Documentation.Haddock.Utf8 other-modules: diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs new file mode 100644 index 00000000..b16cf049 --- /dev/null +++ b/haddock-library/src/Documentation/Haddock/Markup.hs @@ -0,0 +1,59 @@ +module Documentation.Haddock.Markup where + +import Documentation.Haddock.Types + +markup :: DocMarkupH mod id a -> DocH mod id -> a +markup m DocEmpty = markupEmpty m +markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) +markup m (DocString s) = markupString m s +markup m (DocParagraph d) = markupParagraph m (markup m d) +markup m (DocIdentifier x) = markupIdentifier m x +markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x +markup m (DocModule mod0) = markupModule m mod0 +markup m (DocWarning d) = markupWarning m (markup m d) +markup m (DocEmphasis d) = markupEmphasis m (markup m d) +markup m (DocBold d) = markupBold m (markup m d) +markup m (DocMonospaced d) = markupMonospaced m (markup m d) +markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) +markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) +markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) +markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) +markup m (DocHyperlink l) = markupHyperlink m l +markup m (DocAName ref) = markupAName m ref +markup m (DocPic img) = markupPic m img +markup m (DocMathInline mathjax) = markupMathInline m mathjax +markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax +markup m (DocProperty p) = markupProperty m p +markup m (DocExamples e) = markupExample m e +markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) + +markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a) +markupPair m (a,b) = (markup m a, markup m b) + +-- | The identity markup +idMarkup :: DocMarkupH mod id (DocH mod id) +idMarkup = Markup { + markupEmpty = DocEmpty, + markupString = DocString, + markupParagraph = DocParagraph, + markupAppend = DocAppend, + markupIdentifier = DocIdentifier, + markupIdentifierUnchecked = DocIdentifierUnchecked, + markupModule = DocModule, + markupWarning = DocWarning, + markupEmphasis = DocEmphasis, + markupBold = DocBold, + markupMonospaced = DocMonospaced, + markupUnorderedList = DocUnorderedList, + markupOrderedList = DocOrderedList, + markupDefList = DocDefList, + markupCodeBlock = DocCodeBlock, + markupHyperlink = DocHyperlink, + markupAName = DocAName, + markupPic = DocPic, + markupMathInline = DocMathInline, + markupMathDisplay = DocMathDisplay, + markupProperty = DocProperty, + markupExample = DocExamples, + markupHeader = DocHeader + } diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 660878ff..1e87edc0 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -80,3 +80,30 @@ data DocH mod id | DocExamples [Example] | DocHeader (Header (DocH mod id)) deriving (Eq, Show, Functor, Foldable, Traversable) + +data DocMarkupH mod id a = Markup + { markupEmpty :: a + , markupString :: String -> a + , markupParagraph :: a -> a + , markupAppend :: a -> a -> a + , markupIdentifier :: id -> a + , markupIdentifierUnchecked :: mod -> a + , markupModule :: String -> a + , markupWarning :: a -> a + , markupEmphasis :: a -> a + , markupBold :: a -> a + , markupMonospaced :: a -> a + , markupUnorderedList :: [a] -> a + , markupOrderedList :: [a] -> a + , markupDefList :: [(a,a)] -> a + , markupCodeBlock :: a -> a + , markupHyperlink :: Hyperlink -> a + , markupAName :: String -> a + , markupPic :: Picture -> a + , markupMathInline :: String -> a + , markupMathDisplay :: String -> a + , markupProperty :: String -> a + , markupExample :: [Example] -> a + , markupHeader :: Header a -> a + } + -- cgit v1.2.3 From 1ca3ff62bc3be0d9ad03eb7f531197c69182d3a0 Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Mon, 31 Jul 2017 20:35:49 +0200 Subject: Fixup haddock --- haddock-library/src/Documentation/Haddock/Parser.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-library/src/Documentation/Haddock') diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index ddea2b9b..8dc2a801 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -14,7 +14,7 @@ -- library, the most commonly used combination of functions is going -- to be -- --- @'toRegular' . 'parseParas'@ +-- @'toRegular' . '_doc' . 'parseParas'@ module Documentation.Haddock.Parser ( parseString, parseParas , overIdentifier, toRegular, Identifier ) where -- cgit v1.2.3 From 74d1173fa022cc8f520ff33c2620507522423e42 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Mon, 31 Jul 2017 21:50:24 +0200 Subject: Prepare haddock-library-1.4.5 release --- haddock-library/haddock-library.cabal | 3 ++- haddock-library/src/Documentation/Haddock/Markup.hs | 6 +++++- haddock-library/src/Documentation/Haddock/Types.hs | 8 ++++++++ 3 files changed, 15 insertions(+), 2 deletions(-) (limited to 'haddock-library/src/Documentation/Haddock') diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 44834aa9..0a07094b 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -15,7 +15,8 @@ bug-reports: https://github.com/haskell/haddock/issues category: Documentation build-type: Simple cabal-version: >= 2.0 - +extra-source-files: + CHANGES.md library default-language: Haskell2010 diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs index b16cf049..1bf6c084 100644 --- a/haddock-library/src/Documentation/Haddock/Markup.hs +++ b/haddock-library/src/Documentation/Haddock/Markup.hs @@ -1,4 +1,8 @@ -module Documentation.Haddock.Markup where +-- | @since 1.4.5 +module Documentation.Haddock.Markup ( + markup + , idMarkup + ) where import Documentation.Haddock.Types diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 1e87edc0..0ab6bb4c 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -81,6 +81,14 @@ data DocH mod id | DocHeader (Header (DocH mod id)) deriving (Eq, Show, Functor, Foldable, Traversable) +-- | 'DocMarkupH' is a set of instructions for marking up documentation. +-- In fact, it's really just a mapping from 'Doc' to some other +-- type [a], where [a] is usually the type of the output (HTML, say). +-- Use 'Documentation.Haddock.Markup.markup' to apply a 'DocMarkupH' to +-- a 'DocH'. +-- +-- @since 1.4.5 +-- data DocMarkupH mod id a = Markup { markupEmpty :: a , markupString :: String -> a -- cgit v1.2.3 From f1d326b53fbed5d37f2a83c66e73dbbc94a4354f Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Sun, 6 Aug 2017 13:18:02 +0200 Subject: Provide --show-interface option to dump interfaces (#645) * WIP: Provide --show-interface option to dump interfaces Like ghcs own --show-iface this flag dumps a binary interface file to stdout in a human (and machine) readable fashion. Currently it uses json as output format. * Fill all the jsonNull stubs * Rework Bifunctor instance of DocH, update changelog and documentation * replace changelog, bring DocMarkupH doc back * Update CHANGES.md * Update CHANGES.md * Move Control.Arrow up It would result in unused import if the Bifunctor instance is not generated. --- doc/invoking.rst | 5 + haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock.hs | 7 ++ haddock-api/src/Haddock/Interface/Json.hs | 109 +++++++++++++++++++++ haddock-api/src/Haddock/Options.hs | 6 ++ haddock-library/CHANGES.md | 6 ++ haddock-library/src/Documentation/Haddock/Types.hs | 33 ++++++- haddock.cabal | 1 + 8 files changed, 167 insertions(+), 1 deletion(-) create mode 100644 haddock-api/src/Haddock/Interface/Json.hs (limited to 'haddock-library/src/Documentation/Haddock') diff --git a/doc/invoking.rst b/doc/invoking.rst index 83087bac..fc1e4410 100644 --- a/doc/invoking.rst +++ b/doc/invoking.rst @@ -88,6 +88,11 @@ The following options are available: :option:`--read-interface` option for more details. The interface file is in a binary format; don't try to read it. +.. option:: --show-interface= + + Dumps a binary interface file to stdout in a human readable fashion. + Uses json as output format. + .. [1] Haddock interface files are not the same as Haskell interface files, I just couldn't think of a better name. diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index ef4bb98c..d38e9149 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -73,6 +73,7 @@ library Haddock.Interface.Rename Haddock.Interface.Create Haddock.Interface.AttachInstances + Haddock.Interface.Json Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader Haddock.Interface.Specialize diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 57ea5fea..554cb416 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -32,6 +32,7 @@ import Haddock.Backends.LaTeX import Haddock.Backends.Hoogle import Haddock.Backends.Hyperlinker import Haddock.Interface +import Haddock.Interface.Json import Haddock.Parser import Haddock.Types import Haddock.Version @@ -68,6 +69,7 @@ import System.Directory (doesDirectoryExist) import GHC hiding (verbosity) import Config import DynFlags hiding (projectVersion, verbosity) +import ErrUtils import Packages import Panic (handleGhcException) import Module @@ -164,6 +166,11 @@ haddockWithGhc ghc args = handleTopExceptions $ do dflags <- getDynFlags + forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do + mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] + forM_ mIfaceFile $ \(_, ifaceFile) -> do + putMsg dflags (renderJson (jsonInterfaceFile ifaceFile)) + if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs new file mode 100644 index 00000000..9a569204 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE RecordWildCards #-} +module Haddock.Interface.Json ( + jsonInstalledInterface + , jsonInterfaceFile + , renderJson + ) where + +import BasicTypes +import Json +import Module +import Name +import Outputable + +import Control.Arrow +import Data.Map (Map) +import Data.Bifunctor +import qualified Data.Map as Map + +import Haddock.Types +import Haddock.InterfaceFile + +jsonInterfaceFile :: InterfaceFile -> JsonDoc +jsonInterfaceFile InterfaceFile{..} = + jsonObject [ ("link_env" , jsonMap nameStableString (jsonString . moduleNameString . moduleName) ifLinkEnv) + , ("inst_ifaces", jsonArray (map jsonInstalledInterface ifInstalledIfaces)) + ] + +jsonInstalledInterface :: InstalledInterface -> JsonDoc +jsonInstalledInterface InstalledInterface{..} = jsonObject properties + where + properties = + [ ("module" , jsonModule instMod) + , ("is_sig" , jsonBool instIsSig) + , ("info" , jsonHaddockModInfo instInfo) + , ("doc_map" , jsonMap nameStableString jsonMDoc instDocMap) + , ("arg_map" , jsonMap nameStableString (jsonMap show jsonMDoc) instArgMap) + , ("exports" , jsonArray (map jsonName instExports)) + , ("visible_exports" , jsonArray (map jsonName instVisibleExports)) + , ("options" , jsonArray (map (jsonString . show) instOptions)) + , ("sub_map" , jsonMap nameStableString (jsonArray . map jsonName) instSubMap) + , ("bundled_patsyns" , jsonMap nameStableString (jsonArray . map jsonName) instBundledPatSynMap) + , ("fix_map" , jsonMap nameStableString jsonFixity instFixMap) + ] + +jsonHaddockModInfo :: HaddockModInfo Name -> JsonDoc +jsonHaddockModInfo HaddockModInfo{..} = + jsonObject [ ("description" , jsonMaybe jsonDoc hmi_description) + , ("copyright" , jsonMaybe jsonString hmi_copyright) + , ("maintainer" , jsonMaybe jsonString hmi_maintainer) + , ("stability" , jsonMaybe jsonString hmi_stability) + , ("protability" , jsonMaybe jsonString hmi_portability) + , ("safety" , jsonMaybe jsonString hmi_safety) + , ("language" , jsonMaybe (jsonString . show) hmi_language) + , ("extensions" , jsonArray (map (jsonString . show) hmi_extensions)) + ] + +jsonMap :: (a -> String) -> (b -> JsonDoc) -> Map a b -> JsonDoc +jsonMap f g = jsonObject . map (f *** g) . Map.toList + +jsonMDoc :: MDoc Name -> JsonDoc +jsonMDoc MetaDoc{..} = + jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))]) + , ("doc", jsonDoc _doc) + ] + +jsonDoc :: Doc Name -> JsonDoc +jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc)) + +jsonModule :: Module -> JsonDoc +jsonModule = JSString . moduleStableString + +jsonName :: Name -> JsonDoc +jsonName = JSString . nameStableString + +jsonFixity :: Fixity -> JsonDoc +jsonFixity (Fixity _ prec dir) = + jsonObject [ ("prec" , jsonInt prec) + , ("direction" , jsonFixityDirection dir) + ] + +jsonFixityDirection :: FixityDirection -> JsonDoc +jsonFixityDirection InfixL = jsonString "infixl" +jsonFixityDirection InfixR = jsonString "infixr" +jsonFixityDirection InfixN = jsonString "infix" + +renderJson :: JsonDoc -> SDoc +renderJson = renderJSON + +jsonMaybe :: (a -> JsonDoc) -> Maybe a -> JsonDoc +jsonMaybe = maybe jsonNull + +jsonString :: String -> JsonDoc +jsonString = JSString + +jsonObject :: [(String, JsonDoc)] -> JsonDoc +jsonObject = JSObject + +jsonArray :: [JsonDoc] -> JsonDoc +jsonArray = JSArray + +jsonNull :: JsonDoc +jsonNull = JSNull + +jsonInt :: Int -> JsonDoc +jsonInt = JSInt + +jsonBool :: Bool -> JsonDoc +jsonBool = JSBool + diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 0449c829..d73d1a79 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -25,6 +25,7 @@ module Haddock.Options ( sourceUrls, wikiUrls, optDumpInterfaceFile, + optShowInterfaceFile, optLaTeXStyle, optMathjax, qualification, @@ -53,6 +54,7 @@ data Flag -- | Flag_DocBook | Flag_ReadInterface String | Flag_DumpInterface String + | Flag_ShowInterface String | Flag_Heading String | Flag_Html | Flag_Hoogle @@ -112,6 +114,8 @@ options backwardsCompat = "read an interface from FILE", Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE") "write the resulting interface to FILE", + Option [] ["show-interface"] (ReqArg Flag_ShowInterface "FILE") + "print the interface in a human readable form", -- Option ['S'] ["docbook"] (NoArg Flag_DocBook) -- "output in DocBook XML", Option ['h'] ["html"] (NoArg Flag_Html) @@ -270,6 +274,8 @@ wikiUrls flags = optDumpInterfaceFile :: [Flag] -> Maybe FilePath optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] +optShowInterfaceFile :: [Flag] -> Maybe FilePath +optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ] optLaTeXStyle :: [Flag] -> Maybe String optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md index bebb9982..c52908e1 100644 --- a/haddock-library/CHANGES.md +++ b/haddock-library/CHANGES.md @@ -1,3 +1,9 @@ +## Changes in version 1.4.6 + + * to be released + + * Bifunctor instance for DocH + ## Changes in version 1.4.5 * Move markup related data types to haddock-library diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 0ab6bb4c..22cab425 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -19,6 +19,11 @@ import Data.Foldable import Data.Traversable #endif +#if MIN_VERSION_base(4,8,0) +import Control.Arrow ((***)) +import Data.Bifunctor +#endif + -- | With the advent of 'Version', we may want to start attaching more -- meta-data to comments. We make a structure for this ahead of time -- so we don't have to gut half the core each time we want to add such @@ -81,6 +86,33 @@ data DocH mod id | DocHeader (Header (DocH mod id)) deriving (Eq, Show, Functor, Foldable, Traversable) +#if MIN_VERSION_base(4,8,0) +instance Bifunctor DocH where + bimap _ _ DocEmpty = DocEmpty + bimap f g (DocAppend docA docB) = DocAppend (bimap f g docA) (bimap f g docB) + bimap _ _ (DocString s) = DocString s + bimap f g (DocParagraph doc) = DocParagraph (bimap f g doc) + bimap _ g (DocIdentifier i) = DocIdentifier (g i) + bimap f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked (f m) + bimap _ _ (DocModule s) = DocModule s + bimap f g (DocWarning doc) = DocWarning (bimap f g doc) + bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc) + bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc) + bimap f g (DocBold doc) = DocBold (bimap f g doc) + bimap f g (DocUnorderedList docs) = DocUnorderedList (map (bimap f g) docs) + bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs) + bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs) + bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc) + bimap _ _ (DocHyperlink hyperlink) = DocHyperlink hyperlink + bimap _ _ (DocPic picture) = DocPic picture + bimap _ _ (DocMathInline s) = DocMathInline s + bimap _ _ (DocMathDisplay s) = DocMathDisplay s + bimap _ _ (DocAName s) = DocAName s + bimap _ _ (DocProperty s) = DocProperty s + bimap _ _ (DocExamples examples) = DocExamples examples + bimap f g (DocHeader (Header level title)) = DocHeader (Header level (bimap f g title)) +#endif + -- | 'DocMarkupH' is a set of instructions for marking up documentation. -- In fact, it's really just a mapping from 'Doc' to some other -- type [a], where [a] is usually the type of the output (HTML, say). @@ -114,4 +146,3 @@ data DocMarkupH mod id a = Markup , markupExample :: [Example] -> a , markupHeader :: Header a -> a } - diff --git a/haddock.cabal b/haddock.cabal index 36c80f33..5ae3443c 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -106,6 +106,7 @@ executable haddock Documentation.Haddock Haddock Haddock.Interface + Haddock.Interface.Json Haddock.Interface.Rename Haddock.Interface.Create Haddock.Interface.AttachInstances -- cgit v1.2.3 From 2ad45f618b9ad2a7a5507e83c3990d93b752a3c0 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Wed, 16 Aug 2017 08:20:01 +0200 Subject: Bifoldable and Bitraversable for DocH and MetaDoc --- haddock-library/CHANGES.md | 2 +- haddock-library/src/Documentation/Haddock/Types.hs | 61 ++++++++++++++++++++++ 2 files changed, 62 insertions(+), 1 deletion(-) (limited to 'haddock-library/src/Documentation/Haddock') diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md index c52908e1..53d17f5e 100644 --- a/haddock-library/CHANGES.md +++ b/haddock-library/CHANGES.md @@ -2,7 +2,7 @@ * to be released - * Bifunctor instance for DocH + * Bifunctor, Bifoldable and Bitraversable instances for DocH and MetaDoc ## Changes in version 1.4.5 diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 22cab425..48b29075 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -24,6 +24,11 @@ import Control.Arrow ((***)) import Data.Bifunctor #endif +#if MIN_VERSION_base(4,10,0) +import Data.Bifoldable +import Data.Bitraversable +#endif + -- | With the advent of 'Version', we may want to start attaching more -- meta-data to comments. We make a structure for this ahead of time -- so we don't have to gut half the core each time we want to add such @@ -35,6 +40,19 @@ data MetaDoc mod id = , _doc :: DocH mod id } deriving (Eq, Show, Functor, Foldable, Traversable) +#if MIN_VERSION_base(4,8,0) +instance Bifunctor MetaDoc where + bimap f g (MetaDoc m d) = MetaDoc m (bimap f g d) +#endif + +#if MIN_VERSION_base(4,10,0) +instance Bifoldable MetaDoc where + bifoldr f g z d = bifoldr f g z (_doc d) + +instance Bitraversable MetaDoc where + bitraverse f g (MetaDoc m d) = MetaDoc m <$> bitraverse f g d +#endif + overDoc :: (DocH a b -> DocH c d) -> MetaDoc a b -> MetaDoc c d overDoc f d = d { _doc = f $ _doc d } @@ -113,6 +131,49 @@ instance Bifunctor DocH where bimap f g (DocHeader (Header level title)) = DocHeader (Header level (bimap f g title)) #endif +#if MIN_VERSION_base(4,10,0) +instance Bifoldable DocH where + bifoldr f g z (DocAppend docA docB) = bifoldr f g (bifoldr f g z docA) docB + bifoldr f g z (DocParagraph doc) = bifoldr f g z doc + bifoldr _ g z (DocIdentifier i) = g i z + bifoldr f _ z (DocIdentifierUnchecked m) = f m z + bifoldr f g z (DocWarning doc) = bifoldr f g z doc + bifoldr f g z (DocEmphasis doc) = bifoldr f g z doc + bifoldr f g z (DocMonospaced doc) = bifoldr f g z doc + bifoldr f g z (DocBold doc) = bifoldr f g z doc + bifoldr f g z (DocUnorderedList docs) = foldr (flip (bifoldr f g)) z docs + bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z docs + bifoldr f g z (DocDefList docs) = foldr (\(l, r) acc -> bifoldr f g (bifoldr f g acc l) r) z docs + bifoldr f g z (DocCodeBlock doc) = bifoldr f g z doc + bifoldr f g z (DocHeader (Header _ title)) = bifoldr f g z title + bifoldr _ _ z _ = z + +instance Bitraversable DocH where + bitraverse _ _ DocEmpty = pure DocEmpty + bitraverse f g (DocAppend docA docB) = DocAppend <$> bitraverse f g docA <*> bitraverse f g docB + bitraverse _ _ (DocString s) = pure (DocString s) + bitraverse f g (DocParagraph doc) = DocParagraph <$> bitraverse f g doc + bitraverse _ g (DocIdentifier i) = DocIdentifier <$> g i + bitraverse f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked <$> f m + bitraverse _ _ (DocModule s) = pure (DocModule s) + bitraverse f g (DocWarning doc) = DocWarning <$> bitraverse f g doc + bitraverse f g (DocEmphasis doc) = DocEmphasis <$> bitraverse f g doc + bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc + bitraverse f g (DocBold doc) = DocBold <$> bitraverse f g doc + bitraverse f g (DocUnorderedList docs) = DocUnorderedList <$> traverse (bitraverse f g) docs + bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs + bitraverse f g (DocDefList docs) = DocDefList <$> traverse (bitraverse (bitraverse f g) (bitraverse f g)) docs + bitraverse f g (DocCodeBlock doc) = DocCodeBlock <$> bitraverse f g doc + bitraverse _ _ (DocHyperlink hyperlink) = pure (DocHyperlink hyperlink) + bitraverse _ _ (DocPic picture) = pure (DocPic picture) + bitraverse _ _ (DocMathInline s) = pure (DocMathInline s) + bitraverse _ _ (DocMathDisplay s) = pure (DocMathDisplay s) + bitraverse _ _ (DocAName s) = pure (DocAName s) + bitraverse _ _ (DocProperty s) = pure (DocProperty s) + bitraverse _ _ (DocExamples examples) = pure (DocExamples examples) + bitraverse f g (DocHeader (Header level title)) = (DocHeader . Header level) <$> bitraverse f g title +#endif + -- | 'DocMarkupH' is a set of instructions for marking up documentation. -- In fact, it's really just a mapping from 'Doc' to some other -- type [a], where [a] is usually the type of the output (HTML, say). -- cgit v1.2.3 From f7032e5e48c7a6635e1dca607a37a16c8893e94b Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Wed, 16 Aug 2017 09:06:40 +0200 Subject: Refactoring: Make doc renaming monadic This allows us to later throw warnings if can't find an identifier --- haddock-api/src/Haddock/Interface/Create.hs | 127 ++++++++++++--------- haddock-api/src/Haddock/Interface/LexParseRn.hs | 81 ++++++------- haddock-library/src/Documentation/Haddock/Types.hs | 3 + 3 files changed, 116 insertions(+), 95 deletions(-) (limited to 'haddock-library/src/Documentation/Haddock') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 89f7f71b..87cdb01f 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -30,6 +30,7 @@ import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker +import Data.Bitraversable import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Map (Map) @@ -38,8 +39,6 @@ import Data.Maybe import Data.Monoid import Data.Ord import Control.Applicative -import Control.Arrow (second) -import Control.DeepSeq (force) import Control.Exception (evaluate) import Control.Monad import Data.Traversable @@ -109,7 +108,6 @@ createInterface tm flags modMap instIfaceMap = do exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 - warningMap = mkWarningMap dflags warnings gre exportedNames localBundledPatSyns :: Map Name [Name] localBundledPatSyns = @@ -134,8 +132,10 @@ createInterface tm flags modMap instIfaceMap = do -- Locations of all TH splices splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] - maps@(!docMap, !argMap, !subMap, !declMap, _) = - mkMaps dflags gre localInsts declsWithDocs + warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) + + maps@(!docMap, !argMap, !subMap, !declMap, _) <- + liftErrMsg (mkMaps dflags gre localInsts declsWithDocs) let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) @@ -161,7 +161,8 @@ createInterface tm flags modMap instIfaceMap = do let !aliases = mkAliasMap dflags $ tm_renamed_source tm - modWarn = moduleWarning dflags gre warnings + + modWarn <- liftErrMsg (moduleWarning dflags gre warnings) tokenizedSrc <- mkMaybeTokenizedSrc flags tm @@ -245,27 +246,29 @@ lookupModuleDyn dflags Nothing mdlName = -- Warnings ------------------------------------------------------------------------------- -mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap +mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap mkWarningMap dflags warnings gre exps = case warnings of - NoWarnings -> M.empty - WarnAll _ -> M.empty + NoWarnings -> pure M.empty + WarnAll _ -> pure M.empty WarnSome ws -> - let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ + let ws' = [ (n, w) + | (occ, w) <- ws + , elt <- lookupGlobalRdrEnv gre occ , let n = gre_name elt, n `elem` exps ] - in M.fromList $ map (second $ parseWarning dflags gre) ws' + in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' -moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name) -moduleWarning _ _ NoWarnings = Nothing -moduleWarning _ _ (WarnSome _) = Nothing -moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w +moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name)) +moduleWarning _ _ NoWarnings = pure Nothing +moduleWarning _ _ (WarnSome _) = pure Nothing +moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w -parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name -parseWarning dflags gre w = force $ case w of +parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name) +parseWarning dflags gre w = case w of DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg) WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) - . processDocString dflags gre $ HsDocString xs + <$> processDocString dflags gre (HsDocString xs) ------------------------------------------------------------------------------- @@ -313,16 +316,15 @@ mkMaps :: DynFlags -> GlobalRdrEnv -> [Name] -> [(LHsDecl Name, [HsDocString])] - -> Maps -mkMaps dflags gre instances decls = - let - (a, b, c, d) = unzip4 $ map mappings decls - in ( f' (map (nubByName fst) a) - , f (filterMapping (not . M.null) b) - , f (filterMapping (not . null) c) - , f (filterMapping (not . null) d) - , instanceMap - ) + -> ErrMsgM Maps +mkMaps dflags gre instances decls = do + (a, b, c, d) <- unzip4 <$> traverse mappings decls + pure ( f' (map (nubByName fst) a) + , f (filterMapping (not . M.null) b) + , f (filterMapping (not . null) c) + , f (filterMapping (not . null) d) + , instanceMap + ) where f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat @@ -334,35 +336,42 @@ mkMaps dflags gre instances decls = filterMapping p = map (filter (p . snd)) mappings :: (LHsDecl Name, [HsDocString]) - -> ( [(Name, MDoc Name)] - , [(Name, Map Int (MDoc Name))] - , [(Name, [Name])] - , [(Name, [LHsDecl Name])] - ) - mappings (ldecl, docStrs) = + -> ErrMsgM ( [(Name, MDoc Name)] + , [(Name, Map Int (MDoc Name))] + , [(Name, [Name])] + , [(Name, [LHsDecl Name])] + ) + mappings (ldecl, docStrs) = do let L l decl = ldecl declDoc :: [HsDocString] -> Map Int HsDocString - -> (Maybe (MDoc Name), Map Int (MDoc Name)) - declDoc strs m = - let doc' = processDocStrings dflags gre strs - m' = M.map (processDocStringParas dflags gre) m - in (doc', m') - (doc, args) = declDoc docStrs (typeDocs decl) + -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name)) + declDoc strs m = do + doc' <- processDocStrings dflags gre strs + m' <- traverse (processDocStringParas dflags gre) m + pure (doc', m') + + (doc, args) <- declDoc docStrs (typeDocs decl) + + let subs :: [(Name, [HsDocString], Map Int HsDocString)] subs = subordinates instanceMap decl - (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs + + (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs + + let ns = names l decl subNs = [ n | (n, _, _) <- subs ] dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] am = [ (n, args) | n <- ns ] ++ zip subNs subArgs sm = [ (n, subNs) | n <- ns ] cm = [ (n, [ldecl]) | n <- ns ++ subNs ] - in seqList ns `seq` - seqList subNs `seq` - doc `seq` - seqList subDocs `seq` - seqList subArgs `seq` - (dm, am, sm, cm) + + seqList ns `seq` + seqList subNs `seq` + doc `seq` + seqList subDocs `seq` + seqList subArgs `seq` + pure (dm, am, sm, cm) instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] @@ -602,16 +611,20 @@ mkExportItems -- do so. -- NB: Pass in identity module, so we can look it up in index correctly moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices - lookupExport (IEGroup lev docStr) = return $ - return . ExportGroup lev "" $ processDocString dflags gre docStr + lookupExport (IEGroup lev docStr) = liftErrMsg $ do + doc <- processDocString dflags gre docStr + return [ExportGroup lev "" doc] - lookupExport (IEDoc docStr) = return $ - return . ExportDoc $ processDocStringParas dflags gre docStr + lookupExport (IEDoc docStr) = liftErrMsg $ do + doc <- processDocStringParas dflags gre docStr + return [ExportDoc doc] lookupExport (IEDocNamed str) = liftErrMsg $ - findNamedDoc str [ unL d | d <- decls ] >>= return . \case - Nothing -> [] - Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc + findNamedDoc str [ unL d | d <- decls ] >>= \case + Nothing -> return [] + Just docStr -> do + doc <- processDocStringParas dflags gre docStr + return [ExportDoc doc] declWith :: [(HsDecl Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ] declWith pats t = do @@ -924,9 +937,11 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) mkExportItem (L _ (DocD (DocGroup lev docStr))) = do - return . Just . ExportGroup lev "" $ processDocString dflags gre docStr + doc <- liftErrMsg (processDocString dflags gre docStr) + return . Just . ExportGroup lev "" $ doc mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do - return . Just . ExportDoc $ processDocStringParas dflags gre docStr + doc <- liftErrMsg (processDocStringParas dflags gre docStr) + return . Just . ExportDoc $ doc mkExportItem (L l (ValD d)) | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 4f6b2c09..a38e7667 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -34,20 +34,21 @@ import RdrName import RnEnv (dataTcOccs) processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] - -> Maybe (MDoc Name) -processDocStrings dflags gre strs = - case metaDocConcat $ map (processDocStringParas dflags gre) strs of + -> ErrMsgM (Maybe (MDoc Name)) +processDocStrings dflags gre strs = do + mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags gre) strs + case mdoc of -- We check that we don't have any version info to render instead -- of just checking if there is no comment: there may not be a -- comment but we still want to pass through any meta data. - MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing - x -> Just x + MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> pure Nothing + x -> pure (Just x) -processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name +processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) processDocStringParas dflags gre (HsDocString fs) = - overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs) + overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs) -processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name +processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) processDocString dflags gre (HsDocString fs) = rename dflags gre $ parseString dflags (unpackFS fs) @@ -60,9 +61,11 @@ processModuleHeader dflags gre safety mayStr = do Just (L _ (HsDocString fs)) -> do let str = unpackFS fs (hmi, doc) = parseModuleHeader dflags str - !descr = rename dflags gre <$> hmi_description hmi - hmi' = hmi { hmi_description = descr } - doc' = overDoc (rename dflags gre) doc + !descr <- case hmi_description hmi of + Just hmi_descr -> Just <$> rename dflags gre hmi_descr + Nothing -> pure Nothing + let hmi' = hmi { hmi_description = descr } + doc' <- overDocF (rename dflags gre) doc return (hmi', Just doc') let flags :: [LangExt.Extension] @@ -82,12 +85,12 @@ processModuleHeader dflags gre safety mayStr = do -- fallbacks in case we can't locate the identifiers. -- -- See the comments in the source for implementation commentary. -rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name +rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name) rename dflags gre = rn where rn d = case d of - DocAppend a b -> DocAppend (rn a) (rn b) - DocParagraph doc -> DocParagraph (rn doc) + DocAppend a b -> DocAppend <$> rn a <*> rn b + DocParagraph doc -> DocParagraph <$> rn doc DocIdentifier x -> do -- Generate the choices for the possible kind of thing this -- is. @@ -100,7 +103,7 @@ rename dflags gre = rn -- We found no names in the env so we start guessing. [] -> case choices of - [] -> DocMonospaced (DocString (showPpr dflags x)) + [] -> pure (DocMonospaced (DocString (showPpr dflags x))) -- There was nothing in the environment so we need to -- pick some default from what's available to us. We -- diverge here from the old way where we would default @@ -109,37 +112,37 @@ rename dflags gre = rn -- type constructor names (such as in #253). So now we -- only get type constructor links if they are actually -- in scope. - a:_ -> outOfScope dflags a + a:_ -> pure (outOfScope dflags a) -- There is only one name in the environment that matches so -- use it. - [a] -> DocIdentifier a + [a] -> pure (DocIdentifier a) -- But when there are multiple names available, default to -- type constructors: somewhat awfully GHC returns the -- values in the list positionally. - a:b:_ | isTyConName a -> DocIdentifier a - | otherwise -> DocIdentifier b + a:b:_ | isTyConName a -> pure (DocIdentifier a) + | otherwise -> pure (DocIdentifier b) - DocWarning doc -> DocWarning (rn doc) - DocEmphasis doc -> DocEmphasis (rn doc) - DocBold doc -> DocBold (rn doc) - DocMonospaced doc -> DocMonospaced (rn doc) - DocUnorderedList docs -> DocUnorderedList (map rn docs) - DocOrderedList docs -> DocOrderedList (map rn docs) - DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ] - DocCodeBlock doc -> DocCodeBlock (rn doc) - DocIdentifierUnchecked x -> DocIdentifierUnchecked x - DocModule str -> DocModule str - DocHyperlink l -> DocHyperlink l - DocPic str -> DocPic str - DocMathInline str -> DocMathInline str - DocMathDisplay str -> DocMathDisplay str - DocAName str -> DocAName str - DocProperty p -> DocProperty p - DocExamples e -> DocExamples e - DocEmpty -> DocEmpty - DocString str -> DocString str - DocHeader (Header l t) -> DocHeader $ Header l (rn t) + DocWarning doc -> DocWarning <$> rn doc + DocEmphasis doc -> DocEmphasis <$> rn doc + DocBold doc -> DocBold <$> rn doc + DocMonospaced doc -> DocMonospaced <$> rn doc + DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs + DocOrderedList docs -> DocOrderedList <$> traverse rn docs + DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list + DocCodeBlock doc -> DocCodeBlock <$> rn doc + DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x) + DocModule str -> pure (DocModule str) + DocHyperlink l -> pure (DocHyperlink l) + DocPic str -> pure (DocPic str) + DocMathInline str -> pure (DocMathInline str) + DocMathDisplay str -> pure (DocMathDisplay str) + DocAName str -> pure (DocAName str) + DocProperty p -> pure (DocProperty p) + DocExamples e -> pure (DocExamples e) + DocEmpty -> pure (DocEmpty) + DocString str -> pure (DocString str) + DocHeader (Header l t) -> DocHeader . Header l <$> rn t -- | Wrap an identifier that's out of scope (i.e. wasn't found in -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 48b29075..1e76c631 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -56,6 +56,9 @@ instance Bitraversable MetaDoc where overDoc :: (DocH a b -> DocH c d) -> MetaDoc a b -> MetaDoc c d overDoc f d = d { _doc = f $ _doc d } +overDocF :: Functor f => (DocH a b -> f (DocH c d)) -> MetaDoc a b -> f (MetaDoc c d) +overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d) + type Version = [Int] data Hyperlink = Hyperlink -- cgit v1.2.3