haddock-library 1.4.5 → 1.5.0.1

raw patch · 9 files changed

+614/−37 lines, 9 filesdep +containersdep +directorydep +filepathdep ~QuickCheckdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: containers, directory, filepath, optparse-applicative, tree-diff

Dependency ranges changed: QuickCheck, base

API changes (from Hackage documentation)

Files

• CHANGES.md +13/−0
• fixtures/Fixtures.hs +162/−0
• haddock-library.cabal +33/−7
• src/Documentation/Haddock/Markup.hs +3/−1
• src/Documentation/Haddock/Parser.hs +232/−27
• src/Documentation/Haddock/Parser/Monad.hs +22/−1
• src/Documentation/Haddock/Types.hs +117/−1
• test/Documentation/Haddock/ParserSpec.hs +2/−0
• vendor/attoparsec-0.13.1.0/LICENSE +30/−0

@@ -1,3 +1,16 @@+## Changes in version 1.5.0.1++ * Support for parsing unicode operators (#458)++## Changes in version 1.5.0++ * Bifunctor, Bifoldable and Bitraversable instances for DocH and MetaDoc++ * Support for grid tables+   * added `DocTable` constructor to `DocH`+   * added `Table`, `TableCell` and `TableRow` data types+   * added `markupTable` to `DocMarkupH` data type+ ## Changes in version 1.4.5   * Move markup related data types to haddock-library

