aboutsummaryrefslogtreecommitdiff
path: root/haddock-library/src
diff options
context:
space:
mode:
authoralexbiehl <alex.biehl@gmail.com>2017-08-21 20:05:42 +0200
committeralexbiehl <alex.biehl@gmail.com>2017-08-21 20:05:42 +0200
commit7a71af839bd71992a36d97650004c73bf11fa436 (patch)
treee64afbc9df5c97fde6ac6433e42f28df8a4acf49 /haddock-library/src
parentc8a01b83be52e45d3890db173ffe7b09ccd4f351 (diff)
parent740458ac4d2acf197f2ef8dc94a66f9b160b9c3c (diff)
Merge remote-tracking branch 'origin/master' into ghc-head
Diffstat (limited to 'haddock-library/src')
-rw-r--r--haddock-library/src/Documentation/Haddock/Markup.hs63
-rw-r--r--haddock-library/src/Documentation/Haddock/Parser.hs23
-rw-r--r--haddock-library/src/Documentation/Haddock/Parser/Util.hs9
-rw-r--r--haddock-library/src/Documentation/Haddock/Types.hs134
4 files changed, 216 insertions, 13 deletions
diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs
new file mode 100644
index 00000000..1bf6c084
--- /dev/null
+++ b/haddock-library/src/Documentation/Haddock/Markup.hs
@@ -0,0 +1,63 @@
+-- | @since 1.4.5
+module Documentation.Haddock.Markup (
+ markup
+ , idMarkup
+ ) 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/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs
index 123f5612..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
@@ -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
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index 4d5bb68a..1e76c631 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,20 @@
-- 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
+
+#if MIN_VERSION_base(4,8,0)
+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
@@ -28,9 +40,25 @@ 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 }
+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
@@ -78,3 +106,107 @@ data DocH mod id
| DocExamples [Example]
| 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
+
+#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).
+-- 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
+ , 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
+ }