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
renderPandoc :: Style -> [FormattedOutput] -> [Inline]
renderPandoc s
= proc (clean s) . concatMap (render s False)
renderPandoc' :: Style -> [FormattedOutput] -> Block
renderPandoc' s
= Para . proc (clean s) . concatMap (render s False)
renderPandoc_ :: Style -> [FormattedOutput] -> [Inline]
renderPandoc_ s
= proc (clean' s) . concatMap (render s False)
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]
| "sub" <- verticalAlign fm = [Subscript i]
| "baseline" <- verticalAlign fm = [escape "baseline" i]
| otherwise = i
rmZeros = dropWhile (== '0')
escape s x = Link x (s,s)
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 = []