{-# 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
    , renderPandocStrict
    , renderPandoc'
    , renderPandoc_
    , headInline
    , initInline
    , tailFirstInlineStr
    , toCapital
    , startWithPunct
    , endWithPunct
    ) where

import Data.Char ( toUpper, toLower, isPunctuation )

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 (clean s) . concatMap (render s False)

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

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

-- | Same as 'renderPandoc', but will not clean up the produced
-- output.
renderPandocStrict :: Style -> [FormattedOutput] -> [Inline]
renderPandocStrict s
    = concatMap (render s True)

render :: Style -> Bool -> FormattedOutput -> [Inline]
render _ _ (FPan i) = i
render _ _ (FDel s) = toStr s
render sty b 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
    | otherwise = []
    where
      addSuffix f i
          | suffix f /= []
          , elem (head $ suffix f) ",.:?!"
          , [head $ suffix f] == lastInline i = i ++ toStr (tail $ suffix f)
          | suffix f /= []                    = i ++ toStr (       suffix f)
          | otherwise                         = i

      toPandoc f i = addSuffix f $ toStr (prefix f) ++
                     (format f . quote f . proc cleanStrict $ i)
      format     f = font_variant f . font f . text_case f
      rest      xs = procList xs $ concatMap (render sty b)
      quote    f i = if i /= [] && quotes f
                    then [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) : map toLower (tail s) else []
      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
          | "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] -- FIXME
          | "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 = 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 -> [Inline] -> [Inline]
clean _   []  = []
clean s (i:is)
    | Superscript x <- i = split (isLink "baseline") (return . Superscript) x
    | Subscript   x <- i = split (isLink "baseline") (return . Subscript  ) x
    | Link      x _ <- i = clean' s (x ++ clean s is)
    | otherwise          = clean' s (i :  clean s is)
    where
      unwrap f ls
          | Link x _ : _ <- ls = clean' s x
          |        _ : _ <- ls = f ls
          | otherwise          = []
      isLink l il
          | Link _ (x,y) <- il = x == l && 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 -> [Inline] -> [Inline]
clean' _   []  = []
clean' s (i:is)
    | Quoted t inls <- i
    , punctIn s = case headInline is of
                    [x] -> if isPunctuation x
                           then Quoted t (inls ++ [Str [x]]) : clean' s (tailInline is)
                           else i : clean' s is
                    _   -> i : clean' s is
    | otherwise = if lastInline [i] == headInline is && isPunct
                  then i : clean' s (tailInline is)
                  else i : clean' s is
    where
      punctIn = or . query punctIn'
      punctIn' n
          | ("punctuation-in-quote","true") <- n = [True]
          | otherwise                            = [False]

      isPunct = and . map (flip elem ".,;:!? ") $ headInline is

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

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           = []

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           = []