Merge remote-tracking branch 'origin/master' into ghc-head

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
+  }