Pandoc.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | This module defines a 'CiteprocOutput' instance for pandoc 'Inlines'.
module Citeproc.Pandoc
  ()
where
import Text.Pandoc.Definition
import Text.Pandoc.Builder as B
import Text.Pandoc.Walk
import qualified Data.Text as T
import qualified Data.Sequence as Seq
import Data.Text (Text)
import Citeproc.Types
import Citeproc.CaseTransform
import Control.Monad.Trans.State.Strict as S
import Control.Monad (unless, when)
import Data.Char (isSpace, isPunctuation, isAlphaNum)

instance CiteprocOutput Inlines where
  isEmpty               = null
  toText                = stringify
  fromText t            = (if " " `T.isPrefixOf` t
                              then B.space
                              else mempty) <>
                          B.text t <> -- B.text eats leading/trailing spaces
                          (if " " `T.isSuffixOf` t
                              then B.space
                              else mempty)
  dropTextWhile         = dropTextWhile'
  dropTextWhileEnd      = dropTextWhileEnd'
  addFontVariant x      =
    case x of
      NormalVariant    -> id
      SmallCapsVariant -> B.smallcaps
  addFontStyle x        =
    case x of
      NormalFont       -> id
      ItalicFont       -> B.emph
      ObliqueFont      -> B.emph
  addFontWeight x       =
    case x of
      NormalWeight     -> id
      LightWeight      -> id
      BoldWeight       -> B.strong
  addTextDecoration x   =
    case x of
      NoDecoration        -> B.spanWith ("",["nodecoration"],[])
      UnderlineDecoration -> B.underline
  addVerticalAlign x    =
    case x of
      BaselineAlign    -> id
      SubAlign         -> B.subscript
      SupAlign         -> B.superscript
  addTextCase mblang x =
    case x of
      Lowercase        -> caseTransform mblang withLowercaseAll
      Uppercase        -> caseTransform mblang withUppercaseAll
      CapitalizeFirst  -> caseTransform mblang withCapitalizeFirst
      CapitalizeAll    -> caseTransform mblang withCapitalizeWords
      SentenceCase     -> caseTransform mblang withSentenceCase
      TitleCase        -> caseTransform mblang withTitleCase
      PreserveCase     -> B.spanWith ("",["nocase"],[])
  addDisplay x          =
    case x of
      DisplayBlock       -> B.spanWith ("",["csl-block"],[])
      DisplayLeftMargin  -> B.spanWith ("",["csl-left-margin"],[])
      DisplayRightInline -> B.spanWith ("",["csl-right-inline"],[])
      DisplayIndent      -> B.spanWith ("",["csl-indent"],[])
  addQuotes             = B.spanWith ("",["csl-quoted"],[])
  inNote                = B.spanWith ("",["csl-note"],[])
  movePunctuationInsideQuotes
                        = punctuationInsideQuotes
  mapText f             = walk go
    where go (Str t) = Str (f t)
          go x       = x
  addHyperlink t        = B.link t ""
  localizeQuotes        = convertQuotes

