diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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 diff --git a/fixtures/Fixtures.hs b/fixtures/Fixtures.hs new file mode 100644 --- /dev/null +++ b/fixtures/Fixtures.hs @@ -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) diff --git a/haddock-library.cabal b/haddock-library.cabal --- a/haddock-library.cabal +++ b/haddock-library.cabal @@ -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 , Simon Hengel , Mateusz Kowalczyk 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 diff --git a/src/Documentation/Haddock/Markup.hs b/src/Documentation/Haddock/Markup.hs --- a/src/Documentation/Haddock/Markup.hs +++ b/src/Documentation/Haddock/Markup.hs @@ -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 } diff --git a/src/Documentation/Haddock/Parser.hs b/src/Documentation/Haddock/Parser.hs --- a/src/Documentation/Haddock/Parser.hs +++ b/src/Documentation/Haddock/Parser.hs @@ -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. diff --git a/src/Documentation/Haddock/Parser/Monad.hs b/src/Documentation/Haddock/Parser/Monad.hs --- a/src/Documentation/Haddock/Parser/Monad.hs +++ b/src/Documentation/Haddock/Parser/Monad.hs @@ -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 diff --git a/src/Documentation/Haddock/Types.hs b/src/Documentation/Haddock/Types.hs --- a/src/Documentation/Haddock/Types.hs +++ b/src/Documentation/Haddock/Types.hs @@ -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 } - diff --git a/test/Documentation/Haddock/ParserSpec.hs b/test/Documentation/Haddock/ParserSpec.hs --- a/test/Documentation/Haddock/ParserSpec.hs +++ b/test/Documentation/Haddock/ParserSpec.hs @@ -10,6 +10,8 @@ import Test.Hspec import Test.QuickCheck +import Prelude hiding ((<>)) + infixr 6 <> (<>) :: Doc id -> Doc id -> Doc id (<>) = docAppend diff --git a/vendor/attoparsec-0.13.1.0/LICENSE b/vendor/attoparsec-0.13.1.0/LICENSE new file mode 100644 --- /dev/null +++ b/vendor/attoparsec-0.13.1.0/LICENSE @@ -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.