diff --git a/filter/Main.hs b/filter/Main.hs
--- a/filter/Main.hs
+++ b/filter/Main.hs
@@ -1,21 +1,21 @@
{-# LANGUAGE LambdaCase #-}
+
module Main where
-import System.Environment
+import System.Environment
-import Text.Pandoc.JSON
import Text.Pandoc.Filter.EmphasizeCode
+import Text.Pandoc.JSON
-import Paths_pandoc_emphasize_code
-import qualified Data.Version as Version
+import qualified Data.Version as Version
+import Paths_pandoc_emphasize_code
main :: IO ()
main =
- getArgs >>=
- \case
- (arg:_)
- | arg == "-V" -> showVersion
- | arg == "--version" -> showVersion
- _ -> toJSONFilter emphasizeCode
+ getArgs >>= \case
+ (arg:_)
+ | arg == "-V" -> showVersion
+ | arg == "--version" -> showVersion
+ _ -> toJSONFilter emphasizeCode
where
showVersion = putStrLn (Version.showVersion version)
diff --git a/pandoc-emphasize-code.cabal b/pandoc-emphasize-code.cabal
--- a/pandoc-emphasize-code.cabal
+++ b/pandoc-emphasize-code.cabal
@@ -5,7 +5,7 @@
author: Oskar Wickström
maintainer: Oskar Wickström
homepage: https://github.com/owickstrom/pandoc-emphasize-code
-version: 0.2.3
+version: 0.2.4
cabal-version: >= 1.8
build-type: Simple
category: Documentation
@@ -29,6 +29,7 @@
Text.Pandoc.Filter.EmphasizeCode.Renderable
build-depends: base >= 4 && < 5
, unordered-containers >= 0.2 && < 0.3
+ , semigroups
, process
, hashable >= 1.2 && < 2
, filepath
@@ -52,6 +53,7 @@
hs-source-dirs: test
main-is: Main.hs
other-modules: Text.Pandoc.Filter.EmphasizeCodeTest
+ Text.Pandoc.Filter.EmphasizeCode.ParserTest
Text.Pandoc.Filter.EmphasizeCode.RangeTest
Text.Pandoc.Filter.EmphasizeCode.ChunkingTest
Text.Pandoc.Filter.EmphasizeCode.Testing.Ranges
@@ -63,3 +65,4 @@
, tasty-hunit
, tasty-hspec
, tasty-discover
+ , text >= 1.2 && < 1.3
diff --git a/src/Text/Pandoc/Filter/EmphasizeCode.hs b/src/Text/Pandoc/Filter/EmphasizeCode.hs
--- a/src/Text/Pandoc/Filter/EmphasizeCode.hs
+++ b/src/Text/Pandoc/Filter/EmphasizeCode.hs
@@ -4,7 +4,9 @@
module Text.Pandoc.Filter.EmphasizeCode
( emphasizeCode
) where
+
import qualified Data.HashMap.Strict as HM
+import Data.List.NonEmpty
import qualified Data.Text as Text
import qualified Text.Pandoc.JSON as Pandoc
@@ -16,8 +18,9 @@
import Text.Pandoc.Filter.EmphasizeCode.Range
import Text.Pandoc.Filter.EmphasizeCode.Renderable
-printAndFail :: ParseError -> IO a
-printAndFail = fail . Text.unpack . printParseError
+printAndFail :: NonEmpty ParseError -> IO a
+printAndFail (err :| []) = fail . Text.unpack . printParseError $ err
+printAndFail errs = fail . Text.unpack . printParseErrors $ errs
toRenderer ::
Pandoc.Format -> Maybe (Pandoc.Attr -> EmphasizedLines -> Pandoc.Block)
diff --git a/src/Text/Pandoc/Filter/EmphasizeCode/Chunking.hs b/src/Text/Pandoc/Filter/EmphasizeCode/Chunking.hs
--- a/src/Text/Pandoc/Filter/EmphasizeCode/Chunking.hs
+++ b/src/Text/Pandoc/Filter/EmphasizeCode/Chunking.hs
@@ -19,18 +19,19 @@
data LineChunk
= Literal Text
- | Emphasized Text
+ | Emphasized EmphasisStyle
+ Text
deriving (Show, Eq)
chunkText :: LineChunk -> Text
-chunkText (Literal t) = t
-chunkText (Emphasized t) = t
+chunkText (Literal t) = t
+chunkText (Emphasized _ t) = t
type EmphasizedLine = [LineChunk]
type EmphasizedLines = [EmphasizedLine]
-emphasizeRanges :: HashMap Line [LineRange] -> Text -> EmphasizedLines
+emphasizeRanges :: HashMap Line [SingleLineRange] -> Text -> EmphasizedLines
emphasizeRanges ranges contents = zipWith chunkLine (Text.lines contents) [1 ..]
where
chunkLine line' lineNr =
@@ -42,22 +43,25 @@
in filter (not . Text.null . chunkText) (chunks ++ [Literal rest])
chunkRange ::
(Text, Column, EmphasizedLine)
- -> LineRange
+ -> SingleLineRange
-> (Text, Column, EmphasizedLine)
chunkRange (lineText, offset, chunks) r =
case Text.splitAt startIndex lineText of
(before, rest) ->
- case lineRangeEnd r of
+ case singleLineRangeEnd r of
Just end ->
let endIndex = fromIntegral (end - offset) - Text.length before
(emph, rest') = Text.splitAt endIndex rest
newOffset =
offset +
fromIntegral (Text.length lineText - Text.length rest')
- in (rest', newOffset, chunks ++ [Literal before, Emphasized emph])
+ in ( rest'
+ , newOffset
+ , chunks ++ [Literal before, Emphasized style emph])
Nothing ->
( ""
, offset + fromIntegral (Text.length lineText)
- , chunks ++ [Literal before, Emphasized rest])
+ , chunks ++ [Literal before, Emphasized style rest])
where
- startIndex = fromIntegral (lineRangeStart r - 1 - offset)
+ startIndex = fromIntegral (singleLineRangeStart r - 1 - offset)
+ style = singleLineRangeStyle r
diff --git a/src/Text/Pandoc/Filter/EmphasizeCode/Html.hs b/src/Text/Pandoc/Filter/EmphasizeCode/Html.hs
--- a/src/Text/Pandoc/Filter/EmphasizeCode/Html.hs
+++ b/src/Text/Pandoc/Filter/EmphasizeCode/Html.hs
@@ -1,16 +1,19 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Text.Pandoc.Filter.EmphasizeCode.Html
- ( EmphasisTag (..)
+ ( EmphasisTag(..)
, Html(Html)
) where
-import Data.List (intersperse)
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as TextLazy
-import qualified Lucid as Html
-import qualified Text.Pandoc.Definition as Pandoc
+import Data.List (intersperse)
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TextLazy
+import qualified Lucid as Html
+import qualified Text.Pandoc.Definition as Pandoc
-import Text.Pandoc.Filter.EmphasizeCode.Chunking
-import Text.Pandoc.Filter.EmphasizeCode.Renderable
+import Text.Pandoc.Filter.EmphasizeCode.Chunking
+import Text.Pandoc.Filter.EmphasizeCode.Range
+import Text.Pandoc.Filter.EmphasizeCode.Renderable
data EmphasisTag
= Em
@@ -19,15 +22,20 @@
newtype Html =
Html EmphasisTag
-emphasisElement :: EmphasisTag -> Html.Html () -> Html.Html ()
+styleClass :: EmphasisStyle -> Html.Attribute
+styleClass Inline = Html.class_ "inline"
+styleClass Block = Html.class_ "block"
+
+emphasisElement ::
+ EmphasisTag -> [Html.Attribute] -> Html.Html () -> Html.Html ()
emphasisElement Em = Html.em_
emphasisElement Mark = Html.mark_
emphasizeChunkHtml :: EmphasisTag -> LineChunk -> Html.Html ()
emphasizeChunkHtml tag chunk =
case chunk of
- Literal t -> Html.toHtml t
- Emphasized t -> emphasisElement tag (Html.toHtml t)
+ Literal t -> Html.toHtml t
+ Emphasized style t -> emphasisElement tag [styleClass style] (Html.toHtml t)
instance Renderable Html where
renderEmphasized (Html tag) (_, classes, _) lines' =
@@ -44,5 +52,5 @@
Html.code_ $
mconcat
(intersperse
- (Html.toHtmlRaw "\n")
+ (Html.toHtmlRaw ("\n" :: Text.Text))
(map (foldMap (emphasizeChunkHtml tag)) lines'))
diff --git a/src/Text/Pandoc/Filter/EmphasizeCode/Latex.hs b/src/Text/Pandoc/Filter/EmphasizeCode/Latex.hs
--- a/src/Text/Pandoc/Filter/EmphasizeCode/Latex.hs
+++ b/src/Text/Pandoc/Filter/EmphasizeCode/Latex.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Pandoc.Filter.EmphasizeCode.Latex
@@ -11,15 +12,35 @@
import Data.Monoid
#endif
import Data.Char (isSpace)
+import Data.Text (Text)
import qualified Data.Text as Text
import qualified Text.Pandoc.Definition as Pandoc
import Text.Pandoc.Filter.EmphasizeCode.Chunking
+import Text.Pandoc.Filter.EmphasizeCode.Range
import Text.Pandoc.Filter.EmphasizeCode.Renderable
data Latex =
Latex
+escaped :: Char -> Text
+escaped = \case
+ '\\' -> "\\textbackslash{}"
+ '#' -> "\\#"
+ '&' -> "\\&"
+ '{' -> "\\{"
+ '}' -> "\\}"
+ '$' -> "\\$"
+ '_' -> "\\_"
+ '%' -> "\\%"
+ '¶' -> "\\P"
+ '§' -> "\\S"
+ '£' -> "\\£"
+ '\'' -> "\\textquotesingle{}"
+ '<' -> "\\textless{}"
+ '>' -> "\\textgreater{}"
+ c -> Text.singleton c
+
instance Renderable Latex where
renderEmphasized _ (_, classes, _) lines' =
Pandoc.RawBlock
@@ -30,19 +51,26 @@
case classes of
[lang] -> ",language=" <> Text.pack lang
_ -> ""
- encloseInTextIt t
+ encloseInTextIt style t
| Text.null t = t
- | otherwise = "£\\CodeEmphasis{" <> t <> "}£"
- emphasizeNonSpace t
+ | otherwise =
+ case style of
+ Inline -> "£\\CodeEmphasis{" <> t <> "}£"
+ Block -> "£\\CodeEmphasisLine{" <> t <> "}£"
+ emphasizeNonSpace style t
| Text.null t = t
| otherwise =
let (nonSpace, rest) = Text.break isSpace t
(spaces, rest') = Text.span isSpace rest
- in mconcat [encloseInTextIt nonSpace, spaces, emphasizeNonSpace rest']
+ in mconcat
+ [ encloseInTextIt style nonSpace
+ , spaces
+ , emphasizeNonSpace style rest'
+ ]
emphasizeChunk chunk =
case chunk of
- Literal t -> t
- Emphasized t -> emphasizeNonSpace t
+ Literal t -> t
+ Emphasized style t -> emphasizeNonSpace style (Text.concatMap escaped t)
emphasized = Text.unlines (map (foldMap emphasizeChunk) lines')
encloseInVerbatim t =
mconcat
diff --git a/src/Text/Pandoc/Filter/EmphasizeCode/Parser.hs b/src/Text/Pandoc/Filter/EmphasizeCode/Parser.hs
--- a/src/Text/Pandoc/Filter/EmphasizeCode/Parser.hs
+++ b/src/Text/Pandoc/Filter/EmphasizeCode/Parser.hs
@@ -1,30 +1,41 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Pandoc.Filter.EmphasizeCode.Parser
( Parser
, ParseError(..)
+ , parseRange
, parseRanges
, runParser
) where
-
-import Control.Monad.Except
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Text.Read (readMaybe)
+#if MIN_VERSION_base(4,8,0)
+import Data.Semigroup ((<>))
+#else
+import Control.Applicative
+import Data.Monoid
+#endif
+import Control.Monad.Except
+import qualified Data.List as L
+import Data.List.NonEmpty
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Text.Read (readMaybe)
-import Text.Pandoc.Filter.EmphasizeCode.Position
-import Text.Pandoc.Filter.EmphasizeCode.Range
+import Text.Pandoc.Filter.EmphasizeCode.Position
+import Text.Pandoc.Filter.EmphasizeCode.Range
-type Parser a = ExceptT ParseError Maybe a
+type Parser a = ExceptT (NonEmpty ParseError) Maybe a
data ParseError
- = InvalidRange Position
- Position
+ = InvalidPosRange Position
+ Position
+ | InvalidLineRange Line
+ Line
| InvalidRanges RangesError
- | InvalidRangeFormat Text
+ | InvalidPosRangeFormat Text
+ | InvalidLineRangeFormat Text
| InvalidPosition Line
Column
| InvalidPositionFormat Text
@@ -35,40 +46,64 @@
parseMaybe :: Read a => Text -> (Text -> ParseError) -> Parser a
parseMaybe t mkError =
case readMaybe (Text.unpack t) of
- Just x -> pure x
- Nothing -> throwError (mkError t)
+ Just x -> pure x
+ Nothing -> throwError (pure (mkError t))
split2 :: MonadError e m => Text -> Text -> (Text -> e) -> m (Text, Text)
split2 sep t err =
case Text.splitOn sep t of
[before, after] -> return (before, after)
- _ -> throwError (err t)
+ _ -> throwError (err t)
parsePosition :: Text -> Parser Position
parsePosition t = do
- (line, col) <- split2 ":" t InvalidPositionFormat
+ (line, col) <- split2 ":" t (pure . InvalidPositionFormat)
line' <- Line <$> parseMaybe line InvalidLineNumber
col' <- Column <$> parseMaybe col InvalidColumnNumber
case mkPosition line' col' of
Just position -> pure position
- Nothing -> throwError (InvalidPosition line' col')
+ Nothing -> throwError (pure (InvalidPosition line' col'))
-parseRange :: Text -> Parser Range
-parseRange t = do
- (startStr, endStr) <- split2 "-" t InvalidRangeFormat
+parsePosRange :: Text -> Parser PosRange
+parsePosRange t = do
+ (startStr, endStr) <- split2 "-" t (pure . InvalidPosRangeFormat)
start <- parsePosition startStr
end <- parsePosition endStr
- case mkRange start end of
+ case mkPosRange start end of
Just range -> pure range
- Nothing -> throwError (InvalidRange start end)
+ Nothing -> throwError (pure (InvalidPosRange start end))
+parseLineRange :: Text -> Parser LineRange
+parseLineRange t = do
+ (startStr, endStr) <- split2 "-" t (pure . InvalidLineRangeFormat)
+ start <- Line <$> parseMaybe startStr InvalidLineNumber
+ end <- Line <$> parseMaybe endStr InvalidLineNumber
+ case mkLineRange start end of
+ Just range -> pure range
+ Nothing -> throwError (pure (InvalidLineRange start end))
+
+parseRange :: Text -> Parser Range
+parseRange t =
+ case runExceptT (parsePosRange t) of
+ Just (Right pr) -> pure (PR pr)
+ Just (Left err1) ->
+ case runExceptT (parseLineRange t) of
+ Just (Right lr) -> pure (LR lr)
+ Just (Left err2) -> throwError (err1 <> err2)
+ Nothing -> lift Nothing
+ Nothing ->
+ case runExceptT (parseLineRange t) of
+ Just (Right lr) -> pure (LR lr)
+ Just (Left err2) -> throwError err2
+ Nothing -> lift Nothing
+
parseRanges :: Text -> Parser Ranges
parseRanges t = do
- let strs = filter (not . Text.null) (map Text.strip (Text.splitOn "," t))
+ let strs = L.filter (not . Text.null) (Text.strip <$> Text.splitOn "," t)
rs <- mapM parseRange strs
case mkRanges rs of
- Left err -> throwError (InvalidRanges err)
+ Left err -> throwError (pure (InvalidRanges err))
Right ranges -> pure ranges
-runParser :: Parser a -> Maybe (Either ParseError a)
+runParser :: Parser a -> Maybe (Either (NonEmpty ParseError) a)
runParser = runExceptT
diff --git a/src/Text/Pandoc/Filter/EmphasizeCode/Position.hs b/src/Text/Pandoc/Filter/EmphasizeCode/Position.hs
--- a/src/Text/Pandoc/Filter/EmphasizeCode/Position.hs
+++ b/src/Text/Pandoc/Filter/EmphasizeCode/Position.hs
@@ -11,7 +11,7 @@
, positionToTuple
) where
-import Data.Hashable
+import Data.Hashable
newtype Line =
Line Word
diff --git a/src/Text/Pandoc/Filter/EmphasizeCode/Pretty.hs b/src/Text/Pandoc/Filter/EmphasizeCode/Pretty.hs
--- a/src/Text/Pandoc/Filter/EmphasizeCode/Pretty.hs
+++ b/src/Text/Pandoc/Filter/EmphasizeCode/Pretty.hs
@@ -8,6 +8,7 @@
import Control.Applicative
import Data.Monoid
#endif
+import Data.Foldable (toList)
import Data.Text (Text)
import qualified Data.Text as Text
@@ -25,23 +26,35 @@
printPosition p = printLine (line p) <> ":" <> printColumn (column p)
printRange :: Range -> Text
-printRange r = printPosition (rangeStart r) <> "-" <> printPosition (rangeEnd r)
+printRange (PR pr) =
+ printPosition (posRangeStart pr) <> "-" <> printPosition (posRangeEnd pr)
+printRange (LR lr) =
+ printLine (lineRangeStart lr) <> "-" <> printLine (lineRangeEnd lr)
printRangesError :: RangesError -> Text
printRangesError err =
case err of
- EmptyRanges -> "At least one range is required"
+ EmptyRanges -> "At least one range is required"
Overlap r1 r2 -> printRange r1 <> " overlaps with " <> printRange r2
printParseError :: ParseError -> Text
printParseError err =
case err of
- InvalidRange start end ->
- "Invalid range: " <> printPosition start <> " to " <> printPosition end
+ InvalidPosRange start end ->
+ "Invalid position range: " <> printPosition start <> " to " <>
+ printPosition end
+ InvalidLineRange start end ->
+ "Invalid line range: " <> printLine start <> " to " <> printLine end
InvalidRanges rangesErr -> printRangesError rangesErr
- InvalidRangeFormat t -> "Invalid range: " <> t
+ InvalidPosRangeFormat t -> "Invalid position range: " <> t
+ InvalidLineRangeFormat t -> "Invalid line range: " <> t
InvalidPosition line' column' ->
"Invalid position: " <> printLine line' <> " to " <> printColumn column'
InvalidPositionFormat t -> "Invalid position: " <> t
InvalidLineNumber n -> "Invalid line number: " <> n
InvalidColumnNumber n -> "Invalid column number: " <> n
+
+printParseErrors :: (Functor t, Foldable t) => t ParseError -> Text
+printParseErrors errs =
+ let pretty = fmap printParseError errs
+ in Text.unlines $ "Multiple possible failures when parsing:" : toList pretty
diff --git a/src/Text/Pandoc/Filter/EmphasizeCode/Range.hs b/src/Text/Pandoc/Filter/EmphasizeCode/Range.hs
--- a/src/Text/Pandoc/Filter/EmphasizeCode/Range.hs
+++ b/src/Text/Pandoc/Filter/EmphasizeCode/Range.hs
@@ -2,22 +2,30 @@
-- | Ranges that cannot be constructed with incorrect bounds.
module Text.Pandoc.Filter.EmphasizeCode.Range
- ( Range
- , rangeStart
- , rangeEnd
- , mkRange
- , rangeToTuple
+ ( PosRange
+ , mkPosRange
+ , posRangeStart
+ , posRangeEnd
+ , posRangeToTuple
+ , LineRange
+ , mkLineRange
+ , lineRangeStart
+ , lineRangeEnd
+ , lineRangeToTuple
+ , Range(..)
, rangeToTuples
- , lineIntersectsWithRange
+ , disjoint
, Ranges
, rangesToList
, RangesError(..)
, mkRanges
- , LineRange
- , lineRangeLine
- , lineRangeStart
- , lineRangeEnd
- , mkLineRange
+ , EmphasisStyle(..)
+ , SingleLineRange
+ , singleLineRangeLine
+ , singleLineRangeStart
+ , singleLineRangeEnd
+ , singleLineRangeStyle
+ , mkSingleLineRangeInline
, splitRanges
) where
#if MIN_VERSION_base(4,8,0)
@@ -26,41 +34,72 @@
import Control.Applicative
import Data.Monoid
#endif
-import Control.Monad (foldM_, when)
+import Control.Monad (foldM_)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.List (sortOn)
import Text.Pandoc.Filter.EmphasizeCode.Position
-data Range = Range
- { rangeStart :: Position
- , rangeEnd :: Position
+data PosRange = PosRange
+ { posRangeStart :: Position
+ , posRangeEnd :: Position
} deriving (Eq, Show)
-mkRange :: Position -> Position -> Maybe Range
-mkRange s e
- | s <= e = Just (Range s e)
+mkPosRange :: Position -> Position -> Maybe PosRange
+mkPosRange s e
+ | s <= e = Just (PosRange s e)
| otherwise = Nothing
-rangeToTuple :: Range -> (Position, Position)
-rangeToTuple (Range p1 p2) = (p1, p2)
+posRangeToTuple :: PosRange -> (Position, Position)
+posRangeToTuple (PosRange p1 p2) = (p1, p2)
-rangeToTuples :: Range -> ((Line, Column), (Line, Column))
-rangeToTuples r =
- let (p1, p2) = rangeToTuple r
- in (positionToTuple p1, positionToTuple p2)
+data LineRange = LineRange
+ { lineRangeStart :: Line
+ , lineRangeEnd :: Line
+ } deriving (Eq, Show)
-rangesAreDisjoint :: Range -> Range -> Bool
-rangesAreDisjoint (Range s1 e1) (Range s2 e2) =
- (s1 < s2 && e1 < e2) || (s2 < s1 && e2 < e1)
+mkLineRange :: Line -> Line -> Maybe LineRange
+mkLineRange s e
+ | s == 0 || e == 0 = Nothing
+ | s <= e = Just (LineRange s e)
+ | otherwise = Nothing
-rangeIntersects :: Range -> Range -> Bool
-rangeIntersects r1 r2 = not (rangesAreDisjoint r1 r2)
+lineRangeToTuple :: LineRange -> (Line, Line)
+lineRangeToTuple (LineRange l1 l2) = (l1, l2)
-lineIntersectsWithRange :: Line -> Range -> Bool
-lineIntersectsWithRange l (Range start end) = line start <= l && line end >= l
+data Range
+ = PR PosRange
+ | LR LineRange
+ deriving (Eq, Show)
+wrapSndJust :: (a, b) -> (a, Maybe b)
+wrapSndJust (x, y) = (x, Just y)
+
+rangeToTuples :: Range -> ((Line, Maybe Column), (Line, Maybe Column))
+rangeToTuples (PR pr) =
+ let (p1, p2) = posRangeToTuple pr
+ in (wrapSndJust $ positionToTuple p1, wrapSndJust $ positionToTuple p2)
+rangeToTuples (LR lr) =
+ let (l1, l2) = lineRangeToTuple lr
+ in ((l1, Nothing), (l2, Nothing))
+
+disjoint :: (Ord a) => a -> a -> a -> a -> Bool
+disjoint s1 e1 s2 e2 = (e1 < s2) || (e2 < s1)
+
+rangesAreDisjoint :: Range -> Range -> Bool
+rangesAreDisjoint (PR (PosRange s1 e1)) (PR (PosRange s2 e2)) =
+ disjoint s1 e1 s2 e2
+rangesAreDisjoint (LR (LineRange s1 e1)) (LR (LineRange s2 e2)) =
+ disjoint s1 e1 s2 e2
+rangesAreDisjoint (LR (LineRange s1 e1)) (PR (PosRange s2 e2)) =
+ let (s2l, _) = positionToTuple s2
+ (e2l, _) = positionToTuple e2
+ in disjoint s1 e1 s2l e2l
+rangesAreDisjoint (PR pw) (LR lw)
+ -- Flipping argument order doesn't affect whether the ranges are disjoint
+ = rangesAreDisjoint (LR lw) (PR pw)
+
newtype Ranges =
Ranges [Range]
deriving (Eq, Show)
@@ -74,46 +113,68 @@
Range
deriving (Show, Eq)
+rangeStartPos :: Range -> Position
+rangeStartPos (PR (PosRange s _)) = s
+rangeStartPos (LR (LineRange s _)) =
+ case mkPosition s 1 of
+ Just sp -> sp
+ -- Impossible: s is a valid line (mkLineRange) and 1 is a valid column
+ Nothing -> error "rangeStartPos: failed to meet mkPosition invariant!"
+
mkRanges :: [Range] -> Either RangesError Ranges
mkRanges [] = Left EmptyRanges
mkRanges ranges = do
- let sorted = sortOn rangeStart ranges
+ let sorted = sortOn rangeStartPos ranges
foldM_ checkOverlap Nothing sorted
pure (Ranges sorted)
where
- checkOverlap (Just last') this = do
- when (last' `rangeIntersects` this) $ Left (Overlap last' this)
- return (Just this)
+ checkOverlap (Just last') this =
+ if last' `rangesAreDisjoint` this
+ then return (Just this)
+ else Left (Overlap last' this)
checkOverlap Nothing this = return (Just this)
-data LineRange = LineRange
- { lineRangeLine :: Line
- , lineRangeStart :: Column
- , lineRangeEnd :: Maybe Column
+data EmphasisStyle
+ = Inline
+ | Block
+ deriving (Eq, Show)
+
+data SingleLineRange = SingleLineRange
+ { singleLineRangeLine :: Line
+ , singleLineRangeStart :: Column
+ , singleLineRangeEnd :: Maybe Column
+ , singleLineRangeStyle :: EmphasisStyle
} deriving (Eq, Show)
-mkLineRange :: Line -> Column -> Maybe Column -> Maybe LineRange
-mkLineRange line' start (Just end)
- | line' > 0 && start < end = Just (LineRange line' start (Just end))
-mkLineRange line' start Nothing
- | line' > 0 = Just (LineRange line' start Nothing)
-mkLineRange _ _ _ = Nothing
+mkSingleLineRangeInline ::
+ Line -> Column -> Maybe Column -> Maybe SingleLineRange
+mkSingleLineRangeInline line' start (Just end)
+ | line' > 0 && start < end =
+ Just (SingleLineRange line' start (Just end) Inline)
+mkSingleLineRangeInline line' start Nothing
+ | line' > 0 = Just (SingleLineRange line' start Nothing Inline)
+mkSingleLineRangeInline _ _ _ = Nothing
-rangeToLineRanges :: Range -> [LineRange]
-rangeToLineRanges r@Range {rangeStart = p1, rangeEnd = p2}
- | line p1 == line p2 = [LineRange (line p1) (column p1) (Just (column p2))]
+rangeToSingleLineRanges :: Range -> [SingleLineRange]
+rangeToSingleLineRanges (PR pr@(PosRange p1 p2))
+ | line p1 == line p2 =
+ [SingleLineRange (line p1) (column p1) (Just (column p2)) Inline]
| line p2 > line p1 =
- let startLine = LineRange (line p1) (column p1) Nothing
- endLine = LineRange (line p2) 1 (Just (column p2))
+ let startLine = SingleLineRange (line p1) (column p1) Nothing Inline
+ endLine = SingleLineRange (line p2) 1 (Just (column p2)) Inline
middleLines =
- [LineRange n 1 Nothing | n <- [succ (line p1) .. pred (line p2)]]
+ [ SingleLineRange n 1 Nothing Inline
+ | n <- [succ (line p1) .. pred (line p2)]
+ ]
in startLine : middleLines ++ [endLine]
- | otherwise = error ("'Range' has invalid positions: " ++ show r)
+ | otherwise = error ("'PosRange' has invalid positions: " ++ show pr)
+rangeToSingleLineRanges (LR (LineRange l1 l2)) =
+ [SingleLineRange n 1 Nothing Block | n <- [l1 .. l2]]
-splitRanges :: Ranges -> HashMap Line [LineRange]
+splitRanges :: Ranges -> HashMap Line [SingleLineRange]
splitRanges ranges =
HashMap.fromListWith
(flip (<>))
- [ (lineRangeLine lr, [lr])
- | lr <- concatMap rangeToLineRanges (rangesToList ranges)
+ [ (singleLineRangeLine lr, [lr])
+ | lr <- concatMap rangeToSingleLineRanges (rangesToList ranges)
]
diff --git a/src/Text/Pandoc/Filter/EmphasizeCode/Renderable.hs b/src/Text/Pandoc/Filter/EmphasizeCode/Renderable.hs
--- a/src/Text/Pandoc/Filter/EmphasizeCode/Renderable.hs
+++ b/src/Text/Pandoc/Filter/EmphasizeCode/Renderable.hs
@@ -1,6 +1,6 @@
module Text.Pandoc.Filter.EmphasizeCode.Renderable where
-import qualified Text.Pandoc.JSON as Pandoc
+import qualified Text.Pandoc.JSON as Pandoc
import Text.Pandoc.Filter.EmphasizeCode.Chunking
diff --git a/test/Text/Pandoc/Filter/EmphasizeCode/ChunkingTest.hs b/test/Text/Pandoc/Filter/EmphasizeCode/ChunkingTest.hs
--- a/test/Text/Pandoc/Filter/EmphasizeCode/ChunkingTest.hs
+++ b/test/Text/Pandoc/Filter/EmphasizeCode/ChunkingTest.hs
@@ -11,22 +11,27 @@
spec_emphasizeRanges = do
it "emphasizes a single line range" $ do
- rs <- splitRanges <$> mkRanges' [((1, 1), (1, 7))]
+ rs <- splitRanges <$> mkPosRanges' [((1, 1), (1, 7))]
emphasizeRanges rs "hello world" `shouldBe`
- [[Emphasized "hello w", Literal "orld"]]
+ [[Emphasized Inline "hello w", Literal "orld"]]
it "emphasizes multiple line ranges on a single line" $ do
- rs <- splitRanges <$> mkRanges' [((1, 1), (1, 3)), ((1, 5), (1, 8))]
+ rs <- splitRanges <$> mkPosRanges' [((1, 1), (1, 3)), ((1, 5), (1, 8))]
emphasizeRanges rs "hello world" `shouldBe`
- [[Emphasized "hel", Literal "l", Emphasized "o wo", Literal "rld"]]
+ [ [ Emphasized Inline "hel"
+ , Literal "l"
+ , Emphasized Inline "o wo"
+ , Literal "rld"
+ ]
+ ]
it "emphasizes multiple line ranges on multiple lines" $ do
rs <-
splitRanges <$>
- mkRanges' [((1, 1), (1, 5)), ((1, 7), (2, 3)), ((4, 5), (4, 10))]
+ mkPosRanges' [((1, 1), (1, 5)), ((1, 7), (2, 3)), ((4, 5), (4, 10))]
emphasizeRanges rs "hello world\nhej världen\nhallo welt\nhei verden" `shouldBe`
- [ [Emphasized "hello", Literal " ", Emphasized "world"]
- , [Emphasized "hej", Literal " världen"]
+ [ [Emphasized Inline "hello", Literal " ", Emphasized Inline "world"]
+ , [Emphasized Inline "hej", Literal " världen"]
, [Literal "hallo welt"]
- , [Literal "hei ", Emphasized "verden"]
+ , [Literal "hei ", Emphasized Inline "verden"]
]
{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}
diff --git a/test/Text/Pandoc/Filter/EmphasizeCode/ParserTest.hs b/test/Text/Pandoc/Filter/EmphasizeCode/ParserTest.hs
new file mode 100644
--- /dev/null
+++ b/test/Text/Pandoc/Filter/EmphasizeCode/ParserTest.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+
+module Text.Pandoc.Filter.EmphasizeCode.ParserTest where
+
+import Control.Monad (forM_)
+import Data.List.NonEmpty
+import qualified Data.Text as T
+
+import Test.Tasty.Hspec
+import Text.Pandoc.Filter.EmphasizeCode.Parser
+import Text.Pandoc.Filter.EmphasizeCode.Position
+import Text.Pandoc.Filter.EmphasizeCode.Range
+import Text.Pandoc.Filter.EmphasizeCode.Testing.Ranges
+
+spec_parseRangeOk = do
+ it "parses a simple PosRange" $ do
+ r <- PR <$> mkPosRange' ((2, 3), (2, 14))
+ runParser (parseRange "2:3-2:14") `shouldBe` Just (Right r)
+ it "parses a simple LineRange" $ do
+ r <- LR <$> mkLineRange' (2, 3)
+ runParser (parseRange "2-3") `shouldBe` Just (Right r)
+
+errorTests :: [(T.Text, NonEmpty ParseError)]
+errorTests =
+ [ ("2;3-2:14", InvalidPositionFormat "2;3" :| [InvalidLineNumber "2;3"])
+ , ("a:3-2:14", InvalidLineNumber "a" :| [InvalidLineNumber "a:3"])
+ , ("2:z-2:14", InvalidColumnNumber "z" :| [InvalidLineNumber "2:z"])
+ , ( "0:3-2:14"
+ , InvalidPosition (Line 0) (Column 3) :| [InvalidLineNumber "0:3"])
+ , ( "2:0-2:14"
+ , InvalidPosition (Line 2) (Column 0) :| [InvalidLineNumber "2:0"])
+ , ( "2:3 2:14"
+ , InvalidPosRangeFormat "2:3 2:14" :| [InvalidLineRangeFormat "2:3 2:14"])
+ ]
+
+spec_parseRangeError = do
+ forM_ errorTests $ \(input, expected) ->
+ it (T.unpack input ++ " throws " ++ show expected) $ do
+ runParser (parseRange input) `shouldBe` Just (Left expected)
+
+isValid (Just (Right _)) = True
+isValid _ = False
+
+isInvalidPosRange :: Maybe (Either (NonEmpty ParseError) b) -> Bool
+isInvalidPosRange (Just (Left (InvalidPosRange _ _ :| []))) = True
+isInvalidPosRange _ = False
+
+isInvalidPosRangeLineNumber :: Maybe (Either (NonEmpty ParseError) b) -> Bool
+isInvalidPosRangeLineNumber x =
+ case x of
+ (Just (Left (InvalidPosRange _ _ :| [InvalidLineNumber _]))) -> True
+ _ -> False
+
+errorPosRangeTests = ["2:3-1:1"]
+
+spec_parseRangeInvalidPosRange = do
+ forM_ errorPosRangeTests $ \input ->
+ it (T.unpack input ++ " throws InvalidPosRange") $ do
+ runParser (parseRange input) `shouldSatisfy` isInvalidPosRangeLineNumber
+
+spec_parseRangeEdgeCases = do
+ it "should handle single character position range" $ do
+ runParser (parseRange "2:3-2:3") `shouldSatisfy` isValid
+ it "LineRange end should be inclusive" $ do
+ runParser (parseRange "1-1") `shouldSatisfy` isValid
+
+{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}
diff --git a/test/Text/Pandoc/Filter/EmphasizeCode/RangeTest.hs b/test/Text/Pandoc/Filter/EmphasizeCode/RangeTest.hs
--- a/test/Text/Pandoc/Filter/EmphasizeCode/RangeTest.hs
+++ b/test/Text/Pandoc/Filter/EmphasizeCode/RangeTest.hs
@@ -4,51 +4,105 @@
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (mapMaybe)
+import Data.Tuple (swap)
import Test.Tasty.Hspec
import Text.Pandoc.Filter.EmphasizeCode.Position
import Text.Pandoc.Filter.EmphasizeCode.Range
import Text.Pandoc.Filter.EmphasizeCode.Testing.Ranges
-makeLineRanges :: [(Line, Column, Maybe Column)] -> [LineRange]
-makeLineRanges = mapMaybe mkLineRange'
- where
- mkLineRange' (line', start, end) = mkLineRange line' start end
+-- Defaulting to Int instead of (Ord a => a) here to avoid ambiguous type vars
+testDisjoint :: ((Int, Int), (Int, Int)) -> Bool -> Expectation
+testDisjoint ((s1, e1), (s2, e2)) expected =
+ disjoint s1 e1 s2 e2 `shouldBe` expected
-spec_mkRanges = do
+spec_disjoint = do
+ it "is disjoint when zero ends are contained by the other" $ do
+ let input = ((1, 2), (3, 9))
+ testDisjoint input True
+ testDisjoint (swap input) True
+ it "is not disjoint when one end is contained by the other" $ do
+ let input = ((1, 4), (3, 9))
+ testDisjoint input False
+ testDisjoint (swap input) False
+ it "is not disjoint when one end equals the other (ends are inclusive!)" $ do
+ let input = ((1, 3), (3, 9))
+ testDisjoint input False
+ testDisjoint (swap input) False
+ it "is not disjoint when one range is completely contained by the other" $ do
+ let input = ((1, 9), (3, 7))
+ testDisjoint input False
+ testDisjoint (swap input) False
+
+spec_mkRanges_PosRange = do
it "accepts single-position range" $ do
- rs <- mkRanges' [((1, 1), (1, 1))]
- map rangeToTuples (rangesToList rs) `shouldBe` [((1, 1), (1, 1))]
- it "sorts ranges" $ do
- rs <- mkRanges' [((1, 1), (1, 7)), ((4, 1), (7, 2)), ((1, 8), (3, 4))]
+ rs <- mkPosRanges' [((1, 1), (1, 1))]
+ map rangeToTuples (rangesToList rs) `shouldBe` [((1, Just 1), (1, Just 1))]
+ it "sorts position ranges" $ do
+ rs <- mkPosRanges' [((1, 1), (1, 7)), ((4, 1), (7, 2)), ((1, 8), (3, 4))]
map rangeToTuples (rangesToList rs) `shouldBe`
- [((1, 1), (1, 7)), ((1, 8), (3, 4)), ((4, 1), (7, 2))]
- it "does not accept empty ranges" $
- mkRanges' [] `shouldThrow` anyException
+ [ ((1, Just 1), (1, Just 7))
+ , ((1, Just 8), (3, Just 4))
+ , ((4, Just 1), (7, Just 2))
+ ]
+ it "does not accept empty position ranges" $ do
+ mkPosRanges' [] `shouldThrow` anyException
+spec_mkRanges_LineRange = do
+ it "accepts single-line range" $ do
+ rs <- mkLineRanges' [(1, 1)]
+ map rangeToTuples (rangesToList rs) `shouldBe`
+ [((1, Nothing), (1, Nothing))]
+ it "sorts line ranges" $ do
+ rs <- mkLineRanges' [(1, 1), (4, 7), (2, 3)]
+ map rangeToTuples (rangesToList rs) `shouldBe`
+ [ ((1, Nothing), (1, Nothing))
+ , ((2, Nothing), (3, Nothing))
+ , ((4, Nothing), (7, Nothing))
+ ]
+ it "does not accept empty line ranges" $ do
+ mkLineRanges' [] `shouldThrow` anyException
+
+spec_mkRanges_Both = do
+ it "supports mixing and matching position and line ranges" $ do
+ rs <- mkRanges' [((2, 10), (4, 15)), ((7, 11), (8, 22))] [(5, 6)]
+ map rangeToTuples (rangesToList rs) `shouldBe`
+ [ ((2, Just 10), (4, Just 15))
+ , ((5, Nothing), (6, Nothing))
+ , ((7, Just 11), (8, Just 22))
+ ]
+
+makeSingleLineRanges :: [(Line, Column, Maybe Column)] -> [SingleLineRange]
+makeSingleLineRanges = mapMaybe mkSingleLineRange'
+ where
+ mkSingleLineRange' (line', start, end) =
+ mkSingleLineRangeInline line' start end
+
+-- TODO(jez) Test splitRange on LineRange's, not just PosRange's
spec_splitRanges = do
it "splits one range into line ranges" $ do
- rs <- mkRanges' [((1, 1), (1, 7))]
- let lrs = HashMap.fromList [(1, makeLineRanges [(1, 1, Just 7)])]
+ rs <- mkPosRanges' [((1, 1), (1, 7))]
+ let lrs = HashMap.fromList [(1, makeSingleLineRanges [(1, 1, Just 7)])]
splitRanges rs `shouldBe` lrs
it "splits two ranges into line ranges" $ do
- rs <- mkRanges' [((1, 1), (1, 7)), ((1, 8), (2, 2))]
+ rs <- mkPosRanges' [((1, 1), (1, 7)), ((1, 8), (2, 2))]
let lrs =
HashMap.fromList
- [ (1, makeLineRanges [(1, 1, Just 7), (1, 8, Nothing)])
- , (2, makeLineRanges [(2, 1, Just 2)])
+ [ (1, makeSingleLineRanges [(1, 1, Just 7), (1, 8, Nothing)])
+ , (2, makeSingleLineRanges [(2, 1, Just 2)])
]
splitRanges rs `shouldBe` lrs
it "splits multiple ranges into line ranges" $ do
- rs <- mkRanges' [((1, 1), (1, 7)), ((1, 8), (3, 4)), ((8, 2), (10, 2))]
+ rs <- mkPosRanges' [((1, 1), (1, 7)), ((1, 8), (3, 4)), ((8, 2), (10, 2))]
let lrs =
HashMap.fromList
- [ (1, makeLineRanges [(1, 1, Just 7), (1, 8, Nothing)])
- , (2, makeLineRanges [(2, 1, Nothing)])
- , (3, makeLineRanges [(3, 1, Just 4)])
- , (8, makeLineRanges [(8, 2, Nothing)])
- , (9, makeLineRanges [(9, 1, Nothing)])
- , (10, makeLineRanges [(10, 1, Just 2)])
+ [ (1, makeSingleLineRanges [(1, 1, Just 7), (1, 8, Nothing)])
+ , (2, makeSingleLineRanges [(2, 1, Nothing)])
+ , (3, makeSingleLineRanges [(3, 1, Just 4)])
+ , (8, makeSingleLineRanges [(8, 2, Nothing)])
+ , (9, makeSingleLineRanges [(9, 1, Nothing)])
+ , (10, makeSingleLineRanges [(10, 1, Just 2)])
]
splitRanges rs `shouldBe` lrs
+
{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}
diff --git a/test/Text/Pandoc/Filter/EmphasizeCode/Testing/Ranges.hs b/test/Text/Pandoc/Filter/EmphasizeCode/Testing/Ranges.hs
--- a/test/Text/Pandoc/Filter/EmphasizeCode/Testing/Ranges.hs
+++ b/test/Text/Pandoc/Filter/EmphasizeCode/Testing/Ranges.hs
@@ -1,15 +1,37 @@
module Text.Pandoc.Filter.EmphasizeCode.Testing.Ranges where
-import Data.Maybe (mapMaybe)
-
import Text.Pandoc.Filter.EmphasizeCode.Position
import Text.Pandoc.Filter.EmphasizeCode.Range
-mkRanges' :: [((Line, Column), (Line, Column))] -> IO Ranges
-mkRanges' rs = either (fail . show) return (mkRanges (mapMaybe makeRange rs))
+mkPosRange' :: ((Line, Column), (Line, Column)) -> IO PosRange
+mkPosRange' rcrc = do
+ case makePosRange rcrc of
+ Nothing -> fail "Invalid PosRange in test case"
+ Just pr -> return pr
where
- makeRange ((r1, c1), (r2, c2)) = do
+ makePosRange ((r1, c1), (r2, c2)) = do
p1 <- mkPosition r1 c1
p2 <- mkPosition r2 c2
- mkRange p1 p2
+ mkPosRange p1 p2
+mkPosRanges' :: [((Line, Column), (Line, Column))] -> IO Ranges
+mkPosRanges' rs = do
+ posRanges <- map PR <$> mapM mkPosRange' rs
+ either (fail . show) return (mkRanges posRanges)
+
+mkLineRange' :: (Line, Line) -> IO LineRange
+mkLineRange' (l1, l2) = do
+ case mkLineRange l1 l2 of
+ Nothing -> fail "Invalid LineRange in test case"
+ Just pr -> return pr
+
+mkLineRanges' :: [(Line, Line)] -> IO Ranges
+mkLineRanges' rs = do
+ lineRanges <- map LR <$> mapM mkLineRange' rs
+ either (fail . show) return (mkRanges lineRanges)
+
+mkRanges' :: [((Line, Column), (Line, Column))] -> [(Line, Line)] -> IO Ranges
+mkRanges' prs lrs = do
+ posRanges <- map PR <$> mapM mkPosRange' prs
+ lineRanges <- map LR <$> mapM mkLineRange' lrs
+ either (fail . show) return (mkRanges $ posRanges ++ lineRanges)
diff --git a/test/Text/Pandoc/Filter/EmphasizeCodeTest.hs b/test/Text/Pandoc/Filter/EmphasizeCodeTest.hs
--- a/test/Text/Pandoc/Filter/EmphasizeCodeTest.hs
+++ b/test/Text/Pandoc/Filter/EmphasizeCodeTest.hs
@@ -14,8 +14,8 @@
"html"
(mconcat
[ "hello world\n"
- , "hej världen\n"
- , "hallo welt\n"
+ , "hej världen\n"
+ , "hallo welt\n"
, "hei verden
"
])
@@ -25,8 +25,8 @@
"html"
(mconcat
[ "hello world\n"
- , "hej världen\n"
- , "hallo welt\n"
+ , "hej världen\n"
+ , "hallo welt\n"
, "hei verden
"
])
@@ -39,26 +39,46 @@
"hello world\nhej världen\nhallo welt\nhei verden")
spec_emphasizeCode = do
- it "emphasizes HTML and a single range" $
+ it "emphasizes HTML and a single position range" $
emphasizeCode "html5" "2:5-3:5" `shouldReturn` singleRangeHtmlMark
- it "emphasizes HTML and a single range over multiple lines" $
+ it "emphasizes HTML and a single position range over multiple lines" $
emphasizeCode "html5" "2:5-4:3" `shouldReturn`
RawBlock
"html"
(mconcat
[ "hello world\n"
- , "hej världen\n"
- , "hallo welt\n"
- , "hei verden
"
+ , "hej världen\n"
+ , "hallo welt\n"
+ , "hei verden"
])
+ it "emphasizes HTML and a single line range" $
+ emphasizeCode "html5" "2-3" `shouldReturn`
+ RawBlock
+ "html"
+ (mconcat
+ [ "hello world\n"
+ , "hej världen\n"
+ , "hallo welt\n"
+ , "hei verden
"
+ ])
it "emphasizes HTML and multiple ranges" $
emphasizeCode "html5" "1:1-1:5,2:5-3:5" `shouldReturn`
RawBlock
"html"
(mconcat
- [ "hello world\n"
- , "hej världen\n"
- , "hallo welt\n"
+ [ "hello world\n"
+ , "hej världen\n"
+ , "hallo welt\n"
+ , "hei verden
"
+ ])
+ it "emphasizes HTML and multiple ranges (mixing range types)" $
+ emphasizeCode "html5" "1-1,2:5-3:5" `shouldReturn`
+ RawBlock
+ "html"
+ (mconcat
+ [ "hello world\n"
+ , "hej världen\n"
+ , "hallo welt\n"
, "hei verden
"
])
it "emphasizes RevealJS HTML using " $