pandoc-emphasize-code 0.2.3 → 0.2.4

raw patch · 16 files changed

+503/−179 lines, 16 filesdep +semigroupsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: semigroups

API changes (from Hackage documentation)

Files

• filter/Main.hs +10/−10
• pandoc-emphasize-code.cabal +4/−1
• src/Text/Pandoc/Filter/EmphasizeCode.hs +5/−2
• src/Text/Pandoc/Filter/EmphasizeCode/Chunking.hs +13/−9
• src/Text/Pandoc/Filter/EmphasizeCode/Html.hs +20/−12
• src/Text/Pandoc/Filter/EmphasizeCode/Latex.hs +34/−6
• src/Text/Pandoc/Filter/EmphasizeCode/Parser.hs +62/−27
• src/Text/Pandoc/Filter/EmphasizeCode/Position.hs +1/−1
• src/Text/Pandoc/Filter/EmphasizeCode/Pretty.hs +18/−5
• src/Text/Pandoc/Filter/EmphasizeCode/Range.hs +116/−55
• src/Text/Pandoc/Filter/EmphasizeCode/Renderable.hs +1/−1
• test/Text/Pandoc/Filter/EmphasizeCode/ChunkingTest.hs +13/−8
• test/Text/Pandoc/Filter/EmphasizeCode/ParserTest.hs +68/−0
• test/Text/Pandoc/Filter/EmphasizeCode/RangeTest.hs +78/−24
• test/Text/Pandoc/Filter/EmphasizeCode/Testing/Ranges.hs +28/−6
• test/Text/Pandoc/Filter/EmphasizeCodeTest.hs +32/−12

@@ -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)

@@ -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

@@ -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)

@@ -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

@@ -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'))

@@ -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

@@ -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

@@ -11,7 +11,7 @@   , positionToTuple   ) where -import Data.Hashable+import           Data.Hashable  newtype Line =   Line Word

@@ -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

@@ -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)     ]

@@ -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 

@@ -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) #-}

@@ -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) #-}

@@ -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) #-}

@@ -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)

@@ -14,8 +14,8 @@     "html"     (mconcat        [ "<pre class=\"my-lang\"><code>hello world\n"-       , "hej <mark>världen</mark>\n"-       , "<mark>hallo</mark> welt\n"+       , "hej <mark class=\"inline\">världen</mark>\n"+       , "<mark class=\"inline\">hallo</mark> welt\n"        , "hei verden</code></pre>"        ]) @@ -25,8 +25,8 @@     "html"     (mconcat        [ "<pre class=\"my-lang\"><code>hello world\n"-       , "hej <em>världen</em>\n"-       , "<em>hallo</em> welt\n"+       , "hej <em class=\"inline\">världen</em>\n"+       , "<em class=\"inline\">hallo</em> welt\n"        , "hei verden</code></pre>"        ]) @@ -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          [ "<pre class=\"my-lang\"><code>hello world\n"-         , "hej <mark>världen</mark>\n"-         , "<mark>hallo welt</mark>\n"-         , "<mark>hei</mark> verden</code></pre>"+         , "hej <mark class=\"inline\">världen</mark>\n"+         , "<mark class=\"inline\">hallo welt</mark>\n"+         , "<mark class=\"inline\">hei</mark> verden</code></pre>"          ])+  it "emphasizes HTML and a single line range" $+    emphasizeCode "html5" "2-3" `shouldReturn`+    RawBlock+      "html"+      (mconcat+         [ "<pre class=\"my-lang\"><code>hello world\n"+         , "<mark class=\"block\">hej världen</mark>\n"+         , "<mark class=\"block\">hallo welt</mark>\n"+         , "hei verden</code></pre>"+         ])   it "emphasizes HTML and multiple ranges" $     emphasizeCode "html5" "1:1-1:5,2:5-3:5" `shouldReturn`     RawBlock       "html"       (mconcat-         [ "<pre class=\"my-lang\"><code><mark>hello</mark> world\n"-         , "hej <mark>världen</mark>\n"-         , "<mark>hallo</mark> welt\n"+         [ "<pre class=\"my-lang\"><code><mark class=\"inline\">hello</mark> world\n"+         , "hej <mark class=\"inline\">världen</mark>\n"+         , "<mark class=\"inline\">hallo</mark> welt\n"+         , "hei verden</code></pre>"+         ])+  it "emphasizes HTML and multiple ranges (mixing range types)" $+    emphasizeCode "html5" "1-1,2:5-3:5" `shouldReturn`+    RawBlock+      "html"+      (mconcat+         [ "<pre class=\"my-lang\"><code><mark class=\"block\">hello world</mark>\n"+         , "hej <mark class=\"inline\">världen</mark>\n"+         , "<mark class=\"inline\">hallo</mark> welt\n"          , "hei verden</code></pre>"          ])   it "emphasizes RevealJS HTML using <mark>" $