{-# LANGUAGE PatternGuards, DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.CSL.Output.Pandoc
-- Copyright   :  (c) Andrea Rossato
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Andrea Rossato <andrea.rossato@unitn.it>
-- Stability   :  unstable
-- Portability :  unportable
--
-- The pandoc output formatter for CSL
--
-----------------------------------------------------------------------------

module Text.CSL.Output.Pandoc
    ( renderPandoc
    , renderPandoc'
    , renderPandoc_
    , headInline
    , initInline
    , tailFirstInlineStr
    , toCapital
    , startWithPunct
    , endWithPunct
    ) where

import Data.Char ( toUpper, toLower )
import Data.Maybe ( fromMaybe )

import Text.CSL.Style
import Text.CSL.Output.Plain
import Text.Pandoc.Definition

-- | With a 'Style' and the formatted output generate a 'String' in
-- the native 'Pandoc' formats (i.e. immediately readable by pandoc).
renderPandoc :: Style -> [FormattedOutput] -> [Inline]
renderPandoc s
    = proc (convertQuoted s) . proc' (clean s $ isPunctuationInQuote s) .
      flipFlop . render s

-- | Same as 'renderPandoc', but the output is wrapped in a pandoc
-- paragraph block.
renderPandoc' :: Style -> [FormattedOutput] -> Block
renderPandoc' s
    = Para . proc (convertQuoted s) . proc' (clean s $ isPunctuationInQuote s) .
      flipFlop . render s

-- | For the testsuite: we use 'Link' and 'Strikeout' to store
-- "nocase" and "nodecor" rich text formatting classes.
renderPandoc_ :: Style -> [FormattedOutput] -> [Inline]
renderPandoc_ s
    = proc (convertQuoted s) . proc (clean' s $ isPunctuationInQuote s) .
      flipFlop . render s

render :: Style -> [FormattedOutput] -> [Inline]
render _ [] = []
render s (x:[])   = renderFo s x
render s (x:y:os) = let a = renderFo s x
                        b = renderFo s y
                        isPunct = and . map (flip elem ".!?") in
                    if isPunct (lastInline a) && isPunct (headInline b)
                    then a ++ render s (tailFO [y] ++ os)
                    else a ++ render s (y:os)

tailFO :: [FormattedOutput] -> [FormattedOutput]
tailFO [] = []
tailFO (f:fs)
    | FDel  s  <- f = FDel  (tail' s)       : fs
    | FPan is  <- f = FPan  (tailInline is) : fs
    | FN s  fm <- f = if prefix fm /= [] then FN s (tailFm fm)    : fs else FN    (tail' s) fm : fs
    | FS s  fm <- f = if prefix fm /= [] then FS s (tailFm fm)    : fs else FS    (tail' s) fm : fs
    | FO fm fo <- f = if prefix fm /= [] then FO   (tailFm fm) fo : fs else FO fm (tailFO fo)  : fs
    | otherwise     = f : tailFO fs
    where
      tailFm fm = fm { prefix = tail $ prefix fm }

renderFo :: Style -> FormattedOutput -> [Inline]
renderFo _ (FPan i) = i
renderFo _ (FDel s) = toStr s
renderFo sty fo
    | FS str fm    <- fo = toPandoc fm $ toStr str
    | FN str fm    <- fo = toPandoc fm $ toStr $ rmZeros str
    | FO     fm xs <- fo = toPandoc fm $ rest xs
    | FUrl u fm    <- fo = toPandoc fm [Link (toStr $ snd u) u]
    | otherwise = []
    where
      addSuffix f i
          | suffix f /= []
          , elem (head $ suffix f) ".?!"
          , lastInline i /= []
          , last (lastInline i)`elem` ".?!" = i ++ toStr (tail $ suffix f)
          | suffix f /= []                  = i ++ toStr (       suffix f)
          | otherwise                       = i

      toPandoc f i = addSuffix f $ toStr (prefix f) ++
                     (quote f . format f . proc cleanStrict $ i)
      format     f = font_variant f . font f . text_case f
      rest      xs = procList xs $ render sty
      quote    f i = if i /= [] && quotes f /= NoQuote
                     then if quotes f == NativeQuote
                          then [escape "inquote"   . valign f $ i]
                          else [Quoted DoubleQuote . valign f $ i]
                     else valign f i
      setCase f i
          | Str     s <- i = Str $ f s
          | otherwise      = i
      setCase' f i
          | Link s r <- i = Link (map (setCase f) s) r
          | otherwise     = setCase f i

      toCap        s = if s /= []       then toUpper (head s) : tail s else []
      toTitleCap   s = if isShortWord s then toUpper (head s) : tail s else s
      isShortWord  s = not $ s `elem` ["a","an","and","as","at","but","by","down","for","from"
                                      ,"in","into","nor","of","on","onto","or","over","so"
                                      ,"the","till","to","up","via","with","yet"]
      text_case _ [] = []
      text_case fm a@(i:is)
          | noCase fm                         = [escape "nocase" a]
          | "lowercase"        <- textCase fm = map (setCase' $ map toLower) a
          | "uppercase"        <- textCase fm = map (setCase' $ map toUpper) a
          | "capitalize-all"   <- textCase fm = map (setCase  $ unwords . map toCap      . words) a
          | "title"            <- textCase fm = map (setCase  $ unwords . map toTitleCap . words) a
          | "capitalize-first" <- textCase fm = [setCase capitalize i] ++ is
          | "sentence"         <- textCase fm = [setCase toCap      i] ++
                                                map (setCase $ map toLower) is
          | otherwise                         = a

      font_variant fm i
          | "small-caps" <- fontVariant fm = [SmallCaps i]
          | otherwise                      = i

      font fm
          | noDecor fm                 = return . escape "nodecor"
          | "italic"  <- fontStyle  fm = return . Emph
          | "oblique" <- fontStyle  fm = return . Emph
          | "bold"    <- fontWeight fm = return . Strong
          | otherwise                  = id

      valign _ [] = []
      valign fm i
          | "sup"      <- verticalAlign fm = [Superscript i]
          | "sub"      <- verticalAlign fm = [Subscript   i]
          | "baseline" <- verticalAlign fm = [escape "baseline" i]
          | otherwise                      = i

      rmZeros = dropWhile (== '0')
      escape s x = Link x (s,s) -- we use a link to store some data

toStr :: String -> [Inline]
toStr = toStr' . entityToChar
    where
      toStr' s
          |'«':' ':xs <- s = toStr' ("«\8239" ++ xs)
          |' ':'»':xs <- s = toStr' ("\8239»" ++ xs)
          |' ':';':xs <- s = toStr' ("\8239;" ++ xs)
          |' ':':':xs <- s = toStr' ("\8239:" ++ xs)
          |' ':'!':xs <- s = toStr' ("\8239!" ++ xs)
          |' ':'?':xs <- s = toStr' ("\8239?" ++ xs)
          |' ':xs <- s = Space   : toStr' xs
          | x :xs <- s = Str [x] : toStr' xs
          | otherwise  = []

cleanStrict :: [Inline] -> [Inline]
cleanStrict []  = []
cleanStrict (i:is)
    | Str []    <- i  =                  cleanStrict is
    | Str " "   <- i  = Space          : cleanStrict is
    | Str sa    <- i
    , Str sb:xs <- is = Str (sa ++ sb) : cleanStrict xs
    | otherwise       =              i : cleanStrict is

clean :: Style -> Bool -> [Inline] -> [Inline]
clean _ _ []  = []
clean s b (i:is)
    | Superscript x <- i = split (isLink  "baseline") (return . Superscript) x ++ clean s b is
    | Subscript   x <- i = split (isLink  "baseline") (return . Subscript  ) x ++ clean s b is
    | SmallCaps   x <- i = split (isLink  "nodecor" ) (return . SmallCaps  ) x ++ clean s b is
    | Emph        x <- i = split (isLink' "emph"    ) (return . Emph       ) x ++ clean s b is
    | Strong      x <- i = split (isLink' "strong"  ) (return . Strong     ) x ++ clean s b is
    | Link      x t <- i = clean' s b (Link x t : clean s b is)
    | otherwise          = clean' s b (i        : clean s b is)
    where
      unwrap f ls
          | Link x _ : _ <- ls = clean' s b x
          |        _ : _ <- ls = f ls
          | otherwise          = []
      isLink l il
          | Link _ (x,y) <- il = x == l && x == y
          | otherwise          = False
      isLink' l il
          | Link _ (x,y) <- il = (x == l || x == "nodecor") && x == y
          | otherwise          = False
      split _ _ [] = []
      split f g xs = let (y, r) = break f xs
                     in concatMap (unwrap g) [y, head' r] ++ split f g (tail' r)

clean' :: Style -> Bool -> [Inline] -> [Inline]
clean' _ _   []  = []
clean' s b (i:is)
    | Link inls (y,z) <- i, y == "inquote"
    , y == z    = case headInline is of
                    [x] -> if x `elem` ".," && b
                           then if lastInline inls `elem` [".",",",";",":","!","?"]
                                then quote DoubleQuote inls                : clean' s b (tailInline is)
                                else quote DoubleQuote (inls ++ [Str [x]]) : clean' s b (tailInline is)
                           else quote DoubleQuote inls : clean' s b is
                    _   ->      quote DoubleQuote inls : clean' s b is
    | Quoted t inls <- i = quote t inls : clean' s b is
    | otherwise = if lastInline [i] == headInline is && isPunct
                  then i : clean' s b (tailInline is)
                  else i : clean' s b is
    where
      quote t x = Quoted t (reverseQuoted t x)
      isPunct = and . map (flip elem ".,;:!? ") $ headInline is
      reverseQuoted t = proc reverseQuoted'
          where
            reverseQuoted' q
                | Quoted _ qs <- q
                , DoubleQuote <- t = Quoted SingleQuote (reverseQuoted SingleQuote qs)
                | Quoted _ qs <- q
                , SingleQuote <- t = Quoted DoubleQuote (reverseQuoted DoubleQuote qs)
                | otherwise        = q

flipFlop :: [Inline] -> [Inline]
flipFlop [] = []
flipFlop (i:is)
    | Emph     inls <- i = Emph   (reverseEmph   True inls) : flipFlop is
    | Strong   inls <- i = Strong (reverseStrong True inls) : flipFlop is
    | otherwise          = i                                : flipFlop is
    where
      reverseEmph bo = map reverseEmph'
          where
            reverseEmph' e
                | bo, Emph inls <- e = Link (reverseEmph False inls) ("emph","emph")
                | Emph     inls <- e = Emph (reverseEmph True  inls)
                | Link ls (x,y) <- e = if x == "nodecor" && x == y
                                       then Link ls ("emph","emph")
                                       else e
                | otherwise          = e
      reverseStrong bo = map reverseStrong'
          where
            reverseStrong' e
                | bo, Strong inls <- e = Link   (reverseStrong False inls) ("strong","strong")
                | Strong     inls <- e = Strong (reverseStrong True  inls)
                | Link   ls (x,y) <- e = if x == "nodecor" && x == y
                                         then Link ls ("strong","strong")
                                         else e
                | otherwise            = e

isPunctuationInQuote :: Style -> Bool
isPunctuationInQuote = or . query punctIn'
    where
      punctIn' n
          | ("punctuation-in-quote","true") <- n = [True]
          | otherwise                            = [False]

endWithPunct, startWithPunct :: [Inline] -> Bool
endWithPunct   = and . map (`elem` ".,;:!?") . lastInline
startWithPunct = and . map (`elem` ".,;:!?") . headInline

convertQuoted :: Style -> [Inline] -> [Inline]
convertQuoted s = convertQuoted'
    where
      locale = let l = styleLocale s in case l of [x] -> x; _   -> Locale [] [] [] [] []
      getQuote  x y = entityToChar . termSingular . fromMaybe newTerm {termSingular = x} .
                      findTerm y Long . localeTerms $ locale
      doubleQuotesO = getQuote "\"" "open-quote"
      doubleQuotesC = getQuote "\"" "close-quote"
      singleQuotesO = getQuote "'"  "open-inner-quote"
      singleQuotesC = getQuote "'"  "close-inner-quote"
      convertQuoted' o
          | (Quoted DoubleQuote t:xs) <- o = Str doubleQuotesO : t ++ Str doubleQuotesC : convertQuoted' xs
          | (Quoted SingleQuote t:xs) <- o = Str singleQuotesO : t ++ Str singleQuotesC : convertQuoted' xs
          | (x                   :xs) <- o = x : convertQuoted' xs
          | otherwise                      = []

headInline :: [Inline] -> String
headInline [] = []
headInline (i:_)
    | Str s <- i = head' s
    | Space <- i = " "
    | otherwise  = headInline $ getInline i

lastInline :: [Inline] -> String
lastInline [] = []
lastInline (i:[])
    | Str s <- i = last' s
    | Space <- i = " "
    | otherwise  = lastInline $ getInline i
    where
      last' s = if s /= [] then [last s] else []
lastInline (_:xs) = lastInline xs

initInline :: [Inline] -> [Inline]
initInline [] = []
initInline (i:[])
    | Str          s <- i = return $ Str         (init'       s)
    | Emph        is <- i = return $ Emph        (initInline is)
    | Strong      is <- i = return $ Strong      (initInline is)
    | Superscript is <- i = return $ Superscript (initInline is)
    | Subscript   is <- i = return $ Subscript   (initInline is)
    | Quoted q    is <- i = return $ Quoted q    (initInline is)
    | SmallCaps   is <- i = return $ SmallCaps   (initInline is)
    | Strikeout   is <- i = return $ Strikeout   (initInline is)
    | Link      is t <- i = return $ Link        (initInline is) t
    | otherwise           = []
    where
      init' s = if s /= [] then init s else []
initInline (i:xs) = i : initInline xs

tailInline :: [Inline] -> [Inline]
tailInline inls
    | (i:t) <- inls
    , Space <- i = t
    | otherwise  = tailFirstInlineStr inls

tailFirstInlineStr :: [Inline] -> [Inline]
tailFirstInlineStr = mapHeadInline tail'

toCapital :: [Inline] -> [Inline]
toCapital = mapHeadInline capitalize

mapHeadInline :: (String -> String) -> [Inline] -> [Inline]
mapHeadInline _ [] = []
mapHeadInline f (i:xs)
    | Str         [] <- i =                      mapHeadInline f xs
    | Str          s <- i = Str         (f                s)   : xs
    | Emph        is <- i = Emph        (mapHeadInline f is)   : xs
    | Strong      is <- i = Strong      (mapHeadInline f is)   : xs
    | Superscript is <- i = Superscript (mapHeadInline f is)   : xs
    | Subscript   is <- i = Subscript   (mapHeadInline f is)   : xs
    | Quoted q    is <- i = Quoted q    (mapHeadInline f is)   : xs
    | SmallCaps   is <- i = SmallCaps   (mapHeadInline f is)   : xs
    | Strikeout   is <- i = Strikeout   (mapHeadInline f is)   : xs
    | Link      is t <- i = Link        (mapHeadInline f is) t : xs
    | otherwise           = i : xs

getInline :: Inline -> [Inline]
getInline i
    | Emph        is <- i = is
    | Strong      is <- i = is
    | Strikeout   is <- i = is
    | Superscript is <- i = is
    | Subscript   is <- i = is
    | Quoted _    is <- i = is
    | SmallCaps   is <- i = is
    | Link      is _ <- i = is
    | otherwise           = []