@@ -0,0 +1,162 @@+{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main (main) where++import Control.Applicative ((<|>))+import Control.Exception (IOException, catch)+import Control.Monad (when)+import Data.Foldable (traverse_)+import Data.List (foldl')+import Data.Traversable (for)+import GHC.Generics (Generic)+import Prelude ()+import Prelude.Compat+import System.Directory (getDirectoryContents)+import System.Exit (exitFailure)+import System.FilePath++import Data.TreeDiff+import Data.TreeDiff.Golden++import qualified Options.Applicative as O++import           Documentation.Haddock.Types+import qualified Documentation.Haddock.Parser as Parse++type Doc id = DocH () id++data Fixture = Fixture+    { fixtureName   :: FilePath+    , fixtureOutput :: FilePath+    }+  deriving Show++data  Result = Result+    { _resultSuccess :: !Int+    , _resultTotal   :: !Int+    }+  deriving Show++combineResults :: Result -> Result -> Result+combineResults (Result s t) (Result s' t') = Result (s + s') (t + t')++readFixtures :: IO [Fixture]+readFixtures = do+    let dir = "fixtures/examples"+    files <- getDirectoryContents dir+    let inputs = filter (\fp -> takeExtension fp == ".input") files+    return $ flip map inputs $ \fp -> Fixture+        { fixtureName = dir </> fp+        , fixtureOutput = dir </> fp -<.> "parsed"+        }++goldenFixture+    :: String+    -> IO Expr+    -> IO Expr+    -> (Expr -> Expr -> IO (Maybe String))+    -> (Expr -> IO ())+    -> IO Result+goldenFixture name expect actual cmp wrt = do+    putStrLn $ "running " ++ name+    a <- actual+    e <- expect `catch` handler a+    mres <- cmp e a+    case mres of+        Nothing  -> return (Result 1 1)+        Just str -> do+            putStr str+            return (Result 0 1)+  where+    handler :: Expr -> IOException -> IO Expr+    handler a exc = do+        putStrLn $ "Caught " ++ show exc+        putStrLn "Accepting the test"+        wrt a+        return a++runFixtures :: [Fixture] -> IO ()+runFixtures fixtures = do+    results <- for fixtures $ \(Fixture i o) -> do+        let name = takeBaseName i+        let readDoc = do+                input <- readFile i+                return (parseString input)+        ediffGolden goldenFixture name o readDoc+    case foldl' combineResults (Result 0 0) results of+        Result s t -> do+            putStrLn $ "Fixtures: success " ++ show s ++ "; total " ++ show t+            when (s /= t) exitFailure++listFixtures :: [Fixture] -> IO ()+listFixtures = traverse_ $ \(Fixture i _) -> do+    let name = takeBaseName i+    putStrLn name++acceptFixtures :: [Fixture] -> IO ()+acceptFixtures = traverse_ $ \(Fixture i o) -> do+    input <- readFile i+    let doc = parseString input+    let actual = show (prettyExpr $ toExpr doc) ++ "\n"+    writeFile o actual++parseString :: String -> Doc String+parseString = Parse.toRegular . _doc . Parse.parseParas++data Cmd = CmdRun | CmdAccept | CmdList++main :: IO ()+main = runCmd =<< O.execParser opts+  where+    opts = O.info (O.helper <*> cmdParser) O.fullDesc++    cmdParser :: O.Parser Cmd+    cmdParser = cmdRun <|> cmdAccept <|> cmdList <|> pure CmdRun++    cmdRun = O.flag' CmdRun $ mconcat+        [ O.long "run"+        , O.help "Run parser fixtures"+        ]++    cmdAccept = O.flag' CmdAccept $ mconcat+        [ O.long "accept"+        , O.help "Run & accept parser fixtures"+        ]++    cmdList = O.flag' CmdList $ mconcat+        [ O.long "list"+        , O.help "List fixtures"+        ]++runCmd :: Cmd -> IO ()+runCmd CmdRun    = readFixtures >>= runFixtures+runCmd CmdList   = readFixtures >>= listFixtures+runCmd CmdAccept = readFixtures >>= acceptFixtures++-------------------------------------------------------------------------------+-- Orphans+-------------------------------------------------------------------------------++deriving instance Generic (DocH mod id)+instance (ToExpr mod, ToExpr id)  => ToExpr (DocH mod id)++deriving instance Generic (Header id)+instance ToExpr id => ToExpr (Header id)++deriving instance Generic Hyperlink+instance ToExpr Hyperlink++deriving instance Generic Picture+instance ToExpr Picture++deriving instance Generic Example+instance ToExpr Example++deriving instance Generic (Table id)+instance ToExpr id => ToExpr (Table id)++deriving instance Generic (TableRow id)+instance ToExpr id => ToExpr (TableRow id)++deriving instance Generic (TableCell id)+instance ToExpr id => ToExpr (TableCell id)

@@ -1,5 +1,6 @@+cabal-version:        2.0 name:                 haddock-library-version:              1.4.5+version:              1.5.0.1 synopsis:             Library exposing some functionality of Haddock. description:          Haddock is a documentation-generation tool for Haskell                       libraries. These modules expose some functionality of it@@ -8,21 +9,23 @@                       project if you can't release often. For interacting with Haddock                       itself, see the ‘haddock’ package. license:              BSD3-license-file:         LICENSE+license-files:        LICENSE+                      vendor/attoparsec-0.13.1.0/LICENSE maintainer:           Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> homepage:             http://www.haskell.org/haddock/ 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    build-depends:-      base         >= 4.5     && < 4.11+      base         >= 4.5     && < 4.12     , bytestring   >= 0.9.2.1 && < 0.11+    , containers   >= 0.4.2.1 && < 0.6     , transformers >= 0.3.0   && < 0.6    -- internal sub-lib@@ -50,7 +53,7 @@   default-language:     Haskell2010    build-depends:-      base         >= 4.5     && < 4.11+      base         >= 4.5     && < 4.12     , bytestring   >= 0.9.2.1 && < 0.11     , deepseq      >= 1.3     && < 1.5 @@ -61,13 +64,13 @@   exposed-modules:     Data.Attoparsec.ByteString     Data.Attoparsec.ByteString.Char8+    Data.Attoparsec.Combinator    other-modules:     Data.Attoparsec     Data.Attoparsec.ByteString.Buffer     Data.Attoparsec.ByteString.FastSet     Data.Attoparsec.ByteString.Internal-    Data.Attoparsec.Combinator     Data.Attoparsec.Internal     Data.Attoparsec.Internal.Fhthagn     Data.Attoparsec.Internal.Types@@ -107,9 +110,10 @@    build-depends:       base-compat   ^>= 0.9.3+    , containers   >= 0.4.2.1 && < 0.6     , transformers   >= 0.3.0   && < 0.6     , hspec         ^>= 2.4.4-    , QuickCheck    ^>= 2.10+    , QuickCheck    ^>= 2.11    -- internal sub-lib   build-depends: attoparsec@@ -123,6 +127,28 @@    build-tool-depends:     hspec-discover:hspec-discover ^>= 2.4.4++test-suite fixtures+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  main-is:          Fixtures.hs+  ghc-options:      -Wall+  hs-source-dirs:   fixtures+  build-depends:+      base-compat           ^>= 0.9.3+    , directory             ^>= 1.3.0.2+    , filepath              ^>= 1.4.1.2+    , optparse-applicative  ^>= 0.14.0.0+    , tree-diff             ^>= 0.0.0.1++  -- Depend on the library.+  build-depends:+    haddock-library++  -- Versions for the dependencies below are transitively pinned by+  -- dependency on haddock-library:lib:attoparsec+  build-depends:+      base  source-repository head   type:     git

@@ -30,6 +30,7 @@ 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))+markup m (DocTable (Table h b))      = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b))  markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a) markupPair m (a,b) = (markup m a, markup m b)@@ -59,5 +60,6 @@   markupMathDisplay          = DocMathDisplay,   markupProperty             = DocProperty,   markupExample              = DocExamples,-  markupHeader               = DocHeader+  markupHeader               = DocHeader,+  markupTable                = DocTable   }

