diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,34 @@ `jira-wiki-markup` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +1.0.0 +===== + +Released 2019-12-17. + +* Add `Doc` datatype representing a full document; `parse` now returns + this type. +* Improve parsing: + - double-backslash is recognized as linebreak; + - emoticons are parsed as `Emoji`; + - special sequences of dashes are translated into their unicode + representation; + - naked URLs are parsed as `AutoLink`; + - blocks of colored text are parsed as `Color`; + - interpretation of special characters as markup can be forced by + surrounding them with curly braces. +* A parser `plainText` was added available to read markup-less text. +* *Inline*-parser `symbol` was renamed to `specialChar`. +* Add printer module to render the document AST as Jira markup. +* Markup datatype changes: + - new *Block* elements `Color` and `HorizontalRule`. + - new *Inline* elements `Emoji`, and `Styled`. + - *Inline* constructors `Subscript`, `Superscript`, `Emph`, `Strong`, + `Inserted`, and `Deleted` have been remove. Use `Styled` instead. + - Constructor `Image` now takes a list of parameters as an additional + argument. +* CI runs also test GHC 8.8. + 0.1.1 ===== diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,9 +7,11 @@ [![Build status](https://travis-ci.com/tarleb/jira-wiki-markup.svg?branch=master)](https://travis-ci.com/tarleb/jira-wiki-markup) [![Windows build status](https://ci.appveyor.com/api/projects/status/github/tarleb/jira-wiki-markup?branch=master&svg=true)](https://ci.appveyor.com/project/tarleb/jira-wiki-markup) -This package provides a parser for [Jira wiki markup]. It converts the -raw text into an abstract syntax tree. The tree is easy to handle and to -different to different output formats. +This package provides a parser and printer for [Jira wiki markup]. It +converts the raw text into an abstract syntax tree. The tree is easy to +handle and to translate into different output formats. + +[Jira wiki markup]: https://jira.atlassian.com/secure/WikiRendererHelpAction.jspa?section=all # License diff --git a/jira-wiki-markup.cabal b/jira-wiki-markup.cabal --- a/jira-wiki-markup.cabal +++ b/jira-wiki-markup.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: jira-wiki-markup -version: 0.1.1 +version: 1.0.0 synopsis: Handle Jira wiki markup description: Parse jira wiki text into an abstract syntax tree for easy transformation to other formats. @@ -15,7 +15,11 @@ build-type: Simple extra-doc-files: README.md , CHANGELOG.md -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.4 +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.4 + , GHC == 8.8.1 source-repository head type: git @@ -28,8 +32,12 @@ , Text.Jira.Parser.Block , Text.Jira.Parser.Core , Text.Jira.Parser.Inline + , Text.Jira.Parser.PlainText + , Text.Jira.Parser.Shared + , Text.Jira.Printer build-depends: base >= 4.9 && < 5 + , mtl >= 2.2 && < 2.3 , parsec >= 3.1 && < 3.2 , text >= 1.1.1 && < 1.3 @@ -50,7 +58,6 @@ build-depends: base >= 4.9 && < 5 , text >= 1.1.1 && < 1.3 , jira-wiki-markup - ghc-options: -Wall -threaded @@ -72,6 +79,7 @@ other-modules: Text.Jira.ParserTests , Text.Jira.Parser.BlockTests , Text.Jira.Parser.InlineTests + , Text.Jira.PrinterTests build-depends: base >= 4.9 && < 5 , jira-wiki-markup diff --git a/src/Text/Jira/Markup.hs b/src/Text/Jira/Markup.hs --- a/src/Text/Jira/Markup.hs +++ b/src/Text/Jira/Markup.hs @@ -11,42 +11,61 @@ Jira markup types. -} module Text.Jira.Markup - ( Block (..) + ( Doc (..) + , Block (..) , Inline (..) + , InlineStyle (..) , ListStyle (..) , URL (..) + , ColorName (..) + , Icon (..) , Row (..) , Cell (..) , Language (..) , Parameter (..) , normalizeInlines + , iconText ) where import Data.Text (Text, append) +-- | Jira document +newtype Doc = Doc { fromDoc :: [Block] } + deriving (Eq, Ord, Show) + -- | Inline Jira markup elements. data Inline - = Anchor Text -- ^ anchor for internal links - | Deleted [Inline] -- ^ deleted (struk-out) text - | Emph [Inline] -- ^ emphasized text - | Entity Text -- ^ named or numeric HTML entity - | Image URL -- ^ an image - | Inserted [Inline] -- ^ text marked as having been inserted - | Linebreak -- ^ hard linebreak - | Link [Inline] URL -- ^ hyperlink with alias - | Monospaced [Inline] -- ^ text rendered with monospaced font - | Str Text -- ^ simple, markup-less string - | Space -- ^ space between words - | Strong [Inline] -- ^ strongly emphasized text - | Subscript [Inline] -- ^ subscript text - | Superscript [Inline] -- ^ superscript text + = Anchor Text -- ^ anchor for internal links + | AutoLink URL -- ^ URL which is also a link + | Emoji Icon -- ^ emoticon + | Entity Text -- ^ named or numeric HTML entity + | Image [Parameter] URL -- ^ an image + | Linebreak -- ^ hard linebreak + | Link [Inline] URL -- ^ hyperlink with alias + | Monospaced [Inline] -- ^ text rendered with monospaced font + | Space -- ^ space between words + | SpecialChar Char -- ^ single char with special meaning + | Str Text -- ^ simple, markup-less string + | Styled InlineStyle [Inline] -- ^ styled text deriving (Eq, Ord, Show) +-- | Supported inline text effect styles. +data InlineStyle + = Emphasis -- ^ emphasized text + | Insert -- ^ text marked as having been inserted + | Strikeout -- ^ deleted (struk-out) text + | Strong -- ^ strongly emphasized text + | Subscript -- ^ subscript text + | Superscript -- ^ superscript text + deriving (Eq, Ord, Show) + -- | Blocks of text. data Block = Code Language [Parameter] Text -- ^ Code block with panel parameters + | Color ColorName [Block] -- ^ text displayed in a specific color | BlockQuote [Block] -- ^ Block of quoted content | Header Int [Inline] -- ^ Header with level and text + | HorizontalRule -- ^ horizontal ruler | List ListStyle [[Block]] -- ^ List | NoFormat [Parameter] Text -- ^ Unformatted text | Panel [Parameter] [Block] -- ^ Formatted panel @@ -56,11 +75,15 @@ -- | Style used for list items. data ListStyle - = CircleBullets -- ^ List with round bullets - | SquareBullets -- ^ List with square bullets - | Enumeration -- ^ Enumeration, i.e., numbered items + = CircleBullets -- ^ List with round bullets + | SquareBullets -- ^ List with square bullets + | Enumeration -- ^ Enumeration, i.e., numbered items deriving (Eq, Ord, Show) +-- | Text color +newtype ColorName = ColorName Text + deriving (Eq, Ord, Show) + -- | Unified resource location newtype URL = URL { fromURL :: Text } deriving (Eq, Ord, Show) @@ -85,6 +108,33 @@ , parameterValue :: Text } deriving (Eq, Ord, Show) +-- | Graphical emoticons +data Icon + = IconSlightlySmiling + | IconFrowning + | IconTongue + | IconSmiling + | IconWinking + | IconThumbsUp + | IconThumbsDown + | IconInfo + | IconCheckmark + | IconX + | IconAttention + | IconPlus + | IconMinus + | IconQuestionmark + | IconOn + | IconOff + | IconStar + | IconStarRed + | IconStarGreen + | IconStarBlue + | IconStarYellow + | IconFlag + | IconFlagOff + deriving (Enum, Eq, Ord, Show) + -- | Normalize a list of inlines, merging elements where possible. normalizeInlines :: [Inline] -> [Inline] normalizeInlines = \case @@ -96,3 +146,30 @@ Linebreak : Space : xs -> Linebreak : normalizeInlines xs Str s1 : Str s2 : xs -> Str (s1 `append` s2) : normalizeInlines xs x : xs -> x : normalizeInlines xs + +-- | Gets the characters used to represent an emoji. +iconText :: Icon -> Text +iconText = \case + IconSlightlySmiling -> ":)" + IconFrowning -> ":(" + IconTongue -> ":P" + IconSmiling -> ":D" + IconWinking -> ";)" + IconThumbsUp -> "(y)" + IconThumbsDown -> "(n)" + IconInfo -> "(i)" + IconCheckmark -> "(/)" + IconX -> "(x)" + IconAttention -> "(!)" + IconPlus -> "(+)" + IconMinus -> "(-)" + IconQuestionmark -> "(?)" + IconOn -> "(on)" + IconOff -> "(off)" + IconStar -> "(*)" + IconStarRed -> "(*r)" + IconStarGreen -> "(*g)" + IconStarBlue -> "(*b)" + IconStarYellow -> "(*y)" + IconFlag -> "(flag)" + IconFlagOff -> "(flagoff)" diff --git a/src/Text/Jira/Parser.hs b/src/Text/Jira/Parser.hs --- a/src/Text/Jira/Parser.hs +++ b/src/Text/Jira/Parser.hs @@ -11,10 +11,12 @@ -} module Text.Jira.Parser ( parse + , doc , module Text.Jira.Markup , module Text.Jira.Parser.Core , module Text.Jira.Parser.Inline , module Text.Jira.Parser.Block + , module Text.Jira.Parser.PlainText ) where import Data.Text (Text) @@ -22,8 +24,13 @@ import Text.Jira.Parser.Block import Text.Jira.Parser.Core import Text.Jira.Parser.Inline +import Text.Jira.Parser.PlainText import Text.Parsec hiding (parse) --- | Parses a document into a list of blocks. -parse :: Text -> Either ParseError [Block] -parse = parseJira (many1 block) +-- | Parses a document into a Jira AST. +parse :: Text -> Either ParseError Doc +parse = parseJira doc + +-- | Parses a list of jira blocks into a @'Doc'@ element. +doc :: JiraParser Doc +doc = Doc <$> many block "doc" diff --git a/src/Text/Jira/Parser/Block.hs b/src/Text/Jira/Parser/Block.hs --- a/src/Text/Jira/Parser/Block.hs +++ b/src/Text/Jira/Parser/Block.hs @@ -14,7 +14,9 @@ -- * Parsers for block types , blockQuote , code + , color , header + , horizontalRule , list , noformat , panel @@ -37,9 +39,11 @@ , list , table , blockQuote + , horizontalRule , code , noformat , panel + , color , para ] <* skipWhitespace @@ -47,8 +51,9 @@ para :: JiraParser Block para = ( "para") . try $ do isInList <- stateInList <$> getState - when isInList $ + when isInList $ do notFollowedBy' blankline + notFollowedBy' horizontalRule Para . normalizeInlines <$> many1 inline -- | Parses a header line into a @Header@. @@ -88,14 +93,14 @@ firstItemAtDepth :: Int -> JiraParser [Block] firstItemAtDepth depth = try $ listContent (depth + 1) <|> do - blocks <- nonListContent + blocks <- nonListContent depth nestedLists <- try . many $ listAtDepth (depth + 1) return $ blocks ++ nestedLists listItemAtDepth :: Int -> JiraParser Char -> JiraParser [Block] listItemAtDepth depth bulletChar = atDepth depth *> - try (bulletChar *> nonListContent) <|> - try (anyBulletMarker *> listContent depth) + (try (bulletChar *> nonListContent depth) <|> + try (anyBulletMarker *> listContent depth)) listContent :: Int -> JiraParser [Block] listContent depth = do @@ -106,13 +111,14 @@ anyBulletMarker :: JiraParser Char anyBulletMarker = oneOf "*-#" - nonListContent :: JiraParser [Block] - nonListContent = try $ + nonListContent :: Int -> JiraParser [Block] + nonListContent depth = try $ let nonListBlock = notFollowedBy' (many1 (oneOf "#-*")) *> block in char ' ' *> do - first <- block - rest <- many nonListBlock - return (first : rest) + first <- block + nonList <- many nonListBlock + lists <- many (listAtDepth (depth + 1)) + return (first : nonList ++ lists) -- | Parses a table into a @Table@ element. table :: JiraParser Block @@ -146,9 +152,12 @@ -- | Parses a code block into a @Code@ element. code :: JiraParser Block code = try $ do - (lang, params) <- string "{code" *> parameters <* char '}' <* blankline + (langName, params) <- string "{code" *> parameters <* char '}' <* blankline + let lang = maybe defaultLanguage Language langName content <- anyChar `manyTill` try (string "{code}" *> blankline) return $ Code lang params (pack content) + where + defaultLanguage = Language (pack "java") -- | Parses a block quote into a @'Quote'@ element. blockQuote :: JiraParser Block @@ -161,6 +170,11 @@ (string "{quote}" *> optional blankline *> block `manyTill` try (string "{quote}")) +-- | Parses four consecutive hyphens as @'HorizontalRule'@. +horizontalRule :: JiraParser Block +horizontalRule = HorizontalRule <$ + try (string "----" *> blankline) + -- | Parses a preformatted text into a @NoFormat@ element. noformat :: JiraParser Block noformat = try $ do @@ -175,19 +189,15 @@ content <- block `manyTill` try (string "{panel}" *> blankline) return $ Panel params content --- | Parses a set of panel parameters -parameters :: JiraParser (Language, [Parameter]) -parameters = option (defaultLanguage, []) $ do - _ <- char ':' - lang <- option defaultLanguage (try language) - params <- try (Parameter <$> key <*> (char '=' *> value)) `sepBy` pipe - return (lang, params) +-- | Parses colored text into a @'Color'@ element. +color :: JiraParser Block +color= try $ do + name <- string "{color:" *> (colorName <|> colorCode) <* char '}' + content <- block `manyTill` try (string "{color}" *> blankline) + return $ Color (ColorName $ pack name) content where - defaultLanguage = Language (pack "java") - pipe = char '|' - key = pack <$> many1 (noneOf "\"'\t\n\r |{}=") - value = pack <$> many1 (noneOf "\"'\n\r|{}=") - language = Language <$> key <* (pipe <|> lookAhead (char '}')) + colorName = many letter + colorCode = optional (char '#') *> count 6 digit -- | Skip whitespace till we reach the next block skipWhitespace :: JiraParser () diff --git a/src/Text/Jira/Parser/Core.hs b/src/Text/Jira/Parser/Core.hs --- a/src/Text/Jira/Parser/Core.hs +++ b/src/Text/Jira/Parser/Core.hs @@ -26,10 +26,12 @@ , blankline , skipSpaces , blockNames + , parameters ) where import Control.Monad (join, void) -import Data.Text (Text) +import Data.Text (Text, pack) +import Text.Jira.Markup import Text.Parsec -- | Jira Parsec parser @@ -88,22 +90,37 @@ blankline :: JiraParser () blankline = try $ skipSpaces *> void newline +-- | Parses a set of panel parameters +parameters :: JiraParser (Maybe Text, [Parameter]) +parameters = option (Nothing, []) $ do + _ <- char ':' + lang <- optionMaybe (try language) + params <- try (Parameter <$> key <*> (char '=' *> value)) `sepBy` pipe + return (lang, params) + where + pipe = char '|' + key = pack <$> many1 (noneOf "\"'\t\n\r |{}=") + value = pack <$> many1 (noneOf "\"'\n\r|{}=") + language = key <* (pipe <|> lookAhead (char '}')) + -- | Succeeds if the parser is looking at the end of a paragraph. endOfPara :: JiraParser () endOfPara = eof <|> lookAhead blankline <|> lookAhead headerStart + <|> lookAhead horizontalRule <|> lookAhead listItemStart <|> lookAhead tableStart <|> lookAhead panelStart where - headerStart = void $ char 'h' *> oneOf "123456" <* char '.' - listItemStart = void $ many1 (oneOf "#*-") *> char ' ' - tableStart = void $ skipSpaces *> many1 (char '|') *> char ' ' - panelStart = void $ char '{' *> choice (map string blockNames) + headerStart = void $ char 'h' *> oneOf "123456" <* char '.' + listItemStart = void $ many1 (oneOf "#*-") <* char ' ' + tableStart = void $ skipSpaces *> many1 (char '|') *> char ' ' + panelStart = void $ char '{' *> choice (map (try . string) blockNames) + horizontalRule = void $ try (string "----") *> blankline blockNames :: [String] -blockNames = ["code", "noformat", "panel", "quote"] +blockNames = ["code", "color", "noformat", "panel", "quote"] -- | Variant of parsec's @notFollowedBy@ function which properly fails even if -- the given parser does not consume any input (like @eof@ does). diff --git a/src/Text/Jira/Parser/Inline.hs b/src/Text/Jira/Parser/Inline.hs --- a/src/Text/Jira/Parser/Inline.hs +++ b/src/Text/Jira/Parser/Inline.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-| Module : Text.Jira.Parser.Inline Copyright : © 2019 Albert Krewinkel @@ -14,64 +16,67 @@ ( inline -- * Inline component parsers , anchor - , deleted - , emph + , autolink + , dash + , emoji , entity - , inserted , image , linebreak , link , monospaced + , specialChar , str - , strong - , subscript - , superscript - , symbol + , styled , whitespace + -- * Constants + , specialChars ) where import Control.Monad (guard, void) -import Data.Char (isLetter) +import Data.Char (isLetter, isPunctuation, ord) +#if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>), All (..)) -import Data.Text (pack, singleton) +#else +import Data.Monoid (All (..)) +#endif +import Data.Text (append, pack) import Text.Jira.Markup import Text.Jira.Parser.Core +import Text.Jira.Parser.Shared import Text.Parsec -- | Parses any inline element. inline :: JiraParser Inline inline = notFollowedBy' blockEnd *> choice [ whitespace + , emoji + , dash + , autolink , str , linebreak , link , image - , emph - , strong - , subscript - , superscript - , deleted - , inserted + , styled , monospaced , anchor , entity - , symbol + , specialChar ] "inline" where blockEnd = char '{' *> choice (map string blockNames) <* char '}' --- | Characters with a special meaning, i.e., those used for markup. +-- | Characters which, depending on context, can have a special meaning. specialChars :: String -specialChars = " \n" ++ symbolChars - --- | Special characters which can be part of a string. -symbolChars :: String -symbolChars = "_+-*^~|[]{}!&\\" +specialChars = "_+-*^~|[]{}(!&\\" --- | Parses an in-paragraph newline as a @Linebreak@ element. +-- | Parses an in-paragraph newline as a @Linebreak@ element. Both newline +-- characters and double-backslash are recognized as line-breaks. linebreak :: JiraParser Inline -linebreak = Linebreak <$ try (newline <* notFollowedBy' endOfPara) - "linebreak" +linebreak = Linebreak <$ try ( + choice [ void $ newline <* notFollowedBy' endOfPara + , void $ string "\\\\" <* notFollowedBy' (char '\\') + ] + ) "linebreak" -- | Parses whitespace and return a @Space@ element. whitespace :: JiraParser Inline @@ -81,9 +86,11 @@ str :: JiraParser Inline str = Str . pack <$> (alphaNums <|> otherNonSpecialChars) "string" where + nonStrChars = " \n" ++ specialChars alphaNums = many1 alphaNum <* updateLastStrPos - otherNonSpecialChars = many1 (noneOf specialChars) + otherNonSpecialChars = many1 (noneOf nonStrChars) + -- | Parses an HTML entity into an @'Entity'@ element. entity :: JiraParser Inline entity = Entity . pack @@ -92,21 +99,34 @@ numerical = (:) <$> char '#' <*> many1 digit named = many1 letter +-- | Parses textual representation of an icon into an @'Emoji'@ element. +emoji :: JiraParser Inline +emoji = Emoji <$> icon <* notFollowedBy' letter "emoji" + +-- | Parses ASCII representation of en-dash or em-dash. +dash :: JiraParser Inline +dash = try $ do + guard =<< notAfterString + _ <- string "--" + choice [ Str "—" <$ char '-' -- em dash + , pure (Str "–") -- en dash + ] <* lookAhead (void (char ' ') <|> eof) + -- | Parses a special character symbol as a @Str@. -symbol :: JiraParser Inline -symbol = Str . singleton <$> (escapedChar <|> symbolChar) - "symbol" +specialChar :: JiraParser Inline +specialChar = SpecialChar <$> (escapedChar <|> plainSpecialChar) + "special char" where - escapedChar = try (char '\\' *> oneOf symbolChars) + escapedChar = try (char '\\' *> satisfy isPunctuation) - symbolChar = do + plainSpecialChar = do inTablePred <- do b <- stateInTable <$> getState return $ if b then All . (/= '|') else mempty inLinkPred <- do b <- stateInLink <$> getState return $ if b then All . (`notElem` ("]|\n" :: String)) else mempty - oneOf $ filter (getAll . (inTablePred <> inLinkPred)) symbolChars + oneOf $ filter (getAll . (inTablePred <> inLinkPred)) specialChars -- @@ -120,8 +140,12 @@ -- | Parse image into an @Image@ element. image :: JiraParser Inline -image = fmap (Image . URL . pack) . try $ - char '!' *> noneOf "\r\t\n" `manyTill` char '!' +image = try $ do + -- does not use @url@, as is may contain relative locations. + src <- char '!' *> (URL . pack <$> many1 (noneOf "\r\t\n|]!")) + (_, params) <- option (Nothing, []) (char '|' *> parameters) + _ <- char '!' + return $ Image params src -- | Parse link into a @Link@ element. link :: JiraParser Inline @@ -129,43 +153,80 @@ guard . not . stateInLink =<< getState withStateFlag (\b st -> st { stateInLink = b }) $ do _ <- char '[' - alias <- option [] $ try (many inline <* char '|') - url <- URL . pack <$> many1 (noneOf "|] \n") + alias <- option [] $ try (many inline <* char '|') + linkUrl <- email <|> url _ <- char ']' - return $ Link alias url + return $ Link alias linkUrl +autolink :: JiraParser Inline +autolink = AutoLink <$> (email <|> url) "email or other URL" + +-- | Parse a URL with scheme @file@, @ftp@, @http@, @https@, @irc@, @nntp@, or +-- @news@. +url :: JiraParser URL +url = try $ do + urlScheme <- scheme + sep <- pack <$> string "://" + rest <- pack <$> many urlChar + return $ URL (urlScheme `append` sep `append` rest) + where + scheme = do + first <- letter + case first of + 'f' -> ("file" <$ string "ile") <|> ("ftp" <$ string "tp") + 'h' -> string "ttp" *> option "http" ("https" <$ char 's') + 'i' -> "irc" <$ string "rc" + 'n' -> ("nntp" <$ string "ntp") <|> ("news" <$ string "ews") + _ -> fail "not looking at a known scheme" + +-- | Parses an E-mail URL. +email :: JiraParser URL +email = URL . pack <$> try + ((++) <$> string "mailto:" <*> many1 urlChar) + +-- | Parses a character which is allowed in URLs +urlChar :: JiraParser Char +urlChar = satisfy $ \c -> + c `notElem` ("|]" :: String) && ord c >= 32 && ord c <= 127 + + -- -- Markup -- --- | Parses deleted text into @Deleted@. -deleted :: JiraParser Inline -deleted = Deleted <$> ('-' `delimitingMany` inline) "deleted" --- | Parses emphasized text into @Emph@. -emph :: JiraParser Inline -emph = Emph <$> ('_' `delimitingMany` inline) "emphasis" +-- | Parses styled text +styled :: JiraParser Inline +styled = (simpleStyled <|> forceStyled) "styled text" + where + simpleStyled = try $ do + styleChar <- lookAhead $ oneOf "-_+*~^" + content <- styleChar `delimitingMany` inline + let style = delimiterStyle styleChar + return $ Styled style content --- | Parses inserted text into @Inserted@. -inserted :: JiraParser Inline -inserted = Inserted <$> ('+' `delimitingMany` inline) "inserted" + forceStyled = try $ do + styleChar <- char '{' *> oneOf "-_+*~^" <* char '}' + let closing = try $ string ['{', styleChar, '}'] + let style = delimiterStyle styleChar + content <- manyTill inline closing + return $ Styled style content +-- | Returns the markup kind from the delimiting markup character. +delimiterStyle :: Char -> InlineStyle +delimiterStyle = \case + '*' -> Strong + '+' -> Insert + '-' -> Strikeout + '^' -> Superscript + '_' -> Emphasis + '~' -> Subscript + c -> error ("Unknown delimiter character: " ++ [c]) + -- | Parses monospaced text into @Monospaced@. monospaced :: JiraParser Inline monospaced = Monospaced <$> enclosed (try $ string "{{") (try $ string "}}") inline "monospaced" - --- | Parses strongly emphasized text into @Strong@. -strong :: JiraParser Inline -strong = Strong <$> ('*' `delimitingMany` inline) "strong" - --- | Parses subscript text into @Subscript@. -subscript :: JiraParser Inline -subscript = Subscript <$> ('~' `delimitingMany` inline) "subscript" - --- | Parses superscript text into @Superscript@. -superscript :: JiraParser Inline -superscript = Superscript <$> ('^' `delimitingMany` inline) "superscript" -- -- Helpers diff --git a/src/Text/Jira/Parser/PlainText.hs b/src/Text/Jira/Parser/PlainText.hs new file mode 100644 --- /dev/null +++ b/src/Text/Jira/Parser/PlainText.hs @@ -0,0 +1,46 @@ +{-| +Module : Text.Jira.Parser.PlainText +Copyright : © 2019 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel +Stability : alpha +Portability : portable + +Functions for parsing markup-less strings. +-} + +module Text.Jira.Parser.PlainText + ( plainText + ) where + +import Data.Text (Text, append, pack) +import Text.Jira.Markup +import Text.Jira.Parser.Core +import Text.Jira.Parser.Inline (specialChars) +import Text.Jira.Parser.Shared (icon) +import Text.Parsec + +-- | Parses into an @'Inline'@ elements which represent plain text. The +-- result consists of any number of @'Str'@, @'SpecialChar'@, or +-- @'Space'@ elements. +-- +-- This parser can be used to convert un-escaped strings into proper +-- Jira markup elements. +plainText :: Text -> Either ParseError [Inline] +plainText = parseJira (normalizeInlines <$> many plainInlineParser) + where + plainInlineParser :: JiraParser Inline + plainInlineParser = choice + [ Space <$ skipMany1 (char ' ') + , escapeIcon + , plainSpecialChar + , Str . pack <$> many1 (noneOf (' ':specialChars)) + ] "text-only inline" + +-- | Escapes text which would otherwise render as an icon. +escapeIcon :: Parsec Text u Inline +escapeIcon = Str . ("\\" `append`) . iconText <$> icon + +plainSpecialChar :: Parsec Text u Inline +plainSpecialChar = SpecialChar <$> oneOf specialChars diff --git a/src/Text/Jira/Parser/Shared.hs b/src/Text/Jira/Parser/Shared.hs new file mode 100644 --- /dev/null +++ b/src/Text/Jira/Parser/Shared.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE LambdaCase #-} +{-| +Module : Text.Jira.Parser.Shared +Copyright : © 2019 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel +Stability : alpha +Portability : portable + +Parsers whch are shared between multiple modules. +-} +module Text.Jira.Parser.Shared + ( icon + ) where + +import Data.Char (isLetter) +import Data.Text (Text) +import Text.Jira.Markup +import Text.Parsec + +-- | Parses an icon +icon :: Parsec Text u Icon +icon = smiley <|> otherIcon + +smiley :: Parsec Text u Icon +smiley = try $ choice + [ IconWinking <$ string ";)" + , char ':' *> anyChar >>= \case + 'D' -> pure IconSmiling + ')' -> pure IconSlightlySmiling + '(' -> pure IconFrowning + 'P' -> pure IconTongue + c -> fail ("unknown smiley: :" ++ [c]) + ] + +otherIcon :: Parsec Text u Icon +otherIcon = try $ do + let isIconChar c = isLetter c || (c `elem` ("/!+-?*" :: String)) + name <- char '(' + *> many1 (satisfy isIconChar) + <* char ')' + case name of + "y" -> pure IconThumbsUp + "n" -> pure IconThumbsDown + "i" -> pure IconInfo + "/" -> pure IconCheckmark + "x" -> pure IconX + "!" -> pure IconAttention + "+" -> pure IconPlus + "-" -> pure IconMinus + "?" -> pure IconQuestionmark + "on" -> pure IconOn + "off" -> pure IconOff + "*" -> pure IconStar + "*r" -> pure IconStarRed + "*g" -> pure IconStarGreen + "*b" -> pure IconStarBlue + "*y" -> pure IconStarYellow + "flag" -> pure IconFlag + "flagoff" -> pure IconFlagOff + _ -> fail ("not a known emoji" ++ name) diff --git a/src/Text/Jira/Printer.hs b/src/Text/Jira/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Text/Jira/Printer.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-| +Module : Text.Jira.Parser +Copyright : © 2019 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel +Stability : alpha +Portability : portable + +Generate Jira wiki markup text from an abstract syntax tree. +-} +module Text.Jira.Printer + ( pretty + , renderBlock + , renderInline + , prettyBlocks + , prettyInlines + , JiraPrinter + , PrinterState (..) + , startState + , withDefault + ) where + +import Data.Char (isAlphaNum) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif +import Control.Monad ((<=<)) +import Control.Monad.Reader (Reader, runReader, asks, local) +import Data.Text (Text) +import Text.Jira.Markup +import qualified Data.Text as T + +-- | Render Jira document as Jira wiki formatted text. +pretty :: Doc -> Text +pretty (Doc blks) = prettyBlocks blks + +-- | Render a list of Jira blocks as Jira wiki formatted text. +prettyBlocks :: [Block] -> Text +prettyBlocks blks = runReader (renderBlocks blks) startState + +-- | Renders a list of Jira inline markup elements. +prettyInlines :: [Inline] -> Text +prettyInlines = \case + [] -> + "" + s@Str{} : Styled style inlns : rest -> + renderInline s <> renderStyledSafely style inlns <> prettyInlines rest + Styled style inlns : s@(Str t) : rest | startsWithAlphaNum t -> + renderStyledSafely style inlns <> renderInline s <> prettyInlines rest + s@Str{} : SpecialChar c : rest@(Str {}:_) -> + (renderInline s `T.snoc` c) <> prettyInlines rest + s@Space : SpecialChar c : rest@(Space {}:_) -> + (renderInline s `T.snoc` c) <> prettyInlines rest + s@Linebreak : SpecialChar c : rest@(Space {}:_) -> + (renderInline s `T.snoc` c) <> prettyInlines rest + (x:xs) -> + renderInline x <> prettyInlines xs + + where + startsWithAlphaNum t = case T.uncons t of + Just (c, _) -> isAlphaNum c + _ -> False + +-- | Internal state used by the printer. +data PrinterState = PrinterState + { stateInTable :: Bool + , stateListLevel :: Text + } + +type JiraPrinter a = Reader PrinterState a + +-- | Run with default state. +withDefault :: JiraPrinter a -> a +withDefault = flip runReader startState + +-- | Default start state of the printer. +startState :: PrinterState +startState = PrinterState + { stateInTable = False + , stateListLevel = "" + } + +-- | Render a block as Jira wiki format. +renderBlocks :: [Block] -> JiraPrinter Text +renderBlocks = concatBlocks <=< mapM renderBlock + +-- | Combine the texts produced from rendering a list of blocks. +concatBlocks :: [Text] -> JiraPrinter Text +concatBlocks = return . T.intercalate "\n" + +-- | Add a newline character unless we are within a list or table. +appendNewline :: Text -> JiraPrinter Text +appendNewline text = do + listLevel <- asks stateListLevel + inTable <- asks stateInTable + return $ + -- add final newline only if we are neither within a table nor a list. + if inTable || not (T.null listLevel) + then text + else text <> "\n" + +-- | Render a block as Jira wiki format. +renderBlock :: Block -> JiraPrinter Text +renderBlock = \case + Code lang params content -> return $ T.concat + [ "{code:" + , T.intercalate "|" + (renderLang lang : map renderParam params) + , "}\n" + , content + , "\n{code}" + ] + Color colorName blocks -> renderBlocks blocks >>= \blks -> return $ T.concat + [ "{color:", colorText colorName, "}\n" + , blks + , "{color}" + ] + BlockQuote [Para xs] -> return $ "bq. " <> prettyInlines xs + BlockQuote blocks -> renderBlocks blocks >>= \blks -> return $ T.concat + [ "{quote}\n" + , blks + , "\n{quote}"] + Header lvl inlines -> return $ T.concat + [ "h", T.pack (show lvl), ". " + , prettyInlines inlines + ] + HorizontalRule -> return "----" + List style items -> listWithMarker items (styleChar style) >>= + appendNewline + NoFormat params content -> return $ T.concat + [ "{noformat" + , renderBlockParams params + , "}\n" + , content + , "{noformat}" + ] + Panel params blocks -> renderBlocks blocks >>= \blks -> + return $ T.concat + [ "{panel" + , renderBlockParams params + , "}\n" + , blks + , "{panel}" + ] + Para inlines -> appendNewline $ prettyInlines inlines + Table rows -> + local (\st -> st { stateInTable = True }) $ + fmap T.unlines (mapM renderRow rows) + +-- | Returns the ext representation of a color +colorText :: ColorName -> Text +colorText (ColorName c) = c + +renderLang :: Language -> Text +renderLang (Language lang) = lang + +renderBlockParams :: [Parameter] -> Text +renderBlockParams = \case + [] -> mempty + xs -> T.cons ':' (renderParams xs) + +renderParams :: [Parameter] -> Text +renderParams = T.intercalate "|" . map renderParam + +renderParam :: Parameter -> Text +renderParam (Parameter key value) = key <> "=" <> value + +renderRow :: Row -> JiraPrinter Text +renderRow (Row cells) = do + rendered <- mapM renderCell cells + let closing = if all isHeaderCell cells then " ||" else " |" + return $ T.unwords rendered <> closing + where + isHeaderCell HeaderCell {} = True + isHeaderCell BodyCell {} = False + +renderCell :: Cell -> JiraPrinter Text +renderCell cell = let (cellStart, blocks) = case cell of + (HeaderCell bs) -> ("|| ", bs) + (BodyCell bs) -> ("| ", bs) + in (cellStart <>) <$> renderBlocks blocks + +styleChar :: ListStyle -> Char +styleChar = \case + CircleBullets -> '*' + SquareBullets -> '-' + Enumeration -> '#' + +-- | Create a list using the given character as bullet item marker. +listWithMarker :: [[Block]] + -> Char + -> JiraPrinter Text +listWithMarker items marker = do + let addItem s = s { stateListLevel = stateListLevel s `T.snoc` marker } + renderedBlocks <- local addItem $ mapM listItemToJira items + return $ T.intercalate "\n" renderedBlocks + +-- | Convert bullet or ordered list item (list of blocks) to Jira. +listItemToJira :: [Block] + -> JiraPrinter Text +listItemToJira items = do + contents <- renderBlocks items + marker <- asks stateListLevel + return $ case items of + List{} : _ -> contents + _ -> marker <> " " <> contents + +-- | Renders a single inline item as Jira markup. +renderInline :: Inline -> Text +renderInline = \case + Anchor name -> "{anchor:" <> name <> "}" + AutoLink url -> urlText url + Emoji icon -> iconText icon + Entity entity -> "&" <> entity <> ";" + Image params url -> "!" <> urlText url <> + if null params + then "!" + else "|" <> renderParams params <> "!" + Linebreak -> "\n" + Link inlines (URL url) -> "[" <> prettyInlines inlines <> "|" <> url <> "]" + Monospaced inlines -> "{{" <> prettyInlines inlines <> "}}" + Space -> " " + SpecialChar c -> case c of + -- backslash is unescapable, render as entity + '\\' -> "\" + _ -> "\\" `T.snoc` c + Str txt -> txt + Styled style inlines -> renderWrapped (delimiterChar style) inlines + +renderStyledSafely :: InlineStyle -> [Inline] -> Text +renderStyledSafely style = + let delim = T.pack ['{', delimiterChar style, '}'] + in (delim <>) . (<> delim) . prettyInlines + +delimiterChar :: InlineStyle -> Char +delimiterChar = \case + Emphasis -> '_' + Insert -> '+' + Strong -> '*' + Strikeout -> '-' + Subscript -> '~' + Superscript -> '^' + +-- | Text rendering of an URL. +urlText :: URL -> Text +urlText (URL url) = url + +renderWrapped :: Char -> [Inline] -> Text +renderWrapped c = T.cons c . flip T.snoc c . prettyInlines diff --git a/test/Text/Jira/Parser/BlockTests.hs b/test/Text/Jira/Parser/BlockTests.hs --- a/test/Text/Jira/Parser/BlockTests.hs +++ b/test/Text/Jira/Parser/BlockTests.hs @@ -45,6 +45,10 @@ , testCase "ended by blank line" $ parseJira para "Hello\n\n" @?= Right (Para [Str "Hello"]) + + , testCase "deleted text after linebreak" $ + parseJira para "foo\n-deleted-\n" @?= + Right (Para [Str "foo", Linebreak, Styled Strikeout [Str "deleted"]]) ] , testGroup "header" @@ -78,6 +82,12 @@ isLeft (parseJira header " h1. nope\n") @? "leading spaces" ] + , testGroup "horizontalRule" + [ testCase "single ruler" $ + parseJira horizontalRule "----\n" @?= + Right HorizontalRule + ] + , testGroup "list" [ testCase "single item list" $ parseJira list "* hello\n" @?= @@ -157,14 +167,18 @@ , testCase "item after nested list" $ let text = Text.unlines [ "* first" - , "** nested" , "* second" + , "** nested1" + , "** nested2" + , "* third" ] in parseJira list text @?= Right (List CircleBullets - [ [ Para [Str "first"] - , List CircleBullets [[Para [Str "nested"]]]] - , [ Para [Str "second"]]]) + [ [ Para [Str "first"] ] + , [ Para [Str "second"] + , List CircleBullets [ [Para [Str "nested1"]] + , [Para [Str "nested2"]]]] + , [ Para [Str "third"]] ]) , testCase "nested lists" $ let text = Text.unlines @@ -287,6 +301,13 @@ Right (Panel [Parameter "title" "test"] [Para [Str "line"]]) ] + , testGroup "color" + [ testCase "single paragraph" $ + parseJira color "{color:red}This is red.\n{color}\n" @?= + Right (Color (ColorName "red") + [Para [Str "This", Space, Str "is", Space, Str "red."]]) + ] + , testGroup "blockQuote" [ testCase "single line quite before eof" $ parseJira blockQuote "bq. this text" @?= @@ -319,6 +340,14 @@ , testCase "para after header" $ parseJira ((,) <$> block <*> block) "h2.header\nparagraph\n" @?= Right (Header 2 [Str "header"], Para [Str "paragraph"]) + + , testCase "para before horizontal rule " $ + parseJira ((,) <$> block <*> return HorizontalRule) "paragraph\n----\n" @?= + Right (Para [Str "paragraph"], HorizontalRule) + + , testCase "para after horizontal rule " $ + parseJira ((,) <$> block <*> block) "----\nparagraph\n" @?= + Right (HorizontalRule, Para [Str "paragraph"]) , testCase "para after list" $ parseJira ((,) <$> block <*> block) "* foo\n\nbar\n" @?= diff --git a/test/Text/Jira/Parser/InlineTests.hs b/test/Text/Jira/Parser/InlineTests.hs --- a/test/Text/Jira/Parser/InlineTests.hs +++ b/test/Text/Jira/Parser/InlineTests.hs @@ -39,14 +39,45 @@ "str should only be parsed into Space" ] - , testGroup "symbol" - [ testCase "special symbol" $ - parseJira symbol "!" @?= Right (Str "!") + , testGroup "specialChar" + [ testCase "plain special char" $ + parseJira specialChar "!" @?= Right (SpecialChar '!') , testCase "escaped symbol" $ - parseJira symbol "\\{" @?= Right (Str "{") + parseJira specialChar "\\{" @?= Right (SpecialChar '{') ] + , testGroup "dash" + [ testCase "en dash" $ + parseJira dash "--" @?= Right (Str "–") + + , testCase "em dash" $ + parseJira dash "---" @?= Right (Str "—") + ] + + , testGroup "emoji" + [ testCase "smiling face" $ + parseJira emoji ":D" @?= Right (Emoji IconSmiling) + + , testCase "winking face" $ + parseJira emoji ";)" @?= Right (Emoji IconWinking) + + , testCase "checkmark" $ + parseJira emoji "(/)" @?= Right (Emoji IconCheckmark) + + , testCase "red x" $ + parseJira emoji "(x)" @?= Right (Emoji IconX) + + , testCase "thumbs up" $ + parseJira emoji "(y)" @?= Right (Emoji IconThumbsUp) + + , testCase "green star" $ + parseJira emoji "(*g)" @?= Right (Emoji IconStarGreen) + + , testCase "may not be followed by a letter" $ + isLeft (parseJira emoji "(x)nope") @? "no letters after emojis" + ] + , testGroup "whitespace" [ testCase "space" $ parseJira whitespace " " @?= Right Space @@ -95,43 +126,58 @@ "entities must not be empty" ] - , testCase "deleted" $ - parseJira deleted "-far-fetched-" @?= - Right (Deleted [Str "far", Str "-", Str "fetched"]) + , testGroup "styled" - , testGroup "emph" - [ testCase "single word" $ - parseJira emph "_single_" @?= Right (Emph [Str "single"]) + [ testCase "deleted" $ + parseJira styled "-far-fetched-" @?= + Right (Styled Strikeout [Str "far", SpecialChar '-', Str "fetched"]) - , testCase "multi word" $ - parseJira emph "_multiple words_" @?= - Right (Emph [Str "multiple", Space, Str "words"]) + , testGroup "emphasis" + [ testCase "single word" $ + parseJira styled "_single_" @?= Right (Styled Emphasis [Str "single"]) - , testCase "symbol before opening underscore" $ - parseJira (str *> emph) "#_bar_" @?= - Right (Emph [Str "bar"]) + , testCase "multi word" $ + parseJira styled "_multiple words_" @?= + Right (Styled Emphasis [Str "multiple", Space, Str "words"]) - , testCase "neither symbol nor space before opening underscore" $ - isLeft (parseJira (str *> emph) "foo_bar_") @? "space after opening char" + , testCase "forced markup" $ + parseJira styled "{_}forced{_}" @?= + Right (Styled Emphasis [Str "forced"]) - , testCase "disallow space after opening underscore" $ - isLeft (parseJira emph "_ nope_") @? "space after underscore" + , testCase "symbol before opening underscore" $ + parseJira (str *> styled) "#_bar_" @?= + Right (Styled Emphasis [Str "bar"]) - , testCase "require word boundary after closing underscore" $ - isLeft (parseJira emph "_nope_nope") @? "no boundary after closing" + , testCase "neither symbol nor space before opening underscore" $ + isLeft (parseJira (str *> styled) "foo_bar_") @? "space after opening char" - , testCase "zero with space as word boundary" $ - parseJira ((,) <$> emph <*> str) "_yup_\8203next" @?= - Right (Emph [Str "yup"], Str "\8203next") + , testCase "disallow space after opening underscore" $ + isLeft (parseJira styled "_ nope_") @? "space after underscore" - , testCase "fails for strong" $ - isLeft (parseJira emph "*strong*") @? "strong as emph" - ] + , testCase "require word boundary after closing underscore" $ + isLeft (parseJira styled "_nope_nope") @? "no boundary after closing" - , testCase "inserted" $ - parseJira inserted "+multiple words+" @?= - Right (Inserted [Str "multiple", Space, Str "words"]) + , testCase "zero with space as word boundary" $ + parseJira ((,) <$> styled <*> str) "_yup_\8203next" @?= + Right (Styled Emphasis [Str "yup"], Str "\8203next") + ] + , testCase "inserted" $ + parseJira styled "+multiple words+" @?= + Right (Styled Insert [Str "multiple", Space, Str "words"]) + + , testCase "strong" $ + parseJira styled "*single*" @?= Right (Styled Strong [Str "single"]) + + , testCase "subscript" $ + parseJira styled "~multiple words~" @?= + Right (Styled Subscript [Str "multiple", Space, Str "words"]) + + , testCase "superscript" $ + parseJira styled "^multiple words^" @?= + Right (Styled Superscript [Str "multiple", Space, Str "words"]) + ] + , testCase "monospaced" $ parseJira monospaced "{{multiple words}}" @?= Right (Monospaced [Str "multiple", Space, Str "words"]) @@ -141,6 +187,10 @@ parseJira linebreak "\na" @?= Right Linebreak + , testCase "double-backslash linebreak" $ + parseJira linebreak "\\\\" @?= + Right Linebreak + , testCase "linebreak at eof fails" $ isLeft (parseJira linebreak "\n") @? "newline before eof" @@ -152,32 +202,25 @@ , testCase "linebreak before header fails" $ isLeft (parseJira linebreak "\nh1.foo\n") @? "newline before header" - ] - , testGroup "strong" - [ testCase "single word" $ - parseJira strong "*single*" @?= Right (Strong [Str "single"]) - - , testCase "multi word" $ - parseJira strong "*multiple words*" @?= - Right (Strong [Str "multiple", Space, Str "words"]) - - , testCase "fails for emph" $ - isLeft (parseJira strong "_emph_") @? "emph as strong" + , testCase "three backslashes do not cause a linebreak" $ + isLeft (parseJira linebreak "\\\\\\") @? "three backslashes" ] - , testCase "subscript" $ - parseJira subscript "~multiple words~" @?= - Right (Subscript [Str "multiple", Space, Str "words"]) - - , testCase "superscript" $ - parseJira superscript "^multiple words^" @?= - Right (Superscript [Str "multiple", Space, Str "words"]) - , testCase "anchor" $ parseJira anchor "{anchor:testing}" @?= Right (Anchor "testing") + , testGroup "autolink" + [ testCase "hypertext link" $ + parseJira autolink "https://example.org/foo" @?= + Right (AutoLink (URL "https://example.org/foo")) + + , testCase "email" $ + parseJira autolink "mailto:nobody@test.invalid" @?= + Right (AutoLink (URL "mailto:nobody@test.invalid")) + ] + , testGroup "link" [ testCase "unaliased link" $ parseJira link "[https://example.org]" @?= @@ -189,14 +232,19 @@ , testCase "alias with emphasis" $ parseJira link "[_important_ example|https://example.org]" @?= - Right (Link [Emph [Str "important"], Space, Str "example"] + Right (Link [Styled Emphasis [Str "important"], Space, Str "example"] (URL "https://example.org")) + + , testCase "mail address" $ + parseJira link "[send mail|mailto:me@nope.invalid]" @?= + Right (Link [Str "send", Space, Str "mail"] + (URL "mailto:me@nope.invalid")) ] , testGroup "image" [ testCase "local file" $ parseJira image "!image.jpg!" @?= - Right (Image (URL "image.jpg")) + Right (Image [] (URL "image.jpg")) , testCase "no newlines" $ isLeft (parseJira image "!hello\nworld.png!") @? @@ -207,15 +255,45 @@ , testGroup "inline parser" [ testCase "simple sentence" $ parseJira (normalizeInlines <$> many1 inline) "Hello, World!" @?= - Right [Str "Hello,", Space, Str "World!"] + Right [Str "Hello,", Space, Str "World", SpecialChar '!'] , testCase "with entity" $ parseJira (many1 inline) "shopping at P&C" @?= Right [ Str "shopping", Space, Str "at", Space - , Str "P", Entity "amp", Str "C"] + , Str "P", Entity "amp", Str "C" + ] + , testCase "autolink followed by pipe" $ + parseJira (many1 inline) "https://jira.example/file.txt|" @?= + Right [AutoLink (URL "https://jira.example/file.txt"), SpecialChar '|'] + , testCase "backslash-escaped char" $ parseJira (normalizeInlines <$> many1 inline) "opening brace: \\{" @?= - Right [ Str "opening", Space, Str "brace:", Space, Str "{"] + Right [Str "opening", Space, Str "brace:", Space, SpecialChar '{'] + + , testCase "icon after word" $ + parseJira (many1 inline) "checkmark(/)" @?= + Right [Str "checkmark", Emoji IconCheckmark] + + , testCase "smiley after word" $ + parseJira (normalizeInlines <$> many1 inline) "smiley:)" @?= + Right [Str "smiley", Emoji IconSlightlySmiling] + + , testCase "escaped smiley after word" $ + parseJira (normalizeInlines <$> many1 inline) "closing paren\\:)" @?= + Right [Str "closing", Space, Str "paren", SpecialChar ':', Str ")"] + + , testCase "smiley between words" $ + parseJira (normalizeInlines <$> many1 inline) "verdict: :D funny" @?= + Right [Str "verdict:", Space, Emoji IconSmiling, Space, Str "funny"] + + , testCase "dash with spaces" $ + parseJira (many1 inline) "one -- two" @?= + Right [Str "one", Space, Str "–", Space, Str "two"] + + + , testCase "forced markup" $ + parseJira (many1 inline) "H{~}2{~}O" @?= + Right [Str "H", Styled Subscript [Str "2"], Str "O"] ] ] diff --git a/test/Text/Jira/ParserTests.hs b/test/Text/Jira/ParserTests.hs --- a/test/Text/Jira/ParserTests.hs +++ b/test/Text/Jira/ParserTests.hs @@ -13,6 +13,8 @@ import Data.Text () import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Text.Jira.Parser import qualified Text.Jira.Parser.BlockTests import qualified Text.Jira.Parser.InlineTests @@ -20,4 +22,36 @@ tests = testGroup "Parser" [ Text.Jira.Parser.InlineTests.tests , Text.Jira.Parser.BlockTests.tests + , testGroup "doc" + [ testCase "empty document" $ + parse "" @?= + Right (Doc []) + + , testCase "simple document" $ + parse "h1. test\nThis is ok." @?= + Right (Doc [ Header 1 [Str "test"] + , Para [Str "This", Space, Str "is", Space, Str "ok."]]) + ] + + , testGroup "plainText" + [ testCase "word" $ + plainText "kthxbye" @?= + Right [Str "kthxbye"] + + , testCase "words" $ + plainText "be Berlin" @?= + Right [Str "be", Space, Str "Berlin"] + + , testCase "smiley" $ + plainText ":)" @?= + Right [Str "\\:)"] + + , testCase "icon after word" $ + plainText "f(x)" @?= + Right [Str "f\\(x)"] + + , testCase "special chars" $ + plainText "*not strong*" @?= + Right [SpecialChar '*', Str "not", Space, Str "strong", SpecialChar '*'] + ] ] diff --git a/test/Text/Jira/PrinterTests.hs b/test/Text/Jira/PrinterTests.hs new file mode 100644 --- /dev/null +++ b/test/Text/Jira/PrinterTests.hs @@ -0,0 +1,151 @@ +{-| +Module : Text.Jira.PrinterTests +Copyright : © 2019 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel +Stability : alpha +Portability : portable + +Tests for the jira wiki printer. +-} +module Text.Jira.PrinterTests (tests) where + +import Prelude hiding (unlines) +import Data.Text (Text, unlines) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Text.Jira.Markup +import Text.Jira.Printer + +tests :: TestTree +tests = testGroup "Printer" + [ testGroup "doc" + [ testCase "empty document" $ + pretty (Doc []) @?= "" + ] + + , testGroup "blocks" + [ testCase "simple paragraph" $ + let para = Para [Str "Hello,", Space, Str "World!"] + in renderBlock' para @?= "Hello, World!\n" + + , testCase "two paragraphs" $ + let para1 = Para [Str "First", Space, Str "paragraph."] + para2 = Para [Str "Second", Space, Str "paragraph."] + in prettyBlocks [para1, para2] @?= unlines + [ "First paragraph." + , "" + , "Second paragraph." + ] + + , testGroup "header" + [ testCase "simple" $ + let header = Header 1 [Str "test", Space, Str "header"] + in renderBlock' header @?= "h1. test header" + + , testCase "header" $ + let header = Header 5 [Str "test", Space, Str "header"] + in renderBlock' header @?= "h5. test header" + ] + + , testCase "horizontal rule" $ + renderBlock' HorizontalRule @?= "----" + + , testCase "color" $ + renderBlock' (Color (ColorName "blue") [Para [Str "yabadee"]]) @?= + "{color:blue}\nyabadee\n{color}" + + , testGroup "list" + [ testCase "simple list" $ + let list = List SquareBullets [ [Para [Str "first"]] + , [Para [Str "second"]] + , [Para [Str "third"]] + ] + in renderBlock' list @?= unlines + [ "- first" + , "- second" + , "- third" + ] + + , testCase "nested list" $ + let list = List CircleBullets + [ [Para [Str "first"]] + , [ List Enumeration [ [Para [Str "second-1"]] + , [Para [Str "second-2"]]]] + , [ Para [Str "third"] + , List CircleBullets [ [Para [Str "third-1"]] + , [Para [Str "third-2"]]]] + ] + in renderBlock' list @?= unlines + [ "* first" + , "*# second-1" + , "*# second-2" + , "* third" + , "** third-1" + , "** third-2" + ] + ] + + , testCase "table" $ + let headerRow = Row [ HeaderCell [Para [Str "one"]] + , HeaderCell [Para [Str "two"]] + ] + bodyRow = Row [ BodyCell [Para [Str "1"]] + , BodyCell [Para [Str "2"]] + ] + table = Table [headerRow, bodyRow] + in renderBlock' table @?= "|| one || two ||\n| 1 | 2 |\n" + + , testCase "para after table" $ + let table = Table [Row [BodyCell [Para [Str "boring"]]]] + para = Para [Str "after", Space, Str "table"] + in prettyBlocks [table, para] @?= "| boring |\n\nafter table\n" + + , testCase "para after list" $ + let list = List Enumeration [[Para [Str "boring"]]] + para = Para [Str "after", Space, Str "table"] + in prettyBlocks [list, para] @?= "# boring\n\nafter table\n" + ] + + , testGroup "isolated inline" + [ testCase "SpecialChar" $ + renderInline (SpecialChar '*') @?= "\\*" + + , testCase "AutoLink" $ + renderInline (AutoLink (URL "https://example.org")) @?= + "https://example.org" + + , testCase "Emoji" $ + renderInline (Emoji IconSmiling) @?= ":D" + + , testCase "Styled Emphasis" $ + renderInline (Styled Emphasis [Str "Hello,", Space, Str "World!"]) @?= + "_Hello, World!_" + + , testCase "Styled Strong" $ + renderInline (Styled Strong [Str "Hello,", Space, Str "World!"]) @?= + "*Hello, World!*" + ] + + , testGroup "combined inlines" + [ testCase "special char between words" $ + prettyInlines [Str "easy", SpecialChar '-', Str "peasy"] @?= + "easy-peasy" + + , testCase "special char before word" $ + prettyInlines [SpecialChar '*', Str "star"] @?= + "\\*star" + + , testCase "markup within word" $ + prettyInlines [Str "H", Styled Subscript [Str "2"], Str "O"] @?= + "H{~}2{~}O" + + , testCase "markup followed by punctuation" $ + prettyInlines [Styled Emphasis [Str "Word"], Str "."] @?= + "_Word_." + ] + ] + +renderBlock' :: Block -> Text +renderBlock' = withDefault . renderBlock diff --git a/test/jira-wiki-markup-test.hs b/test/jira-wiki-markup-test.hs --- a/test/jira-wiki-markup-test.hs +++ b/test/jira-wiki-markup-test.hs @@ -14,6 +14,7 @@ import Data.Text () import Test.Tasty (TestTree, defaultMain, testGroup) import qualified Text.Jira.ParserTests +import qualified Text.Jira.PrinterTests -- | Run the tests for jira-wiki-markup. main :: IO () @@ -22,4 +23,5 @@ tests :: TestTree tests = testGroup "jira-wiki-markup" [ Text.Jira.ParserTests.tests + , Text.Jira.PrinterTests.tests ]