module Text.Pandoc.Readers.Org.Meta
( metaExport
, metaKey
, metaLine
) where
import Text.Pandoc.Readers.Org.BlockStarts
import Text.Pandoc.Readers.Org.ExportSettings ( exportSettings )
import Text.Pandoc.Readers.Org.Inlines
import Text.Pandoc.Readers.Org.ParserState
import Text.Pandoc.Readers.Org.Parsing
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Builder ( Blocks, Inlines )
import Text.Pandoc.Definition
import Control.Monad ( mzero, void )
import Data.Char ( toLower )
import Data.List ( intersperse )
import qualified Data.Map as M
import Data.Monoid ( (<>) )
import Network.HTTP ( urlEncode )
metaExport :: OrgParser (F Meta)
metaExport = do
st <- getState
let settings = orgStateExportSettings st
return $ (if exportWithAuthor settings then id else removeMeta "author")
. (if exportWithCreator settings then id else removeMeta "creator")
. (if exportWithEmail settings then id else removeMeta "email")
<$> orgStateMeta st
removeMeta :: String -> Meta -> Meta
removeMeta key meta' =
let metaMap = unMeta meta'
in Meta $ M.delete key metaMap
metaLine :: OrgParser Blocks
metaLine = mempty <$ metaLineStart <* (optionLine <|> declarationLine)
declarationLine :: OrgParser ()
declarationLine = try $ do
key <- map toLower <$> metaKey
(key', value) <- metaValue key
updateState $ \st ->
let meta' = B.setMeta key' <$> value <*> pure nullMeta
in st { orgStateMeta = meta' <> orgStateMeta st }
metaKey :: OrgParser String
metaKey = map toLower <$> many1 (noneOf ": \n\r")
<* char ':'
<* skipSpaces
metaValue :: String -> OrgParser (String, (F MetaValue))
metaValue key =
let inclKey = "header-includes"
in case key of
"author" -> (key,) <$> metaInlinesCommaSeparated
"title" -> (key,) <$> metaInlines
"date" -> (key,) <$> metaInlines
"header-includes" -> (key,) <$> accumulatingList key metaInlines
"latex_header" -> (inclKey,) <$>
accumulatingList inclKey (metaExportSnippet "latex")
"latex_class" -> ("documentclass",) <$> metaString
"latex_class_options" -> ("classoption",) <$>
metaModifiedString (filter (`notElem` "[]"))
"html_head" -> (inclKey,) <$>
accumulatingList inclKey (metaExportSnippet "html")
_ -> (key,) <$> metaString
metaInlines :: OrgParser (F MetaValue)
metaInlines = fmap (MetaInlines . B.toList) <$> inlinesTillNewline
metaInlinesCommaSeparated :: OrgParser (F MetaValue)
metaInlinesCommaSeparated = do
authStrs <- (many1 (noneOf ",\n")) `sepBy1` (char ',')
newline
authors <- mapM (parseFromString inlinesTillNewline . (++ "\n")) authStrs
let toMetaInlines = MetaInlines . B.toList
return $ MetaList . map toMetaInlines <$> sequence authors
metaString :: OrgParser (F MetaValue)
metaString = metaModifiedString id
metaModifiedString :: (String -> String) -> OrgParser (F MetaValue)
metaModifiedString f = return . MetaString . f <$> anyLine
metaExportSnippet :: String -> OrgParser (F MetaValue)
metaExportSnippet format =
return . MetaInlines . B.toList . B.rawInline format <$> anyLine
accumulatingList :: String
-> OrgParser (F MetaValue)
-> OrgParser (F MetaValue)
accumulatingList key p = do
value <- p
meta' <- orgStateMeta <$> getState
return $ (\m v -> MetaList (curList m ++ [v])) <$> meta' <*> value
where curList m = case lookupMeta key m of
Just (MetaList ms) -> ms
Just x -> [x]
_ -> []
optionLine :: OrgParser ()
optionLine = try $ do
key <- metaKey
case key of
"link" -> parseLinkFormat >>= uncurry addLinkFormat
"options" -> exportSettings
"todo" -> todoSequence >>= updateState . registerTodoSequence
"seq_todo" -> todoSequence >>= updateState . registerTodoSequence
"typ_todo" -> todoSequence >>= updateState . registerTodoSequence
_ -> mzero
addLinkFormat :: String
-> (String -> String)
-> OrgParser ()
addLinkFormat key formatter = updateState $ \s ->
let fs = orgStateLinkFormatters s
in s{ orgStateLinkFormatters = M.insert key formatter fs }
parseLinkFormat :: OrgParser ((String, String -> String))
parseLinkFormat = try $ do
linkType <- (:) <$> letter <*> many (alphaNum <|> oneOf "-_") <* skipSpaces
linkSubst <- parseFormat
return (linkType, linkSubst)
parseFormat :: OrgParser (String -> String)
parseFormat = try $ do
replacePlain <|> replaceUrl <|> justAppend
where
replacePlain = try $ (\x -> concat . flip intersperse x)
<$> sequence [tillSpecifier 's', rest]
replaceUrl = try $ (\x -> concat . flip intersperse x . urlEncode)
<$> sequence [tillSpecifier 'h', rest]
justAppend = try $ (++) <$> rest
rest = manyTill anyChar (eof <|> () <$ oneOf "\n\r")
tillSpecifier c = manyTill (noneOf "\n\r") (try $ string ('%':c:""))
inlinesTillNewline :: OrgParser (F Inlines)
inlinesTillNewline = trimInlinesF . mconcat <$> manyTill inline newline
todoSequence :: OrgParser TodoSequence
todoSequence = try $ do
todoKws <- todoKeywords
doneKws <- optionMaybe $ todoDoneSep *> todoKeywords
newline
case doneKws of
Just done -> return $ keywordsToSequence todoKws done
Nothing -> case reverse todoKws of
[] -> mzero
(x:xs) -> return $ keywordsToSequence (reverse xs) [x]
where
todoKeywords :: OrgParser [String]
todoKeywords = try $
let keyword = many1 nonspaceChar <* skipSpaces
endOfKeywords = todoDoneSep <|> void newline
in manyTill keyword (lookAhead endOfKeywords)
todoDoneSep :: OrgParser ()
todoDoneSep = void . try $ skipSpaces *> char '|' <* skipSpaces1
keywordsToSequence :: [String] -> [String] -> TodoSequence
keywordsToSequence todo done =
let todoMarkers = map (TodoMarker Todo) todo
doneMarkers = map (TodoMarker Done) done
in todoMarkers ++ doneMarkers