@@ -1,5 +1,6 @@+{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ViewPatterns      #-} -- | -- Module      :  Documentation.Haddock.Parser -- Copyright   :  (c) Mateusz Kowalczyk 2013-2014,@@ -23,20 +24,47 @@ import           Control.Arrow (first) import           Control.Monad import qualified Data.ByteString.Char8 as BS-import           Data.Char (chr, isAsciiUpper)-import           Data.List (stripPrefix, intercalate, unfoldr)-import           Data.Maybe (fromMaybe)+import           Data.Char (chr, isUpper, isAlpha, isAlphaNum)+import           Data.List (stripPrefix, intercalate, unfoldr, elemIndex)+import           Data.Maybe (fromMaybe, mapMaybe) import           Data.Monoid+import qualified Data.Set as Set import           Documentation.Haddock.Doc import           Documentation.Haddock.Parser.Monad hiding (take, endOfLine) import           Documentation.Haddock.Parser.Util import           Documentation.Haddock.Types import           Documentation.Haddock.Utf8 import           Prelude hiding (takeWhile)+import qualified Prelude as P +#if MIN_VERSION_base(4,9,0)+import           Text.Read.Lex                      (isSymbolChar)+#else+import           Data.Char                          (GeneralCategory (..),+                                                     generalCategory)+#endif+ -- $setup -- >>> :set -XOverloadedStrings +#if !MIN_VERSION_base(4,9,0)+-- inlined from base-4.10.0.0+isSymbolChar :: Char -> Bool+isSymbolChar c = not (isPuncChar c) && case generalCategory c of+    MathSymbol           -> True+    CurrencySymbol       -> True+    ModifierSymbol       -> True+    OtherSymbol          -> True+    DashPunctuation      -> True+    OtherPunctuation     -> not (c `elem` ("'\"" :: String))+    ConnectorPunctuation -> c /= '_'+    _                    -> False+  where+    -- | The @special@ character class as defined in the Haskell Report.+    isPuncChar :: Char -> Bool+    isPuncChar = (`elem` (",;()[]{}`" :: String))+#endif+ -- | Identifier string surrounded with opening and closing quotes/backticks. type Identifier = (Char, String, Char) @@ -79,6 +107,7 @@     g (DocProperty x) = DocProperty x     g (DocExamples x) = DocExamples x     g (DocHeader (Header l x)) = DocHeader . Header l $ g x+    g (DocTable (Table h b)) = DocTable (Table (map (fmap g) h) (map (fmap g) b))  parse :: Parser a -> BS.ByteString -> (ParserState, a) parse p = either err id . parseOnly (p <* endOfInput)@@ -202,21 +231,20 @@ monospace = DocMonospaced . parseStringBS             <$> ("@" *> takeWhile1_ (/= '@') <* "@") --- | Module names: we try our reasonable best to only allow valid--- Haskell module names, with caveat about not matching on technically--- valid unicode symbols.+-- | Module names.+--+-- Note that we allow '#' and '\' to support anchors (old style anchors are of+-- the form "SomeModule\#anchor"). moduleName :: Parser (DocH mod a) moduleName = DocModule <$> (char '"' *> modid <* char '"')   where     modid = intercalate "." <$> conid `sepBy1` "."     conid = (:)-      <$> satisfy isAsciiUpper-      -- NOTE: According to Haskell 2010 we should actually only-      -- 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 (notInClass " .&[{}(=*)+]!|@/;,^?\"\n"))+      <$> satisfyUnicode (\c -> isAlpha c && isUpper c)+      <*> many (satisfyUnicode conChar <|> char '\\' <|> char '#') +    conChar c = isAlphaNum c || c == '_'+ -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture. --@@ -251,7 +279,7 @@  -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier)-paragraph = examples <|> do+paragraph = examples <|> table <|> do   indent <- takeIndent   choice     [ since@@ -266,6 +294,193 @@     , docParagraph <$> textParagraph     ] +-- | Provides support for grid tables.+--+-- Tables are composed by an optional header and body. The header is composed by+-- a single row. The body is composed by a non-empty list of rows.+--+-- Example table with header:+--+-- > +----------+----------++-- > | /32bit/  |   64bit  |+-- > +==========+==========++-- > |  0x0000  | @0x0000@ |+-- > +----------+----------++--+-- Algorithms loosely follows ideas in+-- http://docutils.sourceforge.net/docutils/parsers/rst/tableparser.py+--+table :: Parser (DocH mod Identifier)+table = do+    -- first we parse the first row, which determines the width of the table+    firstRow <- parseFirstRow+    let len = BS.length firstRow++    -- then we parse all consequtive rows starting and ending with + or |,+    -- of the width `len`.+    restRows <- many (parseRestRows len)++    -- Now we gathered the table block, the next step is to split the block+    -- into cells.+    DocTable <$> tableStepTwo len (firstRow : restRows)+  where+    parseFirstRow :: Parser BS.ByteString+    parseFirstRow = do+        skipHorizontalSpace+        -- upper-left corner is ++        c <- char '+'+        cs <- many1 (char '-' <|> char '+')++        -- upper right corner is + too+        guard (last cs == '+')++        -- trailing space+        skipHorizontalSpace+        _ <- char '\n'++        return (BS.cons c $ BS.pack cs)++    parseRestRows :: Int -> Parser BS.ByteString+    parseRestRows l = do+        skipHorizontalSpace++        c <- char '|' <|> char '+'+        bs <- scan (l - 2) predicate+        c2 <- char '|' <|> char '+'++        -- trailing space+        skipHorizontalSpace+        _ <- char '\n'++        return (BS.cons c (BS.snoc bs c2))+      where+        predicate n c+            | n <= 0    = Nothing+            | c == '\n' = Nothing+            | otherwise = Just (n - 1)++-- Second step searchs for row of '+' and '=' characters, records it's index+-- and changes to '=' to '-'.+tableStepTwo+    :: Int              -- ^ width+    -> [BS.ByteString]  -- ^ rows+    -> Parser (Table (DocH mod Identifier))+tableStepTwo width = go 0 [] where+    go _ left [] = tableStepThree width (reverse left) Nothing+    go n left (r : rs)+        | BS.all (`elem` ['+', '=']) r =+            tableStepThree width (reverse left ++ r' : rs) (Just n)+        | otherwise =+            go (n + 1) (r :  left) rs+      where+        r' = BS.map (\c -> if c == '=' then '-' else c) r++-- Third step recognises cells in the table area, returning a list of TC, cells.+tableStepThree+    :: Int              -- ^ width+    -> [BS.ByteString]  -- ^ rows+    -> Maybe Int        -- ^ index of header separator+    -> Parser (Table (DocH mod Identifier))+tableStepThree width rs hdrIndex = do+    cells <- loop (Set.singleton (0, 0))+    tableStepFour rs hdrIndex cells+  where+    height = length rs++    loop :: Set.Set (Int, Int) -> Parser [TC]+    loop queue = case Set.minView queue of+        Nothing -> return []+        Just ((y, x), queue')+            | y + 1 >= height || x + 1 >= width -> loop queue'+            | otherwise -> case scanRight x y of+                Nothing -> loop queue'+                Just (x2, y2) -> do+                    let tc = TC y x y2 x2+                    fmap (tc :) $ loop $ queue' `Set.union` Set.fromList+                        [(y, x2), (y2, x), (y2, x2)]++    -- scan right looking for +, then try scan down+    --+    -- do we need to record + saw on the way left and down?+    scanRight :: Int -> Int -> Maybe (Int, Int)+    scanRight x y = go (x + 1) where+        bs = rs !! y+        go x' | x' >= width           = fail "overflow right "+              | BS.index bs x' == '+' = scanDown x y x' <|> go (x' + 1)+              | BS.index bs x' == '-' = go (x' + 1)+              | otherwise             = fail $ "not a border (right) " ++ show (x,y,x')++    -- scan down looking for ++    scanDown :: Int -> Int -> Int -> Maybe (Int, Int)+    scanDown x y x2 = go (y + 1) where+        go y' | y' >= height                  = fail "overflow down"+              | BS.index (rs !! y') x2 == '+' = scanLeft x y x2 y' <|> go (y' + 1)+              | BS.index (rs !! y') x2 == '|' = go (y' + 1)+              | otherwise                     = fail $ "not a border (down) " ++ show (x,y,x2,y')++    -- check that at y2 x..x2 characters are '+' or '-'+    scanLeft :: Int -> Int -> Int -> Int -> Maybe (Int, Int)+    scanLeft x y x2 y2+        | all (\x' -> BS.index bs x' `elem` ['+', '-']) [x..x2] = scanUp x y x2 y2+        | otherwise                                             = fail $ "not a border (left) " ++ show (x,y,x2,y2)+      where+        bs = rs !! y2++    -- check that at y2 x..x2 characters are '+' or '-'+    scanUp :: Int -> Int -> Int -> Int -> Maybe (Int, Int)+    scanUp x y x2 y2+        | all (\y' -> BS.index (rs !! y') x `elem` ['+', '|']) [y..y2] = return (x2, y2)+        | otherwise                                                    = fail $ "not a border (up) " ++ show (x,y,x2,y2)++-- | table cell: top left bottom right+data TC = TC !Int !Int !Int !Int+  deriving Show++tcXS :: TC -> [Int]+tcXS (TC _ x _ x2) = [x, x2]++tcYS :: TC -> [Int]+tcYS (TC y _ y2 _) = [y, y2]++-- | Fourth step. Given the locations of cells, forms 'Table' structure.+tableStepFour :: [BS.ByteString] -> Maybe Int -> [TC] -> Parser (Table (DocH mod Identifier))+tableStepFour rs hdrIndex cells =  case hdrIndex of+    Nothing -> return $ Table [] rowsDoc+    Just i  -> case elemIndex i yTabStops of+        Nothing -> return $ Table [] rowsDoc+        Just i' -> return $ uncurry Table $ splitAt i' rowsDoc+  where+    xTabStops = sortNub $ concatMap tcXS cells+    yTabStops = sortNub $ concatMap tcYS cells++    sortNub :: Ord a => [a] -> [a]+    sortNub = Set.toList . Set.fromList++    init' :: [a] -> [a]+    init' []       = []+    init' [_]      = []+    init' (x : xs) = x : init' xs++    rowsDoc = (fmap . fmap) parseStringBS rows++    rows = map makeRow (init' yTabStops)+      where+        makeRow y = TableRow $ mapMaybe (makeCell y) cells+        makeCell y (TC y' x y2 x2)+            | y /= y' = Nothing+            | otherwise = Just $ TableCell xts yts (extract (x + 1) (y + 1) (x2 - 1) (y2 - 1))+          where+            xts = length $ P.takeWhile (< x2) $ dropWhile (< x) xTabStops+            yts = length $ P.takeWhile (< y2) $ dropWhile (< y) yTabStops++    -- extract cell contents given boundaries+    extract :: Int -> Int -> Int -> Int -> BS.ByteString+    extract x y x2 y2 = BS.intercalate "\n"+        [ BS.take (x2 - x + 1) $ BS.drop x $ rs !! y'+        | y' <- [y .. y2]+        ]++-- | Parse \@since annotations. since :: Parser (DocH mod a) since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince >> return DocEmpty   where@@ -338,7 +553,7 @@ definitionList indent = DocDefList <$> p   where     p = do-      label <- "[" *> (parseStringBS <$> takeWhile1 (notInClass "]\n")) <* ("]" <* optional ":")+      label <- "[" *> (parseStringBS <$> takeWhile1_ (notInClass "]\n")) <* ("]" <* optional ":")       c <- takeLine       (cs, items) <- more indent p       let contents = parseString . dropNLs . unlines $ c : cs@@ -570,25 +785,15 @@ parseValid :: Parser String parseValid = p some   where-    idChar =-      satisfy (\c -> isAlpha_ascii c-                     || isDigit c-                     -- N.B. '-' is placed first otherwise attoparsec thinks-                     -- it belongs to a character class-                     || inClass "-_.!#$%&*+/<=>?@\\|~:^" c)+    idChar = satisfyUnicode (\c -> isAlphaNum c || isSymbolChar c || c == '_')      p p' = do-      vs' <- p' $ utf8String "⋆" <|> return <$> idChar-      let vs = concat vs'+      vs <- p' idChar       c <- peekChar'       case c of         '`' -> return vs         '\'' -> (\x -> vs ++ "'" ++ x) <$> ("'" *> p many') <|> return vs         _ -> fail "outofvalid"---- | Parses UTF8 strings from ByteString streams.-utf8String :: String -> Parser String-utf8String x = decodeUtf8 <$> string (encodeUtf8 x)  -- | Parses identifiers with help of 'parseValid'. Asks GHC for -- 'String' from the string it deems valid.

@@ -31,9 +31,10 @@ import           Control.Applicative import           Control.Monad import           Data.String-import           Data.ByteString (ByteString)+import           Data.ByteString (ByteString, length) import qualified Data.ByteString.Lazy as LB import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec+import qualified Data.Attoparsec.Combinator as Attoparsec import           Control.Monad.Trans.State import qualified Control.Monad.Trans.Class as Trans import           Data.Word@@ -41,6 +42,7 @@ import           Data.Tuple  import           Documentation.Haddock.Types (Version)+import           Documentation.Haddock.Utf8  (encodeUtf8, decodeUtf8)  newtype ParserState = ParserState {   parserStateSince :: Maybe Version@@ -72,6 +74,25 @@  char8 :: Char -> Parser Word8 char8 = lift . Attoparsec.char8++-- | Peek a unicode character and return the number of bytes that it took up+peekUnicode :: Parser (Char, Int)+peekUnicode = lift $ Attoparsec.lookAhead $ do+  +  -- attoparsec's take fails on shorter inputs rather than truncate+  bs <- Attoparsec.choice (map Attoparsec.take [4,3,2,1])+  +  let c = head . decodeUtf8 $ bs+      n = Data.ByteString.length . encodeUtf8 $ [c]+  pure (c, fromIntegral n)++-- | Like 'satisfy', but consuming a unicode character+satisfyUnicode :: (Char -> Bool) -> Parser Char+satisfyUnicode predicate = do+  (c,n) <- peekUnicode+  if predicate c+    then Documentation.Haddock.Parser.Monad.take n *> pure c+    else fail "satsifyUnicode"  anyChar :: Parser Char anyChar = lift Attoparsec.anyChar

@@ -15,10 +15,21 @@ module Documentation.Haddock.Types where  #if !MIN_VERSION_base(4,8,0)+import Control.Applicative 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 -- so we don't have to gut half the core each time we want to add such@@ -30,9 +41,25 @@           , _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@@ -55,6 +82,21 @@   , exampleResult     :: [String]   } deriving (Eq, Show) +data TableCell id = TableCell+  { tableCellColspan  :: Int+  , tableCellRowspan  :: Int+  , tableCellContents :: id+  } deriving (Eq, Show, Functor, Foldable, Traversable)++newtype TableRow id = TableRow+  { tableRowCells :: [TableCell id]+  } deriving (Eq, Show, Functor, Foldable, Traversable)++data Table id = Table+  { tableHeaderRows :: [TableRow id]+  , tableBodyRows   :: [TableRow id]+  } deriving (Eq, Show, Functor, Foldable, Traversable)+ data DocH mod id   = DocEmpty   | DocAppend (DocH mod id) (DocH mod id)@@ -79,8 +121,82 @@   | DocProperty String   | DocExamples [Example]   | DocHeader (Header (DocH mod id))+  | DocTable (Table (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))+  bimap f g (DocTable (Table header body)) = DocTable (Table (map (fmap (bimap f g)) header) (map (fmap (bimap f g)) body))+#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 f g z (DocTable (Table header body)) = foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) (foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) z body) header+  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+  bitraverse f g (DocTable (Table header body)) = (\h b -> DocTable (Table h b)) <$> traverse (traverse (bitraverse f g)) header <*> traverse (traverse (bitraverse f g)) body+#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).@@ -113,5 +229,5 @@   , markupProperty             :: String -> a   , markupExample              :: [Example] -> a   , markupHeader               :: Header a -> a+  , markupTable                :: Table a -> a   }-

@@ -10,6 +10,8 @@ import           Test.Hspec import           Test.QuickCheck +import           Prelude hiding ((<>))+ infixr 6 <> (<>) :: Doc id -> Doc id -> Doc id (<>) = docAppend

@@ -0,0 +1,30 @@+Copyright (c) Lennart Kolmodin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.