pandoc-include-code-0.1.0: src/Main.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes      #-}
module Main where

import qualified Data.Map              as Map

import           Data.Function         ((&))
import           Data.List             (isInfixOf)
import           Text.Pandoc.JSON
import           Text.Read
import           Text.Regex.PCRE.Heavy

type IsEscaped = Bool

encloseInListingEscape :: IsEscaped -> String -> String
encloseInListingEscape True s  = s
encloseInListingEscape False s = "@" ++ s ++ "@"

escapeForLatex :: IsEscaped -> String -> String
escapeForLatex isEscaped = concatMap escape
  where
  escape '$' = if isEscaped then "\\$" else "$"
  escape c   = [c]

replaceDashWithLatex :: IsEscaped -> String -> String
replaceDashWithLatex isEscaped = gsub ([re|(\--)|]) toLatex
  where
  toLatex ("--":_) = encloseInListingEscape isEscaped "-{}-"
  toLatex _        = ""

replaceTagWithLatex :: IsEscaped -> String -> String
replaceTagWithLatex isEscaped s = foldl replaceWith s replacements
  where
  replacements = [ ([re|<strong>(.*?)</strong>|], "\\texttt{\\textbf{", "}}")
                 , ([re|<em>(.*?)</em>|], "\\texttt{\\textit{", "}}")
                 , ([re|<sub>(.*?)</sub>|], "\\textsubscript{", "}")
                 ]
  replaceWith s' (r, pre, post) = gsub r (toLatex pre post) s'
  toLatex pre post (contents:_) =
    let replacedContents = replaceWithLatex True contents
        command = pre ++ replacedContents ++ post
    in encloseInListingEscape isEscaped command
  toLatex _ _ [] = ""

replaceWithLatex :: Bool -> String -> String
replaceWithLatex isEscaped =
  replaceDashWithLatex isEscaped . replaceTagWithLatex isEscaped . escapeForLatex isEscaped

postProcess :: Format -> String -> String
postProcess fmt contents
  | fmt == Format "latex" = unlines $ map (replaceWithLatex False) $ lines contents
  | otherwise = contents

getRange :: Map.Map String String
         -> Maybe (Int, Int)
getRange attrs = do
  start <- Map.lookup "startLine" attrs >>= readMaybe
  end <- Map.lookup "endLine" attrs >>= readMaybe
  if start <= end
     then return (start, end)
     else Nothing

withinLines :: Maybe (Int, Int) -> String -> String
withinLines range =
  case range of
    Just (start, end) ->
      unlines . take (end - startIndex) . drop startIndex . lines
      where startIndex = pred start
    Nothing           ->
      id

onlySnippet :: Map.Map String String -> String -> String
onlySnippet attrs =
  case Map.lookup "snippet" attrs of
    Just name ->
      unlines . takeWhile (not . isSnippetEnd) . drop 1 . dropWhile (not . isSnippetStart) . lines
      where
        isSnippetTag tag line = (tag ++ " snippet " ++ name) `isInfixOf` line
        isSnippetStart = isSnippetTag "start"
        isSnippetEnd = isSnippetTag "end"
    Nothing ->
      id

includeCode :: Maybe Format -> Block -> IO Block
includeCode (Just fmt) cb@(CodeBlock (id', classes, attrs) _) = do
  let attrs' = Map.fromList attrs
  case Map.lookup "include" attrs' of
    Just f -> do
      fileContents <- if "formatted" `Map.member` attrs'
                        then postProcess fmt <$> readFile f
                        else readFile f
      let filteredLines = fileContents
                          & withinLines (getRange attrs')
                          & onlySnippet attrs'
          paramNames = ["include", "formatted", "startLine", "endLine", "snippet"]
          filteredAttrs = foldl (flip Map.delete) attrs' paramNames
          classes' = unwords classes
      case fmt of
        (Format "html5") -> return (RawBlock (Format "html") ("<pre class=" ++ classes' ++ "><code>" ++ filteredLines ++ "</code></pre>"))
        _               -> return (CodeBlock (id', classes, Map.toList filteredAttrs) filteredLines)
    Nothing -> return cb
includeCode _ x = return x

main :: IO ()
main = toJSONFilter includeCode