diff options
Diffstat (limited to 'src/Text/Pandoc/Readers/Org/Meta.hs')
| -rw-r--r-- | src/Text/Pandoc/Readers/Org/Meta.hs | 145 |
1 files changed, 98 insertions, 47 deletions
diff --git a/src/Text/Pandoc/Readers/Org/Meta.hs b/src/Text/Pandoc/Readers/Org/Meta.hs index 1fea3e890..6ad403fd8 100644 --- a/src/Text/Pandoc/Readers/Org/Meta.hs +++ b/src/Text/Pandoc/Readers/Org/Meta.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} {- -Copyright (C) 2014-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Org.Meta - Copyright : Copyright (C) 2014-2017 Albert Krewinkel + Copyright : Copyright (C) 2014-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -33,25 +33,26 @@ module Text.Pandoc.Readers.Org.Meta , 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 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 Text.Pandoc.Builder (Blocks, Inlines) import qualified Text.Pandoc.Builder as B -import Text.Pandoc.Builder ( Blocks, Inlines ) -import Text.Pandoc.Definition +import Text.Pandoc.Class (PandocMonad) +import Text.Pandoc.Definition +import Text.Pandoc.Shared (safeRead) -import Control.Monad ( mzero, void ) -import Data.Char ( toLower ) -import Data.List ( intersperse ) +import Control.Monad (mzero, void, when) +import Data.Char (toLower) +import Data.List (intersperse) import qualified Data.Map as M -import Data.Monoid ( (<>) ) -import Network.HTTP ( urlEncode ) +import Network.HTTP (urlEncode) -- | Returns the current meta, respecting export options. -metaExport :: OrgParser (F Meta) +metaExport :: Monad m => OrgParser m (F Meta) metaExport = do st <- getState let settings = orgStateExportSettings st @@ -68,29 +69,32 @@ removeMeta key meta' = -- | Parse and handle a single line containing meta information -- The order, in which blocks are tried, makes sure that we're not looking at -- the beginning of a block, so we don't need to check for it -metaLine :: OrgParser Blocks +metaLine :: PandocMonad m => OrgParser m Blocks metaLine = mempty <$ metaLineStart <* (optionLine <|> declarationLine) -declarationLine :: OrgParser () +declarationLine :: PandocMonad m => OrgParser m () 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 } + let addMetaValue st = + st { orgStateMeta = B.setMeta key' <$> value <*> orgStateMeta st } + when (key' /= "results") $ updateState addMetaValue -metaKey :: OrgParser String +metaKey :: Monad m => OrgParser m String metaKey = map toLower <$> many1 (noneOf ": \n\r") <* char ':' <* skipSpaces -metaValue :: String -> OrgParser (String, (F MetaValue)) +metaValue :: PandocMonad m => String -> OrgParser m (String, F MetaValue) metaValue key = let inclKey = "header-includes" in case key of "author" -> (key,) <$> metaInlinesCommaSeparated + "keywords" -> (key,) <$> metaInlinesCommaSeparated "title" -> (key,) <$> metaInlines + "subtitle" -> (key,) <$> metaInlines "date" -> (key,) <$> metaInlines + "nocite" -> (key,) <$> accumulatingList key metaInlines "header-includes" -> (key,) <$> accumulatingList key metaInlines "latex_header" -> (inclKey,) <$> accumulatingList inclKey (metaExportSnippet "latex") @@ -103,32 +107,32 @@ metaValue key = accumulatingList inclKey (metaExportSnippet "html") _ -> (key,) <$> metaString -metaInlines :: OrgParser (F MetaValue) +metaInlines :: PandocMonad m => OrgParser m (F MetaValue) metaInlines = fmap (MetaInlines . B.toList) <$> inlinesTillNewline -metaInlinesCommaSeparated :: OrgParser (F MetaValue) +metaInlinesCommaSeparated :: PandocMonad m => OrgParser m (F MetaValue) metaInlinesCommaSeparated = do - authStrs <- (many1 (noneOf ",\n")) `sepBy1` (char ',') + itemStrs <- many1 (noneOf ",\n") `sepBy1` char ',' newline - authors <- mapM (parseFromString inlinesTillNewline . (++ "\n")) authStrs + items <- mapM (parseFromString inlinesTillNewline . (++ "\n")) itemStrs let toMetaInlines = MetaInlines . B.toList - return $ MetaList . map toMetaInlines <$> sequence authors + return $ MetaList . map toMetaInlines <$> sequence items -metaString :: OrgParser (F MetaValue) +metaString :: Monad m => OrgParser m (F MetaValue) metaString = metaModifiedString id -metaModifiedString :: (String -> String) -> OrgParser (F MetaValue) +metaModifiedString :: Monad m => (String -> String) -> OrgParser m (F MetaValue) metaModifiedString f = return . MetaString . f <$> anyLine -- | Read an format specific meta definition -metaExportSnippet :: String -> OrgParser (F MetaValue) +metaExportSnippet :: Monad m => String -> OrgParser m (F MetaValue) metaExportSnippet format = return . MetaInlines . B.toList . B.rawInline format <$> anyLine -- | Accumulate the result of the @parser@ in a list under @key@. -accumulatingList :: String - -> OrgParser (F MetaValue) - -> OrgParser (F MetaValue) +accumulatingList :: Monad m => String + -> OrgParser m (F MetaValue) + -> OrgParser m (F MetaValue) accumulatingList key p = do value <- p meta' <- orgStateMeta <$> getState @@ -141,7 +145,7 @@ accumulatingList key p = do -- -- export options -- -optionLine :: OrgParser () +optionLine :: Monad m => OrgParser m () optionLine = try $ do key <- metaKey case key of @@ -150,16 +154,19 @@ optionLine = try $ do "todo" -> todoSequence >>= updateState . registerTodoSequence "seq_todo" -> todoSequence >>= updateState . registerTodoSequence "typ_todo" -> todoSequence >>= updateState . registerTodoSequence - _ -> mzero + "macro" -> macroDefinition >>= updateState . registerMacro + "pandoc-emphasis-pre" -> emphChars >>= updateState . setEmphasisPreChar + "pandoc-emphasis-post" -> emphChars >>= updateState . setEmphasisPostChar + _ -> mzero -addLinkFormat :: String +addLinkFormat :: Monad m => String -> (String -> String) - -> OrgParser () + -> OrgParser m () addLinkFormat key formatter = updateState $ \s -> let fs = orgStateLinkFormatters s in s{ orgStateLinkFormatters = M.insert key formatter fs } -parseLinkFormat :: OrgParser ((String, String -> String)) +parseLinkFormat :: Monad m => OrgParser m (String, String -> String) parseLinkFormat = try $ do linkType <- (:) <$> letter <*> many (alphaNum <|> oneOf "-_") <* skipSpaces linkSubst <- parseFormat @@ -167,9 +174,8 @@ parseLinkFormat = try $ do -- | An ad-hoc, single-argument-only implementation of a printf-style format -- parser. -parseFormat :: OrgParser (String -> String) -parseFormat = try $ do - replacePlain <|> replaceUrl <|> justAppend +parseFormat :: Monad m => OrgParser m (String -> String) +parseFormat = try $ replacePlain <|> replaceUrl <|> justAppend where -- inefficient, but who cares replacePlain = try $ (\x -> concat . flip intersperse x) @@ -181,13 +187,34 @@ parseFormat = try $ do 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 +setEmphasisPreChar :: Maybe [Char] -> OrgParserState -> OrgParserState +setEmphasisPreChar csMb st = + let preChars = case csMb of + Nothing -> orgStateEmphasisPreChars defaultOrgParserState + Just cs -> cs + in st { orgStateEmphasisPreChars = preChars } + +setEmphasisPostChar :: Maybe [Char] -> OrgParserState -> OrgParserState +setEmphasisPostChar csMb st = + let postChars = case csMb of + Nothing -> orgStateEmphasisPostChars defaultOrgParserState + Just cs -> cs + in st { orgStateEmphasisPostChars = postChars } + +emphChars :: Monad m => OrgParser m (Maybe [Char]) +emphChars = do + skipSpaces + safeRead <$> anyLine + +inlinesTillNewline :: PandocMonad m => OrgParser m (F Inlines) +inlinesTillNewline = do + updateLastPreCharPos + trimInlinesF . mconcat <$> manyTill inline newline -- -- ToDo Sequences and Keywords -- -todoSequence :: OrgParser TodoSequence +todoSequence :: Monad m => OrgParser m TodoSequence todoSequence = try $ do todoKws <- todoKeywords doneKws <- optionMaybe $ todoDoneSep *> todoKeywords @@ -201,13 +228,13 @@ todoSequence = try $ do (x:xs) -> return $ keywordsToSequence (reverse xs) [x] where - todoKeywords :: OrgParser [String] + todoKeywords :: Monad m => OrgParser m [String] todoKeywords = try $ let keyword = many1 nonspaceChar <* skipSpaces endOfKeywords = todoDoneSep <|> void newline in manyTill keyword (lookAhead endOfKeywords) - todoDoneSep :: OrgParser () + todoDoneSep :: Monad m => OrgParser m () todoDoneSep = void . try $ skipSpaces *> char '|' <* skipSpaces1 keywordsToSequence :: [String] -> [String] -> TodoSequence @@ -215,3 +242,27 @@ todoSequence = try $ do let todoMarkers = map (TodoMarker Todo) todo doneMarkers = map (TodoMarker Done) done in todoMarkers ++ doneMarkers + +macroDefinition :: Monad m => OrgParser m (String, [String] -> String) +macroDefinition = try $ do + macroName <- many1 nonspaceChar <* skipSpaces + firstPart <- expansionPart + (elemOrder, parts) <- unzip <$> many ((,) <$> placeholder <*> expansionPart) + let expander = mconcat . alternate (firstPart:parts) . reorder elemOrder + return (macroName, expander) + where + placeholder :: Monad m => OrgParser m Int + placeholder = try . fmap read $ char '$' *> many1 digit + + expansionPart :: Monad m => OrgParser m String + expansionPart = try $ many (notFollowedBy placeholder *> noneOf "\n\r") + + alternate :: [a] -> [a] -> [a] + alternate [] ys = ys + alternate xs [] = xs + alternate (x:xs) (y:ys) = x : y : alternate xs ys + + reorder :: [Int] -> [String] -> [String] + reorder perm xs = + let element n = take 1 $ drop (n - 1) xs + in concatMap element perm |