-- localized quotes
convertQuotes :: Locale -> Inlines -> Inlines
convertQuotes locale = B.fromList . map (go DoubleQuote) . B.toList
 where
  ((oqOuter, cqOuter), (oqInner, cqInner)) = lookupQuotes locale

  oq DoubleQuote  = oqOuter
  oq SingleQuote  = oqInner
  cq DoubleQuote  = cqOuter
  cq SingleQuote  = cqInner

  flipflop SingleQuote = DoubleQuote
  flipflop DoubleQuote = SingleQuote

  go :: QuoteType -> Inline -> Inline
  go q (Span ("",["csl-quoted"],[]) ils) =
    Span ("",["csl-quoted"],[])
      (Str (oq q) : map (go (flipflop q)) ils ++ [Str (cq q)])
  go q (Span attr zs) = Span attr (map (go q) zs)
  go q (Quoted qt' zs) = Quoted qt' (map (go q) zs)
  go q (SmallCaps zs) = SmallCaps (map (go q) zs)
  go q (Superscript zs) = Superscript (map (go q) zs)
  go q (Subscript zs) = Subscript (map (go q) zs)
  go q (Emph zs) = Emph (map (go q) zs)
  go q (Underline zs) = Underline (map (go q) zs)
  go q (Strong zs) = Strong (map (go q) zs)
  go q (Strikeout zs) = Strikeout (map (go q) zs)
  go q (Cite cs zs) = Cite cs (map (go q) zs)
  go q (Link attr zs t) = Link attr (map (go q) zs) t
  go q (Image attr zs t) = Image attr (map (go q) zs) t
  go _ x = x

punctuationInsideQuotes :: Inlines -> Inlines
punctuationInsideQuotes = B.fromList . go . walk go . B.toList
 where
  startsWithMovable t =
    case T.uncons t of
      Just (c,_) -> c == '.' || c == ','
      Nothing    -> False
  go [] = []
  go (Span ("",["csl-quoted"],[]) xs : Str t : rest)
    | startsWithMovable t
      = Span ("",["csl-quoted"],[])
           (xs ++ [Str (T.take 1 t) | not (endWithPunct xs)]) :
        if T.length t == 1
           then go rest
           else Str (T.drop 1 t) : go rest
  go (Quoted qt xs : Str t : rest)
    | startsWithMovable t
      = Quoted qt
           (xs ++ [Str (T.take 1 t) | not (endWithPunct xs)]) :
        if T.length t == 1
           then go rest
           else Str (T.drop 1 t) : go rest
  go (x:xs) = x : go xs

endWithPunct :: [Inline] -> Bool
endWithPunct [] = False
endWithPunct xs =
  case T.unsnoc (stringify xs) of
    Nothing     -> True   -- no text content
    Just (_, c) -> c `elem` (".,;:!?" :: String)

-- Trimming can reduce a Str, Space, or SoftBreak to an empty Str;
-- remove these leftovers, at all nesting levels.
removeEmptyStrs :: Inlines -> Inlines
removeEmptyStrs = B.fromList . walk (filter (/= Str "")) . B.toList

dropTextWhile' :: (Char -> Bool) -> Inlines -> Inlines
dropTextWhile' f ils = removeEmptyStrs $ evalState (walkM go ils) True
 where
  go x = do
    atStart <- get
    if atStart
       then
         case x of
           Str t -> do
             let t' = T.dropWhile f t
             unless (T.null t') $
               put False
             return $ Str t'
           _ | x == Space || x == SoftBreak ->
             if f ' '
                then return $ Str ""
                else do
                  put False
                  return Space
             | otherwise  -> return x
       else return x


-- The state records whether we are still at the end, i.e. have not
-- yet encountered a character that shouldn't be dropped.  We need an
-- explicit traversal (rather than walkM over Reverse) so that the
-- children of nested inlines are also processed from right to left.
dropTextWhileEnd' :: (Char -> Bool) -> Inlines -> Inlines
dropTextWhileEnd' f ils =
  removeEmptyStrs $ evalState (fmap B.fromList . goList . B.toList $ ils) True
 where
  goList :: [Inline] -> State Bool [Inline]
  goList = fmap reverse . mapM go . reverse
  go :: Inline -> State Bool Inline
  go x = do
    atEnd <- get
    if atEnd
       then
         case x of
           Str t -> do
             let t' = T.dropWhileEnd f t
             unless (T.null t') $
               put False
             return $ Str t'
           Space
             | f ' '     -> return $ Str ""
             | otherwise -> put False >> return x
           SoftBreak
             | f ' '     -> return $ Str ""
             | otherwise -> put False >> return x
           Emph xs -> Emph <$> goList xs
           Underline xs -> Underline <$> goList xs
           Strong xs -> Strong <$> goList xs
           Strikeout xs -> Strikeout <$> goList xs
           Superscript xs -> Superscript <$> goList xs
           Subscript xs -> Subscript <$> goList xs
           SmallCaps xs -> SmallCaps <$> goList xs
           Quoted qt xs -> Quoted qt <$> goList xs
           Cite cs xs -> Cite cs <$> goList xs
           Span attr xs -> Span attr <$> goList xs
           Link attr xs t -> (\xs' -> Link attr xs' t) <$> goList xs
           Image attr xs t -> (\xs' -> Image attr xs' t) <$> goList xs
           _ -> return x
       else return x

-- taken from Text.Pandoc.Shared:

-- | Convert pandoc structure to a string with formatting removed.
-- Footnotes are skipped (since we don't want their contents in link
-- labels).
stringify :: Walkable Inline a => a -> T.Text
stringify = query go . walk (unNote . unQuote)
 where
  go :: Inline -> T.Text
  go Space                                       = " "
  go SoftBreak                                   = " "
  go (Str x)                                     = x
  go (Code _ x)                                  = x
  go (Math _ x)                                  = x
  go (RawInline (Format "html") (T.unpack -> ('<':'b':'r':_)))
                                                 = " " -- see #2105
  go LineBreak                                   = " "
  go _                                           = ""

  unNote :: Inline -> Inline
  unNote (Note _) = Str ""
  unNote x        = x

  unQuote :: Inline -> Inline
  unQuote (Quoted SingleQuote xs) =
    Span ("",[],[]) (Str "\8216" : xs ++ [Str "\8217"])
  unQuote (Quoted DoubleQuote xs) =
    Span ("",[],[]) (Str "\8220" : xs ++ [Str "\8221"])
  unQuote x = x


caseTransform :: Maybe Lang
              -> CaseTransformer
              -> Inlines
              -> Inlines
caseTransform mblang f x =
  evalState (caseTransform' (unCaseTransformer f mblang) x) Start


-- custom traversal which does not descend into
-- SmallCaps, Superscript, Subscript, Span "nocase" (implicit nocase)
caseTransform' :: (CaseTransformState -> Text -> Text)
               -> Inlines
               -> State CaseTransformState Inlines
caseTransform' f ils =
  case Seq.viewr (unMany ils) of
    xs Seq.:> Str t | not (Seq.null xs)
                    , not (hasWordBreak t) -> do
        xs' <- mapM go xs
        st <- get
        when (st == AfterWordEnd || st == StartSentence || st == Start) $
          put BeforeLastWord
        x' <- go (Str t)
        return $ Many $ xs' Seq.|> x'
    _ -> mapM go ils
 where
  go (Str t) = Str . mconcat <$> mapM g (splitUp t)
  go Space = Space <$ g " "
  go (SmallCaps zs) = return' $ SmallCaps zs
  go (Superscript zs) = return' $ Superscript zs
  go (Subscript zs) = return' $ Subscript zs
  go (Span attr@(_,classes,_) zs)
      | "nocase" `elem` classes = do
            st <- get
            case st of
              AfterWordChar | classes == ["nocase"]
                -> return' $ Span nullAttr zs
              _ -> return' $ Span attr zs
      | otherwise = Span attr <$> mapM go zs
  go (Emph zs) = Emph <$> mapM go zs
  go (Underline zs) = Underline <$> mapM go zs
  go (Strong zs) = Strong <$> mapM go zs
  go (Strikeout zs) = Strikeout <$> mapM go zs
  go (Quoted qt zs) = Quoted qt <$> mapM go zs
  go (Cite cs zs) = Cite cs <$> mapM go zs
  go (Link attr zs t) = (\x -> Link attr x t) <$> mapM go zs
  go (Image attr zs t) = (\x -> Image attr x t) <$> mapM go zs
  go x = return x

  -- we need to apply g to update the state:
  return' x = x <$ g (query fromStr x)

  fromStr (Str t) = t
  fromStr _ = mempty

  g :: Text -> State CaseTransformState Text
  g t = do
    st <- get
    put $ case T.unsnoc t of
            Nothing -> st
            Just (_,c)
              | c == '.' || c == '?' || c == '!' || c == ':' ->
                AfterSentenceEndingPunctuation
              | isAlphaNum c -> AfterWordChar
              | isSpace c
              , st == AfterSentenceEndingPunctuation -> StartSentence
              | isWordBreak c -> AfterWordEnd
              | otherwise -> st
    return $
      if T.all isAlphaNum t
         then f st t
         else t
  isWordBreak '-' = True
  isWordBreak '/' = True
  isWordBreak '\x2013' = True
  isWordBreak '\x2014' = True
  isWordBreak c = isSpace c
  hasWordBreak = T.any isWordBreak
  splitUp = T.groupBy sameType
  sameType c d =
    (isAlphaNum c && isAlphaNum d) || (isSpace c && isSpace d) ||
      (isPunctuation c && isPunctuation d)