module Text.CSL.Eval.Output where
import Text.CSL.Output.Plain
import Text.CSL.Style
import Text.ParserCombinators.Parsec hiding ( State (..) )
import Control.Applicative ((<*))
output :: Formatting -> String -> [Output]
output fm s
| ' ':xs <- s = OSpace : output fm xs
| [] <- s = []
| otherwise = [OStr s fm]
appendOutput :: Formatting -> [Output] -> [Output]
appendOutput fm xs = if xs /= [] then [Output xs fm] else []
outputList :: Formatting -> Delimiter -> [Output] -> [Output]
outputList fm d = appendOutput fm . addDelim d . map cleanOutput'
where
cleanOutput' o
| Output xs f <- o = Output (cleanOutput xs) f
| otherwise = rmEmptyOutput o
cleanOutput :: [Output] -> [Output]
cleanOutput = flatten
where
flatten [] = []
flatten (o:os)
| ONull <- o = flatten os
| Output xs f <- o
, f == emptyFormatting = flatten xs ++ flatten os
| otherwise = rmEmptyOutput o : flatten os
rmEmptyOutput :: Output -> Output
rmEmptyOutput o
| Output [] _ <- o = ONull
| OStr [] _ <- o = ONull
| OUrl t _ <- o = if null (fst t) then ONull else o
| otherwise = o
addDelim :: String -> [Output] -> [Output]
addDelim d = foldr (\x xs -> if length xs < 1 then x : xs else check x xs) []
where
check x xs
| ONull <- x = xs
| otherwise = let text = renderPlainStrict . formatOutputList
in if d /= [] && text [x] /= [] && text xs /= []
then if head d == last (text [x]) && head d `elem` ".,;:!?"
then x : ODel (tail d) : xs
else x : ODel d : xs
else x : xs
noOutputError :: Output
noOutputError = OErr NoOutput
noBibDataError :: Cite -> Output
noBibDataError c = OErr $ ReferenceNotFound (citeId c)
oStr :: String -> [Output]
oStr s = oStr' s emptyFormatting
oStr' :: String -> Formatting -> [Output]
oStr' [] _ = []
oStr' s f = rtfParser f s
(<++>) :: [Output] -> [Output] -> [Output]
[] <++> o = o
o <++> [] = o
o1 <++> o2 = o1 ++ [OSpace] ++ o2
rtfTags :: [(String, (String,Formatting))]
rtfTags =
[("b" , ("b" , ef {fontWeight = "bold" }))
,("i" , ("i" , ef {fontStyle = "italic" }))
,("sc" , ("sc" , ef {fontVariant = "small-caps"}))
,("sup" , ("sup" , ef {verticalAlign = "sup" }))
,("sub" , ("sub" , ef {verticalAlign = "sub" }))
,("span class=\"nocase\"" , ("span", ef {noCase = True }))
,("span class=\"nodecor\"" , ("span", ef {noDecor = True }))
]
where
ef = emptyFormatting
rtfParser :: Formatting -> String -> [Output]
rtfParser _ [] = []
rtfParser fm s
= either (const [OStr s fm]) (return . flip Output fm) $
parse (manyTill parser eof) "" s
where
parser = parseText <|> parseQuotes <|> parseMarkup
parseText = do
let amper = try $ char '&' <* notFollowedBy (char '#')
apos = char '\''
regChar = noneOf "<'\"`“‘&"
many1 (regChar <|> amper <|> apos) >>= \x ->
return (OStr x emptyFormatting)
parseMarkup = do
m <- char '<' >> manyTill anyChar (char '>')
case lookup m rtfTags of
Just tf -> do let ct = try $ string $ "</" ++ fst tf ++ ">"
contents <- manyTill parser ct
return (Output contents (snd tf))
Nothing -> do return (OStr ("<" ++ m ++ ">") emptyFormatting)
parseQuotes = choice [parseQ "'" "'"
,parseQ "\"" "\""
,parseQ "``" "''"
,parseQ "`" "'"
,parseQ "“" "”"
,parseQ "‘" "’"
,parseQ "'" "'"
,parseQ """ """
,parseQ """ """
,parseQ "'" "'"
]
parseQ a b = try $ do
_ <- string a
contents <- manyTill parser (try $ string b >> notFollowedBy letter)
return (Output contents (emptyFormatting {quotes = ParsedQuote}))