diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# Changelog + +`jira-wiki-markup` uses [PVP Versioning][1]. +The changelog is available [on GitHub][2]. + +0.0.0 +===== + +* Initially created. + +[1]: https://pvp.haskell.org +[2]: https://github.com/tarleb/jira-wiki-markup/releases diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2019 Albert Krewinkel + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +# jira-wiki-markup + +[![Hackage](https://img.shields.io/hackage/v/jira-wiki-markup.svg)](https://hackage.haskell.org/package/jira-wiki-markup) +[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE) +[![Stackage Lts](http://stackage.org/package/jira-wiki-markup/badge/lts)](http://stackage.org/lts/package/jira-wiki-markup) +[![Stackage Nightly](http://stackage.org/package/jira-wiki-markup/badge/nightly)](http://stackage.org/nightly/package/jira-wiki-markup) +[![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) + +Handle Jira wiki markup diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,20 @@ +{-| +Parse Jira wiki markup from stdin. +-} +module Main (main) where + +import Prelude hiding (interact) + +import Control.Exception (throw) +import Data.Text (pack) +import Data.Text.IO (interact) +import System.Exit (ExitCode (ExitFailure)) +import Text.Jira.Parser (parse) + + +main :: IO () +main = interact parse' + where + parse' t = case parse t of + Left _ -> throw (ExitFailure 1) + Right r -> pack (show r) diff --git a/jira-wiki-markup.cabal b/jira-wiki-markup.cabal new file mode 100644 --- /dev/null +++ b/jira-wiki-markup.cabal @@ -0,0 +1,93 @@ +cabal-version: 2.0 +name: jira-wiki-markup +version: 0.1.0 +synopsis: Handle Jira wiki markup +description: Handle Jira wiki markup +homepage: https://github.com/tarleb/jira-wiki-markup +bug-reports: https://github.com/tarleb/jira-wiki-markup/issues +license: MIT +license-file: LICENSE +author: Albert Krewinkel +maintainer: tarleb@zeitkraut.de +copyright: © 2019 Albert Krewinkel +category: Text +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 + +source-repository head + type: git + location: https://github.com/tarleb/jira-wiki-markup.git + +library + hs-source-dirs: src + exposed-modules: Text.Jira.Markup + , Text.Jira.Parser + , Text.Jira.Parser.Block + , Text.Jira.Parser.Core + , Text.Jira.Parser.Inline + + build-depends: base >= 4.9 && < 5 + , parsec >= 3.1 && < 3.2 + , text >= 1.1.1 && < 1.3 + + ghc-options: -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + + default-language: Haskell2010 + default-extensions: OverloadedStrings + +executable jira-wiki-markup + hs-source-dirs: app + main-is: Main.hs + + build-depends: base >= 4.9 && < 5 + , text >= 1.1.1 && < 1.3 + , jira-wiki-markup + + + ghc-options: -Wall + -threaded + -rtsopts + -with-rtsopts=-N + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + + default-language: Haskell2010 + default-extensions: OverloadedStrings + +test-suite jira-wiki-markup-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: jira-wiki-markup-test.hs + other-modules: Text.Jira.ParserTests + , Text.Jira.Parser.BlockTests + , Text.Jira.Parser.InlineTests + + build-depends: base >= 4.9 && < 5 + , jira-wiki-markup + , parsec >= 3.1 && < 3.2 + , tasty + , tasty-hunit + , text >= 1.1.1 && < 1.3 + + ghc-options: -Wall + -threaded + -rtsopts + -with-rtsopts=-N + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + + default-language: Haskell2010 + default-extensions: OverloadedStrings diff --git a/src/Text/Jira/Markup.hs b/src/Text/Jira/Markup.hs new file mode 100644 --- /dev/null +++ b/src/Text/Jira/Markup.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE LambdaCase #-} +{-| +Module : Text.Jira.Markup +Copyright : © 2019 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel +Stability : alpha +Portability : portable + +Jira markup types. +-} +module Text.Jira.Markup + ( Block (..) + , Inline (..) + , ListStyle (..) + , URL (..) + , Row (..) + , Cell (..) + , Language (..) + , Parameter (..) + , normalizeInlines + ) where + +import Data.Text (Text, append) + +-- | 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 + deriving (Eq, Ord, Show) + +-- | Blocks of text. +data Block + = Code Language [Parameter] Text -- ^ Code block with panel parameters + | BlockQuote [Block] -- ^ Block of quoted content + | Header Int [Inline] -- ^ Header with level and text + | List ListStyle [[Block]] -- ^ List + | NoFormat [Parameter] Text -- ^ Unformatted text + | Panel [Parameter] [Block] -- ^ Formatted panel + | Para [Inline] -- ^ Paragraph of text + | Table [Row] -- ^ Table + deriving (Eq, Ord, Show) + +-- | Style used for list items. +data ListStyle + = CircleBullets -- ^ List with round bullets + | SquareBullets -- ^ List with square bullets + | Enumeration -- ^ Enumeration, i.e., numbered items + deriving (Eq, Ord, Show) + +-- | Unified resource location +newtype URL = URL { fromURL :: Text } + deriving (Eq, Ord, Show) + +-- | Table row, containing an arbitrary number of cells. +newtype Row = Row { fromRow :: [Cell] } + deriving (Eq, Ord, Show) + +-- | Table cell with block content +data Cell + = BodyCell [Block] + | HeaderCell [Block] + deriving (Eq, Ord, Show) + +-- | Programming language used for syntax highlighting. +newtype Language = Language Text + deriving (Eq, Ord, Show) + +-- | Panel parameter +data Parameter = Parameter + { parameterKey :: Text + , parameterValue :: Text + } deriving (Eq, Ord, Show) + +-- | Normalize a list of inlines, merging elements where possible. +normalizeInlines :: [Inline] -> [Inline] +normalizeInlines = \case + [] -> [] + [Space] -> [] + [Linebreak] -> [] + Space : Space : xs -> Space : normalizeInlines xs + Space : Linebreak : xs -> Linebreak : normalizeInlines xs + Linebreak : Space : xs -> Linebreak : normalizeInlines xs + Str s1 : Str s2 : xs -> Str (s1 `append` s2) : normalizeInlines xs + x : xs -> x : normalizeInlines xs diff --git a/src/Text/Jira/Parser.hs b/src/Text/Jira/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/Jira/Parser.hs @@ -0,0 +1,29 @@ +{-| +Module : Text.Jira.Parser +Copyright : © 2019 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel +Stability : alpha +Portability : portable + +Parse Jira wiki markup. +-} +module Text.Jira.Parser + ( parse + , module Text.Jira.Markup + , module Text.Jira.Parser.Core + , module Text.Jira.Parser.Inline + , module Text.Jira.Parser.Block + ) where + +import Data.Text (Text) +import Text.Jira.Markup +import Text.Jira.Parser.Block +import Text.Jira.Parser.Core +import Text.Jira.Parser.Inline +import Text.Parsec hiding (parse) + +-- | Parses a document into a list of blocks. +parse :: Text -> Either ParseError [Block] +parse = parseJira (many1 block) diff --git a/src/Text/Jira/Parser/Block.hs b/src/Text/Jira/Parser/Block.hs new file mode 100644 --- /dev/null +++ b/src/Text/Jira/Parser/Block.hs @@ -0,0 +1,200 @@ +{-| +Module : Text.Jira.Parser.Block +Copyright : © 2019 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel +Stability : alpha +Portability : portable + +Parse Jira wiki blocks. +-} +module Text.Jira.Parser.Block + ( block + -- * Parsers for block types + , blockQuote + , code + , header + , list + , noformat + , panel + , para + , table + ) where + +import Control.Monad (guard, void, when) +import Data.Char (digitToInt) +import Data.Text (pack) +import Text.Jira.Markup +import Text.Jira.Parser.Core +import Text.Jira.Parser.Inline +import Text.Parsec + +-- | Parses any block element. +block :: JiraParser Block +block = choice + [ header + , list + , table + , blockQuote + , code + , noformat + , panel + , para + ] <* skipWhitespace + +-- | Parses a paragraph into a @Para@. +para :: JiraParser Block +para = ( "para") . try $ do + isInList <- stateInList <$> getState + when isInList $ + notFollowedBy' blankline + Para . normalizeInlines <$> many1 inline + +-- | Parses a header line into a @Header@. +header :: JiraParser Block +header = ( "header") . try $ do + level <- digitToInt <$> (char 'h' *> oneOf "123456" <* char '.') + content <- skipMany (char ' ') *> inline `manyTill` (void newline <|> eof) + return $ Header level (normalizeInlines content) + +-- | Parses a list into @List@. +list :: JiraParser Block +list = ( "list") . try $ do + guard . not . stateInList =<< getState + withStateFlag (\b st -> st { stateInList = b }) $ + listAtDepth 0 + where + listAtDepth :: Int -> JiraParser Block + listAtDepth depth = try $ atDepth depth *> listAtDepth' depth + + listAtDepth' :: Int -> JiraParser Block + listAtDepth' depth = try $ do + bulletChar <- anyBulletMarker + first <- firstItemAtDepth depth + rest <- many (try $ listItemAtDepth depth (char bulletChar)) + return $ List (style bulletChar) (first:rest) + + style :: Char -> ListStyle + style c = case c of + '-' -> SquareBullets + '*' -> CircleBullets + '#' -> Enumeration + _ -> error ("the impossible happened: unknown style for bullet " ++ [c]) + + atDepth :: Int -> JiraParser () + atDepth depth = try . void $ count depth anyBulletMarker + + firstItemAtDepth :: Int -> JiraParser [Block] + firstItemAtDepth depth = try $ listContent (depth + 1) <|> + do + blocks <- nonListContent + 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) + + listContent :: Int -> JiraParser [Block] + listContent depth = do + first <- listAtDepth' depth + rest <- many (listAtDepth depth) + return (first : rest) + + anyBulletMarker :: JiraParser Char + anyBulletMarker = oneOf "*-#" + + nonListContent :: JiraParser [Block] + nonListContent = try $ + let nonListBlock = notFollowedBy' (many1 (oneOf "#-*")) *> block + in char ' ' *> do + first <- block + rest <- many nonListBlock + return (first : rest) + +-- | Parses a table into a @Table@ element. +table :: JiraParser Block +table = do + guard . not . stateInTable =<< getState + withStateFlag (\b st -> st { stateInTable = b }) $ + Table <$> many1 row + +-- | Parses a table row. +row :: JiraParser Row +row = fmap Row . try $ + many1 cell <* optional (skipMany (oneOf " |") *> newline) + +-- | Parses a table cell. +cell :: JiraParser Cell +cell = try $ do + mkCell <- cellStart + bs <- many1 block + return $ mkCell bs + +-- | Parses the beginning of a table cell and returns a function which +-- constructs a cell of the appropriate type when given the cell's content. +cellStart :: JiraParser ([Block] -> Cell) +cellStart = try + $ skipSpaces + *> char '|' + *> option BodyCell (HeaderCell <$ many1 (char '|')) + <* skipSpaces + <* notFollowedBy' newline + +-- | Parses a code block into a @Code@ element. +code :: JiraParser Block +code = try $ do + (lang, params) <- string "{code" *> parameters <* char '}' <* blankline + content <- anyChar `manyTill` try (string "{code}" *> blankline) + return $ Code lang params (pack content) + +-- | Parses a block quote into a @'Quote'@ element. +blockQuote :: JiraParser Block +blockQuote = try $ singleLineBq <|> multiLineBq + where + singleLineBq = BlockQuote . (:[]) . Para <$> + (string "bq. " *> skipMany (char ' ') *> + inline `manyTill` (void newline <|> eof)) + multiLineBq = BlockQuote <$> + (string "{quote}" *> optional blankline *> + block `manyTill` try (string "{quote}")) + +-- | Parses a preformatted text into a @NoFormat@ element. +noformat :: JiraParser Block +noformat = try $ do + (_, params) <- string "{noformat" *> parameters <* char '}' <* newline + content <- anyChar `manyTill` try (string "{noformat}" *> blankline) + return $ NoFormat params (pack content) + +-- | Parses a preformatted text into a @NoFormat@ element. +panel :: JiraParser Block +panel = try $ do + (_, params) <- string "{panel" *> parameters <* char '}' <* newline + 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) + 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 '}')) + +-- | Skip whitespace till we reach the next block +skipWhitespace :: JiraParser () +skipWhitespace = optional $ do + isInList <- stateInList <$> getState + isInTable <- stateInTable <$> getState + case (isInList, isInTable) of + (True, _) -> blankline + (_, True) -> skipSpaces + _ -> skipMany blankline diff --git a/src/Text/Jira/Parser/Core.hs b/src/Text/Jira/Parser/Core.hs new file mode 100644 --- /dev/null +++ b/src/Text/Jira/Parser/Core.hs @@ -0,0 +1,114 @@ +{-| +Module : Text.Jira.Parser.Core +Copyright : © 2019 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel +Stability : alpha +Portability : portable + +Core components of the Jira wiki markup parser. +-} +module Text.Jira.Parser.Core + ( + -- * Jira parser and state + JiraParser + , ParserState (..) + , defaultState + , parseJira + , withStateFlag + -- * String position tracking + , updateLastStrPos + , notAfterString + -- * Parsing helpers + , endOfPara + , notFollowedBy' + , blankline + , skipSpaces + , blockNames + ) where + +import Control.Monad (join, void) +import Data.Text (Text) +import Text.Parsec + +-- | Jira Parsec parser +type JiraParser = Parsec Text ParserState + +-- | Parser state used to keep track of various parameteres. +data ParserState = ParserState + { stateInLink :: Bool -- ^ whether the parser is within a link + , stateInList :: Bool -- ^ whether the parser is within a list + , stateInTable :: Bool -- ^ whether the parser is within a table + , stateLastStrPos :: Maybe SourcePos -- ^ position at which the last string + -- ended + } + +-- | Default parser state (i.e., start state) +defaultState :: ParserState +defaultState = ParserState + { stateInLink = False + , stateInList = False + , stateInTable = False + , stateLastStrPos = Nothing + } + +-- | Set a flag in the parser to @True@ before running a parser, then +-- set the flag's value to @False@. +withStateFlag :: (Bool -> ParserState -> ParserState) + -> JiraParser a + -> JiraParser a +withStateFlag flagSetter parser = try $ + let setFlag = modifyState . flagSetter + in setFlag True *> parser <* setFlag False + +-- | Updates the state, marking the current input position as the end of a +-- string. +updateLastStrPos :: JiraParser () +updateLastStrPos = do + pos <- getPosition + modifyState $ \st -> st { stateLastStrPos = Just pos } + +-- | Checks whether the parser is directly after a string. +notAfterString :: JiraParser Bool +notAfterString = do + curPos <- getPosition + prevPos <- stateLastStrPos <$> getState + return (Just curPos /= prevPos) + +-- | Parses a string with the given Jira parser. +parseJira :: JiraParser a -> Text -> Either ParseError a +parseJira parser = runParser parser defaultState "" + +-- | Skip zero or more space chars. +skipSpaces :: JiraParser () +skipSpaces = skipMany (char ' ') + +-- | Parses an empty line, i.e., a line with no chars or whitespace only. +blankline :: JiraParser () +blankline = try $ skipSpaces *> void newline + +-- | Succeeds if the parser is looking at the end of a paragraph. +endOfPara :: JiraParser () +endOfPara = eof + <|> lookAhead blankline + <|> lookAhead headerStart + <|> 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) + +blockNames :: [String] +blockNames = ["code", "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). +notFollowedBy' :: Show a => JiraParser a -> JiraParser () +notFollowedBy' p = + let failIfSucceeds = unexpected . show <$> try p + unitParser = return (return ()) + in try $ join (failIfSucceeds <|> unitParser) diff --git a/src/Text/Jira/Parser/Inline.hs b/src/Text/Jira/Parser/Inline.hs new file mode 100644 --- /dev/null +++ b/src/Text/Jira/Parser/Inline.hs @@ -0,0 +1,186 @@ +{-| +Module : Text.Jira.Parser.Inline +Copyright : © 2019 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel +Stability : alpha +Portability : portable + +Parse Jira wiki inline markup. +-} + +module Text.Jira.Parser.Inline + ( inline + -- * Inline component parsers + , anchor + , deleted + , emph + , entity + , inserted + , image + , linebreak + , link + , monospaced + , str + , strong + , subscript + , superscript + , symbol + , whitespace + ) where + +import Control.Monad (guard, void) +import Data.Char (isLetter) +import Data.Monoid ((<>), All (..)) +import Data.Text (pack, singleton) +import Text.Jira.Markup +import Text.Jira.Parser.Core +import Text.Parsec + +-- | Parses any inline element. +inline :: JiraParser Inline +inline = notFollowedBy' blockEnd *> choice + [ whitespace + , str + , linebreak + , link + , image + , emph + , strong + , subscript + , superscript + , deleted + , inserted + , monospaced + , anchor + , entity + , symbol + ] "inline" + where + blockEnd = char '{' *> choice (map string blockNames) <* char '}' + +-- | Characters with a special meaning, i.e., those used for markup. +specialChars :: String +specialChars = " \n" ++ symbolChars + +-- | Special characters which can be part of a string. +symbolChars :: String +symbolChars = "_+-*^~|[]{}!&" + +-- | Parses an in-paragraph newline as a @Linebreak@ element. +linebreak :: JiraParser Inline +linebreak = Linebreak <$ try (newline <* notFollowedBy' endOfPara) + "linebreak" + +-- | Parses whitespace and return a @Space@ element. +whitespace :: JiraParser Inline +whitespace = Space <$ skipMany1 (char ' ') "whitespace" + +-- | Parses a simple, markup-less string into a @Str@ element. +str :: JiraParser Inline +str = Str . pack <$> (alphaNums <|> otherNonSpecialChars) "string" + where + alphaNums = many1 alphaNum <* updateLastStrPos + otherNonSpecialChars = many1 (noneOf specialChars) + +-- | Parses an HTML entity into an @'Entity'@ element. +entity :: JiraParser Inline +entity = Entity . pack + <$> try (char '&' *> (numerical <|> named) <* char ';') + where + numerical = (:) <$> char '#' <*> many1 digit + named = many1 letter + +-- | Parses a special character symbol as a @Str@. +symbol :: JiraParser Inline +symbol = Str . singleton <$> (escapedChar <|> symbolChar) + "symbol" + where + escapedChar = try (char '\\' *> oneOf symbolChars) + + symbolChar = 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 + + +-- +-- Anchors, links and images +-- + +-- | Parses an anchor into an @Anchor@ element. +anchor :: JiraParser Inline +anchor = Anchor . pack . filter (/= ' ') + <$> try (string "{anchor:" *> noneOf "\n" `manyTill` char '}') + +-- | Parse image into an @Image@ element. +image :: JiraParser Inline +image = fmap (Image . URL . pack) . try $ + char '!' *> noneOf "\r\t\n" `manyTill` char '!' + +-- | Parse link into a @Link@ element. +link :: JiraParser Inline +link = try $ do + guard . not . stateInLink =<< getState + withStateFlag (\b st -> st { stateInLink = b }) $ do + _ <- char '[' + alias <- option [] $ try (many inline <* char '|') + url <- URL . pack <$> many1 (noneOf "|] \n") + _ <- char ']' + return $ Link alias url + +-- +-- 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 inserted text into @Inserted@. +inserted :: JiraParser Inline +inserted = Inserted <$> ('+' `delimitingMany` inline) "inserted" + +-- | 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 +-- + +-- | Parse text delimited by a character. +delimitingMany :: Char -> JiraParser a -> JiraParser [a] +delimitingMany c = enclosed (char c) (char c) + +enclosed :: JiraParser opening -> JiraParser closing + -> JiraParser a + -> JiraParser [a] +enclosed opening closing parser = try $ do + guard =<< notAfterString + opening *> notFollowedBy space *> manyTill parser closing' + where + closing' = try $ closing <* lookAhead wordBoundary + wordBoundary = void (satisfy (not . isLetter)) <|> eof diff --git a/test/Text/Jira/Parser/BlockTests.hs b/test/Text/Jira/Parser/BlockTests.hs new file mode 100644 --- /dev/null +++ b/test/Text/Jira/Parser/BlockTests.hs @@ -0,0 +1,363 @@ +{-| +Module : Text.Jira.Parser.BlockTests +Copyright : © 2019 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel +Stability : alpha +Portability : portable + +Tests for jira wiki block parsers. +-} +module Text.Jira.Parser.BlockTests (tests) where + +import Data.Either (isLeft) +import Data.Text () +import Text.Jira.Markup +import Text.Jira.Parser.Block +import Text.Jira.Parser.Core + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=), (@?)) + +import qualified Data.Text as Text + +tests :: TestTree +tests = testGroup "Blocks" + [ testGroup "components" + [ testGroup "para" + [ testCase "two lines" $ + parseJira block "one\ntwo\n" @?= + Right (Para [Str "one", Linebreak, Str "two"]) + + , testCase "ended by newline" $ + parseJira para "Hello, World\n" @?= + Right (Para [Str "Hello,", Space, Str "World"]) + + , testCase "ended by eof" $ + parseJira para "Hello, World" @?= + Right (Para [Str "Hello,", Space, Str "World"]) + + , testCase "ended by spaces and newline" $ + parseJira para "Hello, World \n" @?= + Right (Para [Str "Hello,", Space, Str "World"]) + + , testCase "ended by blank line" $ + parseJira para "Hello\n\n" @?= + Right (Para [Str "Hello"]) + ] + + , testGroup "header" + [ testCase "Level 1" $ + parseJira header "h1. Intro\n" @?= + Right (Header 1 [Str "Intro"]) + + , testCase "many spaces before title" $ + parseJira header "h2. space\n" @?= + Right (Header 2 [Str "space"]) + + , testCase "no space after dot" $ + parseJira header "h3.hug\n" @?= + Right (Header 3 [Str "hug"]) + + , testCase "empty header" $ + parseJira header "h4.\n" @?= + Right (Header 4 []) + + , testCase "Level 6" $ + parseJira header "h6. More\n" @?= + Right (Header 6 [Str "More"]) + + , testCase "Level 7 fails" $ + isLeft (parseJira header "h7. More\n") @? "level 7 header" + + , testCase "Level 0 fails" $ + isLeft (parseJira header "h0. More\n") @? "level 0 header" + + , testCase "leading spaces are disallowed" $ + isLeft (parseJira header " h1. nope\n") @? "leading spaces" + ] + + , testGroup "list" + [ testCase "single item list" $ + parseJira list "* hello\n" @?= + Right (List CircleBullets [[Para [Str "hello"]]]) + + , testCase "simple list" $ + let text = Text.unlines + [ "* one" + , "* two" + ] + in parseJira list text @?= + Right (List CircleBullets + [ [Para [Str "one"]] + , [Para [Str "two"]]]) + + , testCase "list followed by different list" $ + parseJira ((,) <$> list <*> list) "- first\n* second\n" @?= + Right ( List SquareBullets [[Para [Str "first"]]] + , List CircleBullets [[Para [Str "second"]]]) + + , testCase "nested lists" $ + parseJira list "* first\n** nested\n" @?= + Right (List CircleBullets + [ + [ Para [Str "first"] + , List CircleBullets [[Para [Str "nested"]]] + ] + ]) + + , testCase "deeply nested list" $ + parseJira list "*-* nested\n*-* list\n" @?= + Right (List CircleBullets + [ + [ List SquareBullets + [[ List CircleBullets + [ [Para [Str "nested"]] + , [Para [Str "list"]]] + ]] + ] + ]) + + , testCase "markers can vary" $ + parseJira list "#-* nested\n*** list\n" @?= + Right (List Enumeration + [[ List SquareBullets + [[ List CircleBullets + [ [Para [Str "nested"]] + , [Para [Str "list"]] + ] + ]] + ]]) + + , testCase "single nested list after paragraph" $ + let text = Text.unlines + [ "* line" + , "continued" + , "** nested" + ] + in parseJira list text @?= + Right (List CircleBullets + [ [ Para [Str "line", Linebreak, Str "continued"] + , List CircleBullets [[Para [Str "nested"]]]]]) + + , testCase "multiple nested lists after paragraph" $ + let text = Text.unlines + [ "* line" + , "continued" + , "** nested" + , "*# another" + ] + in parseJira list text @?= + Right (List CircleBullets + [ [ Para [Str "line", Linebreak, Str "continued"] + , List CircleBullets [[Para [Str "nested"]]] + , List Enumeration [[Para [Str "another"]]]]]) + + , testCase "item after nested list" $ + let text = Text.unlines + [ "* first" + , "** nested" + , "* second" + ] + in parseJira list text @?= + Right (List CircleBullets + [ [ Para [Str "first"] + , List CircleBullets [[Para [Str "nested"]]]] + , [ Para [Str "second"]]]) + + , testCase "nested lists" $ + let text = Text.unlines + [ "** eins" + , "*- zwei" + , "** drei" + ] + in parseJira list text @?= + Right (List CircleBullets + [ [ List CircleBullets [[Para [Str "eins"]]] + , List SquareBullets [[Para [Str "zwei"]]] + , List CircleBullets [[Para [Str "drei"]]] + ] + ]) + ] + + , testGroup "Table" + [ testCase "single cell" $ + parseJira table "| Lua \n" @?= + Right (Table [Row [BodyCell [Para [Str "Lua"]]]]) + + , testCase "header cell" $ + parseJira table "|| Language\n" @?= + Right (Table [Row [HeaderCell [Para [Str "Language"]]]]) + + , testCase "2x2 table" $ + parseJira table + (Text.unlines [ "|| Language || Type ||" + , "| Lua | dynamic |\n"]) + @?= + Right (Table [ Row [ HeaderCell [Para [Str "Language"]] + , HeaderCell [Para [Str "Type"]] + ] + , Row [ BodyCell [Para [Str "Lua"]] + , BodyCell [Para [Str "dynamic"]] + ] + ]) + + , testCase "row headeres" $ + parseJira table + (Text.unlines [ "|| Language | Haskell ||" + , "|| Type | static |\n"]) + @?= + Right (Table [ Row [ HeaderCell [Para [Str "Language"]] + , BodyCell [Para [Str "Haskell"]] + ] + , Row [ HeaderCell [Para [Str "Type"]] + , BodyCell [Para [Str "static"]] + ] + ]) + + , testCase "list in table" $ + parseJira table "| * foo\n* bar\n" @?= + Right (Table [ + Row [BodyCell [List CircleBullets + [ [Para [Str "foo"]] + , [Para [Str "bar"]] + ]]]]) + + , testCase "multiple line cells" $ + parseJira table "| foo\nbar | baz |\n" @?= + Right (Table [ + Row [ BodyCell [Para [Str "foo", Linebreak, Str "bar"]] + , BodyCell [Para [Str "baz"]]]]) + + , testCase "multiple lists in cell" $ + parseJira table "| * foo\n- bar\n" @?= + Right (Table [Row [BodyCell [ List CircleBullets [[Para [Str "foo"]]] + , List SquareBullets [[Para [Str "bar"]]]]]]) + ] + + , testGroup "code" + [ testCase "no language" $ + parseJira code "{code}\nprint('Hi Mom!'){code}\n" @?= + Right (Code (Language "java") [] "print('Hi Mom!')") + + , testCase "with language" $ + parseJira code "{code:swift}\nfunc foo() -> Int { return 4 }{code}\n" @?= + Right (Code (Language "swift") [] + "func foo() -> Int { return 4 }") + + , testCase "with parameters" $ + parseJira code "{code:title=coffee|bgColor=#ccc}\nblack(){code}\n" @?= + Right (Code (Language "java") + [Parameter "title" "coffee", Parameter "bgColor" "#ccc"] + "black()") + + , testCase "with language and parameter" $ + parseJira code + "{code:haskell|title=Hello World}\nputStrLn \"Hello, World!\"{code}\n" @?= + Right (Code (Language "haskell") + [Parameter "title" "Hello World"] + "putStrLn \"Hello, World!\"") + ] + + , testGroup "noformat" + [ testCase "no parameters" $ + parseJira noformat "{noformat}\nline 1\nline 2{noformat}\n" @?= + Right (NoFormat [] "line 1\nline 2") + + , testCase "with parameters" $ + parseJira noformat "{noformat:title=test}\nline 1\nline 2{noformat}\n" @?= + Right (NoFormat [Parameter "title" "test"] "line 1\nline 2") + ] + + , testGroup "panel" + [ testCase "two-line paragraph" $ + parseJira panel "{panel}\nline 1\nline 2\n{panel}\n" @?= + Right (Panel [] [Para [Str "line", Space, Str "1", Linebreak, + Str "line", Space, Str "2"]]) + + -- FIXME: the next two shouldn't require a blank line after the contents + , testCase "list" $ + parseJira panel "{panel}\n* first\n* second\n\n{panel}\n" @?= + Right (Panel [] [List CircleBullets [ [Para [Str "first"]] + , [Para [Str "second"]]]]) + + , testCase "with parameters" $ + parseJira panel "{panel:title=test}\nline\n{panel}\n" @?= + Right (Panel [Parameter "title" "test"] [Para [Str "line"]]) + ] + + , testGroup "blockQuote" + [ testCase "single line quite before eof" $ + parseJira blockQuote "bq. this text" @?= + Right (BlockQuote [Para [Str "this", Space, Str "text"]]) + + , testCase "single line blockquote" $ + parseJira blockQuote "bq. this test\n" @?= + Right (BlockQuote [Para [Str "this", Space, Str "test"]]) + + , testCase "multi-paragraph block quote" $ + parseJira blockQuote "{quote}\npara1\n\npara2\n{quote}\n" @?= + Right (BlockQuote [ Para [Str "para1"] + , Para [Str "para2"]]) + + , testCase "condensed block quote" $ + parseJira blockQuote "{quote}life is good{quote}\n" @?= + Right (BlockQuote [Para [Str "life", Space, Str "is", Space, Str "good"]]) + ] + ] + + , testGroup "block combinations" + [ testCase "single paragraph" $ + parseJira block "Lorem ipsum." @?= + Right (Para [Str "Lorem", Space, Str "ipsum."]) + + , testCase "para before header" $ + parseJira ((,) <$> block <*> block) "paragraph\nh1.header\n" @?= + Right (Para [Str "paragraph"], Header 1 [Str "header"]) + + , testCase "para after header" $ + parseJira ((,) <$> block <*> block) "h2.header\nparagraph\n" @?= + Right (Header 2 [Str "header"], Para [Str "paragraph"]) + + , testCase "para after list" $ + parseJira ((,) <$> block <*> block) "* foo\n\nbar\n" @?= + Right (List CircleBullets [[Para [Str "foo"]]], Para [Str "bar"]) + + , testCase "successive lists of same type" $ + parseJira ((,) <$> block <*> block) "* foo\n\n* bar\n" @?= + Right ( List CircleBullets [[Para [Str "foo"]]] + , List CircleBullets [[Para [Str "bar"]]]) + + , testCase "para after table" $ + parseJira ((,) <$> block <*> block) "|| point |\nhuh\n" @?= + Right ( Table [Row [HeaderCell [Para [Str "point"]]]] + , Para [Str "huh"]) + + , testCase "para after blankline terminated table" $ + parseJira ((,) <$> block <*> block) "|| love\n\npeace\n" @?= + Right ( Table [Row [HeaderCell [Para [Str "love"]]]] + , Para [Str "peace"]) + + , testCase "para before code" $ + parseJira ((,) <$> block <*> block) "nice\n{code}\nhappy(){code}\n" @?= + Right ( Para [Str "nice"] + , Code (Language "java") [] "happy()") + + , testCase "para after code" $ + parseJira ((,) <$> block <*> block) "{code}\nfn(){code}\ntext" @?= + Right ( Code (Language "java") [] "fn()" + , Para [Str "text"]) + + , testCase "para before noformat" $ + parseJira ((,) <$> block <*> block) + "wholesome\n{noformat}\nenjoy{noformat}\n" @?= + Right ( Para [Str "wholesome"] + , NoFormat [] "enjoy") + + , testCase "para after noformat" $ + parseJira ((,) <$> block <*> block) "{noformat}\nlala{noformat}\ntext" @?= + Right ( NoFormat [] "lala" + , Para [Str "text"]) + ] + ] diff --git a/test/Text/Jira/Parser/InlineTests.hs b/test/Text/Jira/Parser/InlineTests.hs new file mode 100644 --- /dev/null +++ b/test/Text/Jira/Parser/InlineTests.hs @@ -0,0 +1,217 @@ +{-| +Module : Text.Jira.Parser.InlineTests +Copyright : © 2019 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel +Stability : alpha +Portability : portable + +Tests for the jira wiki inline markup parsers. +-} +module Text.Jira.Parser.InlineTests (tests) where + +import Data.Either (isLeft) +import Data.Text () +import Text.Jira.Markup +import Text.Jira.Parser.Core +import Text.Jira.Parser.Inline +import Text.Parsec (many1) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=), (@?)) + +tests :: TestTree +tests = testGroup "Inline" + [ testGroup "components" + [ testGroup "str" + [ testCase "simple word" $ + parseJira str "word" @?= Right (Str "word") + + , testCase "non-special symbols" $ + parseJira str ",.;#%" @?= Right (Str ",.;#%") + + , testCase "umlauts" $ + parseJira str "äéíöüßðå" @?= Right (Str "äéíöüßðå") + + , testCase "space fails" $ + isLeft (parseJira str " ") @? + "str should only be parsed into Space" + ] + + , testGroup "symbol" + [ testCase "special symbol" $ + parseJira symbol "!" @?= Right (Str "!") + + , testCase "escaped symbol" $ + parseJira symbol "\\{" @?= Right (Str "{") + ] + + , testGroup "whitespace" + [ testCase "space" $ + parseJira whitespace " " @?= Right Space + + , testCase "tab" $ + isLeft (parseJira whitespace "\t") @? + "TAB is not considered whitespace" + + , testCase "nonbreaking space fails" $ + isLeft (parseJira whitespace "\160") @? + "NBSP is not considered whitespace" + + , testCase "zero width space fails" $ + isLeft (parseJira whitespace "\8203") @? + "ZWSP is not considered whitespace" + + , testCase "newline fails" $ + isLeft (parseJira whitespace "\n") @? + "newline is not considered whitespace" + ] + + , testGroup "entity" + [ testCase "named entity" $ + parseJira entity "©" @?= Right (Entity "copy") + + , testCase "numerical entity" $ + parseJira entity "A" @?= Right (Entity "#65") + + , testCase "invalid entity" $ + parseJira entity "&haskell;" @?= Right (Entity "haskell") + + , testCase "space" $ + isLeft (parseJira entity "&a b;") @? + "entities may not contain spaces" + + , testCase "symbol" $ + isLeft (parseJira entity "&a-b;") @? + "entities may not contain symbols" + + , testCase "number without hash" $ + isLeft (parseJira entity "&65;") @? + "numerical entities must start with &#" + + , testCase "no name" $ + isLeft (parseJira entity "&;") @? + "entities must not be empty" + ] + + , testCase "deleted" $ + parseJira deleted "-far-fetched-" @?= + Right (Deleted [Str "far", Str "-", Str "fetched"]) + + , testGroup "emph" + [ testCase "single word" $ + parseJira emph "_single_" @?= Right (Emph [Str "single"]) + + , testCase "multi word" $ + parseJira emph "_multiple words_" @?= + Right (Emph [Str "multiple", Space, Str "words"]) + + , testCase "symbol before opening underscore" $ + parseJira (str *> emph) "#_bar_" @?= + Right (Emph [Str "bar"]) + + , testCase "neither symbol nor space before opening underscore" $ + isLeft (parseJira (str *> emph) "foo_bar_") @? "space after opening char" + + , testCase "disallow space after opening underscore" $ + isLeft (parseJira emph "_ nope_") @? "space after underscore" + + , testCase "require word boundary after closing underscore" $ + isLeft (parseJira emph "_nope_nope") @? "no boundary after closing" + + , testCase "zero with space as word boundary" $ + parseJira ((,) <$> emph <*> str) "_yup_\8203next" @?= + Right (Emph [Str "yup"], Str "\8203next") + + , testCase "fails for strong" $ + isLeft (parseJira emph "*strong*") @? "strong as emph" + ] + + , testCase "inserted" $ + parseJira inserted "+multiple words+" @?= + Right (Inserted [Str "multiple", Space, Str "words"]) + + , testCase "monospaced" $ + parseJira monospaced "{{multiple words}}" @?= + Right (Monospaced [Str "multiple", Space, Str "words"]) + + , testGroup "linebreak" + [ testCase "linebreak before text" $ + parseJira linebreak "\na" @?= + Right Linebreak + + , testCase "linebreak at eof fails" $ + isLeft (parseJira linebreak "\n") @? "newline before eof" + + , testCase "linebreak before blank line fails" $ + isLeft (parseJira linebreak "\n\n") @? "newline before blank line" + + , testCase "linebreak before list fails" $ + isLeft (parseJira linebreak "\n\n") @? "newline before list" + + , 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 "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 "link" + [ testCase "unaliased link" $ + parseJira link "[https://example.org]" @?= + Right (Link [] (URL "https://example.org")) + + , testCase "aliased link" $ + parseJira link "[Example|https://example.org]" @?= + Right (Link [Str "Example"] (URL "https://example.org")) + + , testCase "alias with emphasis" $ + parseJira link "[_important_ example|https://example.org]" @?= + Right (Link [Emph [Str "important"], Space, Str "example"] + (URL "https://example.org")) + ] + + , testGroup "image" + [ testCase "local file" $ + parseJira image "!image.jpg!" @?= + Right (Image (URL "image.jpg")) + + , testCase "no newlines" $ + isLeft (parseJira image "!hello\nworld.png!") @? + "no newlines in image names" + ] + ] + + , testGroup "inline parser" + [ testCase "simple sentence" $ + parseJira (normalizeInlines <$> many1 inline) "Hello, World!" @?= + Right [Str "Hello,", Space, Str "World!"] + + , testCase "with entity" $ + parseJira (many1 inline) "shopping at P&C" @?= + Right [ Str "shopping", Space, Str "at", Space + , Str "P", Entity "amp", Str "C"] + ] + ] diff --git a/test/Text/Jira/ParserTests.hs b/test/Text/Jira/ParserTests.hs new file mode 100644 --- /dev/null +++ b/test/Text/Jira/ParserTests.hs @@ -0,0 +1,23 @@ +{-| +Module : Text.Jira.ParserTests +Copyright : © 2019 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel +Stability : alpha +Portability : portable + +Tests for the jira wiki parser. +-} +module Text.Jira.ParserTests (tests) where + +import Data.Text () +import Test.Tasty (TestTree, testGroup) +import qualified Text.Jira.Parser.BlockTests +import qualified Text.Jira.Parser.InlineTests + +tests :: TestTree +tests = testGroup "Parser" + [ Text.Jira.Parser.InlineTests.tests + , Text.Jira.Parser.BlockTests.tests + ] diff --git a/test/jira-wiki-markup-test.hs b/test/jira-wiki-markup-test.hs new file mode 100644 --- /dev/null +++ b/test/jira-wiki-markup-test.hs @@ -0,0 +1,25 @@ +{-| +Module : Main +Copyright : © 2019 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel +Stability : alpha +Portability : portable + +Tests for the jira-wiki-markup package. +-} +module Main (main) where + +import Data.Text () +import Test.Tasty (TestTree, defaultMain, testGroup) +import qualified Text.Jira.ParserTests + +-- | Run the tests for jira-wiki-markup. +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "jira-wiki-markup" + [ Text.Jira.ParserTests.tests + ]