module Text.Pandoc.Scholarly (classIsMath,
classIsMathDef,
processSingleEqn,
processMultiEqn,
dispMathToLaTeX,
figureIdToNumLabelHandler,
AttributedMath,
getImageAttr,
getIdentifier,
getClasses,
hasClass,
getKeyVals,
lookupKey,
setIdentifier,
insertClass,
insertIfNoneKeyVal,
insertReplaceKeyVal,
insertReplaceKeyValIf,
extractMetaStringList,
extractMetaString
)
where
import Data.List ( intercalate )
import Text.Pandoc.Definition
import Text.Pandoc.Shared
import Text.Pandoc.Parsing hiding (tableWith)
import Control.Arrow
import Control.Monad (void)
import qualified Data.Map as M
type AttributedMath = (Attr, String)
classIsMath :: Attr -> Bool
classIsMath (_,classes,_) = any (`elem` ["math", "math_def", "math_plain"]) classes
classIsMathDef :: Attr -> Bool
classIsMathDef (_,classes,_) = "math_def" `elem` classes
insertClass :: String -> Attr -> Attr
insertClass className attr@(ident, classes, keyval)
| className `notElem` classes = (ident, className:classes, keyval)
| otherwise = attr
insertWithKeyVal :: (String -> String -> String)
-> (String, String)
-> Attr
-> Attr
insertWithKeyVal f (key, val) (ident, classes, keyval) =
let newKeyValMap = M.insertWith f key val $ M.fromList keyval
in (ident, classes, M.toList newKeyValMap)
insertIfNoneKeyVal :: (String, String) -> Attr -> Attr
insertIfNoneKeyVal = insertWithKeyVal (\_ x -> x)
insertReplaceKeyVal :: (String, String) -> Attr -> Attr
insertReplaceKeyVal = insertWithKeyVal const
insertReplaceKeyValIf :: Bool -> (String, String) -> Attr -> Attr
insertReplaceKeyValIf True kv attr = insertReplaceKeyVal kv attr
insertReplaceKeyValIf False _ attr = attr
getClasses :: Attr -> [String]
getClasses (_, classes, _) = classes
hasClass :: String -> Attr -> Bool
hasClass cls (_, classes, _) = cls `elem` classes
getIdentifier :: Attr -> String
getIdentifier (identifier, _, _) = identifier
setIdentifier :: String -> Attr -> Attr
setIdentifier identifier (_, classes, keyval) = (identifier, classes, keyval)
getKeyVals :: Attr -> [(String, String)]
getKeyVals (_, _, keyVals) = keyVals
lookupKey :: String -> Attr -> Maybe String
lookupKey key (_, _, keyval) = M.lookup key $ M.fromList keyval
getImageAttr :: Inline -> Attr
getImageAttr (Image attr _ _) = attr
getImageAttr _ = nullAttr
extractMetaStringList :: Maybe MetaValue -> [String]
extractMetaStringList (Just (MetaList lst)) = map extractMetaString lst
extractMetaStringList (Just (MetaString str)) = [str]
extractMetaStringList _ = []
extractMetaString :: MetaValue -> String
extractMetaString (MetaString str) = str
extractMetaString _ = ""
processSingleEqn :: AttributedMath -> (AttributedMath, [String])
processSingleEqn eqn =
let processors = [ensureLabeled "\n",
ensureMultilineEnv]
label = (getIdentifier . fst) eqn
in (foldr ($) eqn processors, [label])
processMultiEqn :: [AttributedMath] -> (AttributedMath, [String])
processMultiEqn eqnList =
let processors = [ensureNonumber " ",
ensureLabeled " ",
id *** trim]
processedEqnList = foldr map eqnList processors
labels = map (getIdentifier . fst) eqnList
in (concatMultiEquations processedEqnList, labels)
ensureMultilineEnv :: AttributedMath -> AttributedMath
ensureMultilineEnv eqn@(attr, content)
| "math_plain" `elem` getClasses attr = eqn
| hasTeXLinebreak content = if hasTeXAlignment content
then (attr, wrapInLatexEnv "aligned" content)
else (attr, wrapInLatexEnv "split" content)
| otherwise = eqn
ensureNonumber :: String -> AttributedMath -> AttributedMath
ensureNonumber terminal eqn@(attr, content) =
case attr of
("",_ ,_) -> (attr, "\\nonumber" ++ terminal ++ content)
_ -> eqn
ensureLabeled :: String -> AttributedMath -> AttributedMath
ensureLabeled terminal eqn@(attr, content) =
case attr of
("",_ ,_) -> eqn
(label, _, _) -> (attr, "\\label{" ++ label ++ "}" ++ terminal ++ content)
concatMultiEquations :: [AttributedMath] -> AttributedMath
concatMultiEquations eqnList =
let eqnContents = map snd eqnList
multiClass = if hasTeXAlignment (head eqnContents)
then "align"
else "gather"
in ( ("", ["math",multiClass], [("labelList",show (map (getIdentifier.fst) eqnList))]),
intercalate "\\\\\n" eqnContents )
wrapInLatexEnv :: String -> String -> String
wrapInLatexEnv envName content = intercalate "\n"
["\\begin{" ++ envName ++ "}", content, "\\end{" ++ envName ++ "}"]
hasTeXLinebreak :: String -> Bool
hasTeXLinebreak content =
case parse (skipMany (try ignoreLinebreak
<|> try (char '\\' >> notFollowedBy (char '\\') >> return [])
<|> try (noneOf "\\" >> return []))
>> void (string "\\\\")) [] content of
Left _ -> False
Right _ -> True
hasTeXAlignment :: String -> Bool
hasTeXAlignment content =
case parse (skipMany (try ignoreLinebreak
<|> try (string "\\&")
<|> try (noneOf "&" >> return []))
>> void (char '&')) [] content of
Left _ -> False
Right _ -> True
skipTeXComment :: Parser String st String
skipTeXComment = try $ do
char '%'
manyTill anyChar $ try $ newline <|> (eof >> return '\n')
return []
skipTexEnvironment :: String -> Parser String st String
skipTexEnvironment envName = try $ do
string ("\\begin{" ++ envName ++ "}")
manyTill anyChar $ try $ string ("\\end{" ++ envName ++ "}")
return []
ignoreLinebreak :: Parser String st String
ignoreLinebreak = try (string "\\%")
<|> skipTeXComment
<|> skipTexEnvironment "split"
<|> skipTexEnvironment "aligned"
<|> skipTexEnvironment "alignedat"
<|> skipTexEnvironment "cases"
dispMathToLaTeX :: Attr -> String -> String
dispMathToLaTeX (label, classes, _) mathCode
| "align" `elem` classes = wrapInLatexEnv "align" mathCode
| "gather" `elem` classes = wrapInLatexEnv "gather" mathCode
| "math_def" `elem` classes = mathCode
| otherwise = case label of
"" -> wrapInLatexEnv "equation*" mathCode
_ -> wrapInLatexEnv "equation" mathCode
figureIdToNumLabelHandler :: Attr
-> ParserState
-> (XRefIdentifiers -> [String])
-> (XRefIdentifiers -> [String] -> XRefIdentifiers)
-> (Attr -> Attr, ParserState -> ParserState)
figureIdToNumLabelHandler attr state idListGetter idListSetter =
let xrefIds = stateXRefIdents state
needId = not (hasClass "nonumber" attr) && getIdentifier attr /= ""
myIdentifier = getIdentifier attr
myNumLabel = if needId
then length (filter (/= "") $ idListGetter xrefIds) + 1
else 0
newXrefIds = idListSetter xrefIds (idListGetter xrefIds ++ [myIdentifier])
stateUpdater = \s -> s{ stateXRefIdents = newXrefIds }
attrUpdater = insertReplaceKeyValIf needId ("numLabel", show myNumLabel)
in (attrUpdater, stateUpdater)