summaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Readers/TikiWiki.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc/Readers/TikiWiki.hs')
-rw-r--r--src/Text/Pandoc/Readers/TikiWiki.hs654
1 files changed, 654 insertions, 0 deletions
diff --git a/src/Text/Pandoc/Readers/TikiWiki.hs b/src/Text/Pandoc/Readers/TikiWiki.hs
new file mode 100644
index 000000000..a92f7bed2
--- /dev/null
+++ b/src/Text/Pandoc/Readers/TikiWiki.hs
@@ -0,0 +1,654 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RelaxedPolyRec #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+{- |
+ Module : Text.Pandoc.Readers.TikiWiki
+ Copyright : Copyright (C) 2017 Robin Lee Powell
+ License : GPLv2
+
+ Maintainer : Robin Lee Powell <robinleepowell@gmail.com>
+ Stability : alpha
+ Portability : portable
+
+Conversion of TikiWiki text to 'Pandoc' document.
+-}
+
+module Text.Pandoc.Readers.TikiWiki ( readTikiWiki
+ ) where
+
+import Control.Monad
+import Control.Monad.Except (throwError)
+import qualified Data.Foldable as F
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Text.Pandoc.Builder as B
+import Text.Pandoc.Class (CommonState (..), PandocMonad (..))
+import Text.Pandoc.Definition
+import Text.Pandoc.Logging (Verbosity (..))
+import Text.Pandoc.Options
+import Text.Pandoc.Parsing hiding (enclosed, nested)
+import Text.Pandoc.Shared (crFilter)
+import Text.Pandoc.XML (fromEntities)
+import Text.Printf (printf)
+
+-- | Read TikiWiki from an input string and return a Pandoc document.
+readTikiWiki :: PandocMonad m
+ => ReaderOptions
+ -> Text
+ -> m Pandoc
+readTikiWiki opts s = do
+ res <- readWithM parseTikiWiki def{ stateOptions = opts }
+ (T.unpack (crFilter s) ++ "\n\n")
+ case res of
+ Left e -> throwError e
+ Right d -> return d
+
+type TikiWikiParser = ParserT [Char] ParserState
+
+--
+-- utility functions
+--
+
+tryMsg :: PandocMonad m => String -> TikiWikiParser m a -> TikiWikiParser m a
+tryMsg msg p = try p <?> msg
+
+skip :: PandocMonad m => TikiWikiParser m a -> TikiWikiParser m ()
+skip parser = Control.Monad.void parser
+
+nested :: PandocMonad m => TikiWikiParser m a -> TikiWikiParser m a
+nested p = do
+ nestlevel <- stateMaxNestingLevel <$> getState
+ guard $ nestlevel > 0
+ updateState $ \st -> st{ stateMaxNestingLevel = stateMaxNestingLevel st - 1 }
+ res <- p
+ updateState $ \st -> st{ stateMaxNestingLevel = nestlevel }
+ return res
+
+--
+-- main parser
+--
+
+parseTikiWiki :: PandocMonad m => TikiWikiParser m Pandoc
+parseTikiWiki = do
+ bs <- mconcat <$> many block
+ spaces
+ eof
+ return $ B.doc bs
+
+block :: PandocMonad m => TikiWikiParser m B.Blocks
+block = do
+ verbosity <- getsCommonState stVerbosity
+ pos <- getPosition
+ res <- mempty <$ skipMany1 blankline
+ <|> blockElements
+ <|> para
+ skipMany blankline
+ when (verbosity >= INFO) $
+ trace (printf "line %d: %s" (sourceLine pos) (take 60 $ show $ B.toList res))
+ return res
+
+blockElements :: PandocMonad m => TikiWikiParser m B.Blocks
+blockElements = choice [ table
+ , hr
+ , header
+ , mixedList
+ , definitionList
+ , codeMacro
+ ]
+
+-- top
+-- ----
+-- bottom
+--
+-- ----
+--
+hr :: PandocMonad m => TikiWikiParser m B.Blocks
+hr = try $ do
+ string "----"
+ many (char '-')
+ newline
+ return B.horizontalRule
+
+-- ! header
+--
+-- !! header level two
+--
+-- !!! header level 3
+--
+header :: PandocMonad m => TikiWikiParser m B.Blocks
+header = tryMsg "header" $ do
+ level <- fmap length (many1 (char '!'))
+ guard $ level <= 6
+ skipSpaces
+ content <- B.trimInlines . mconcat <$> manyTill inline newline
+ attr <- registerHeader nullAttr content
+ return $B.headerWith attr level content
+
+tableRow :: PandocMonad m => TikiWikiParser m [B.Blocks]
+tableRow = try $ do
+-- row <- sepBy1 (many1Till inline $ oneOf "\n|") (try $ string "|" <* notFollowedBy (oneOf "|\n"))
+-- return $ map (B.plain . mconcat) row
+ row <- sepBy1 (many1 (noneOf "\n|") >>= parseColumn) (try $ string "|" <* notFollowedBy (oneOf "|\n"))
+ return $ map B.plain row
+ where
+ parseColumn x = do
+ parsed <- parseFromString (many1 inline) x
+ return $ mconcat parsed
+
+
+
+-- Tables:
+--
+-- ||foo||
+--
+-- ||row1-column1|row1-column2||row2-column1|row2-column2||
+--
+-- ||row1-column1|row1-column2
+-- row2-column1|row2-column2||
+--
+-- ||row1-column1|row1-column2
+-- row2-column1|row2-column2||row3-column1|row3-column2||
+--
+-- || Orange | Apple | more
+-- Bread | Pie | more
+-- Butter | Ice cream | and more ||
+--
+table :: PandocMonad m => TikiWikiParser m B.Blocks
+table = try $ do
+ string "||"
+ rows <- sepBy1 tableRow (try $ string "\n" <|> (string "||" <* notFollowedBy (string "\n")))
+ string "||"
+ newline
+ -- return $ B.simpleTable (headers rows) $ trace ("rows: " ++ (show rows)) rows
+ return $B.simpleTable (headers rows) rows
+ where
+ -- The headers are as many empty srings as the number of columns
+ -- in the first row
+ headers rows = map (B.plain . B.str) $replicate (length $ head rows) ""
+
+para :: PandocMonad m => TikiWikiParser m B.Blocks
+para = fmap (result . mconcat) ( many1Till inline endOfParaElement)
+ where
+ endOfParaElement = lookAhead $ endOfInput <|> endOfPara <|> newBlockElement
+ endOfInput = try $ skipMany blankline >> skipSpaces >> eof
+ endOfPara = try $ blankline >> skipMany1 blankline
+ newBlockElement = try $ blankline >> skip blockElements
+ result content = if F.all (==Space) content
+ then mempty
+ else B.para $ B.trimInlines content
+
+-- ;item 1: definition 1
+-- ;item 2: definition 2-1
+-- + definition 2-2
+-- ;item ''3'': definition ''3''
+--
+definitionList :: PandocMonad m => TikiWikiParser m B.Blocks
+definitionList = tryMsg "definitionList" $ do
+ elements <-many1 parseDefinitionListItem
+ return $ B.definitionList elements
+ where
+ parseDefinitionListItem :: PandocMonad m => TikiWikiParser m (B.Inlines, [B.Blocks])
+ parseDefinitionListItem = do
+ skipSpaces >> char ';' <* skipSpaces
+ term <- many1Till inline $ char ':' <* skipSpaces
+ line <- listItemLine 1
+ return (mconcat term, [B.plain line])
+
+data ListType = None | Numbered | Bullet deriving (Ord, Eq, Show)
+
+data ListNesting = LN { lntype :: ListType, lnnest :: Int } deriving (Ord, Eq, Show)
+
+-- The first argument is a stack (most recent == head) of our list
+-- nesting status; the list type and the nesting level; if we're in
+-- a number list in a bullet list it'd be
+-- [LN Numbered 2, LN Bullet 1]
+--
+-- Mixed list example:
+--
+-- # one
+-- # two
+-- ** two point one
+-- ** two point two
+-- # three
+-- # four
+--
+mixedList :: PandocMonad m => TikiWikiParser m B.Blocks
+mixedList = try $ do
+ items <- try $ many1 listItem
+ return $ mconcat $ fixListNesting $ spanFoldUpList (LN None 0) items
+
+-- See the "Handling Lists" section of DESIGN-CODE for why this
+-- function exists. It's to post-process the lists and do some
+-- mappends.
+--
+-- We need to walk the tree two items at a time, so we can see what
+-- we're going to join *to* before we get there.
+--
+-- Because of that, it seemed easier to do it by hand than to try to
+-- figre out a fold or something.
+fixListNesting :: [B.Blocks] -> [B.Blocks]
+fixListNesting [] = []
+fixListNesting [first] = [recurseOnList first]
+-- fixListNesting nestall | trace ("\n\nfixListNesting: " ++ (show nestall)) False = undefined
+-- fixListNesting nestall@(first:second:rest) =
+fixListNesting (first:second:rest) =
+ let secondBlock = head $ B.toList second in
+ case secondBlock of
+ BulletList _ -> fixListNesting $ mappend (recurseOnList first) (recurseOnList second) : rest
+ OrderedList _ _ -> fixListNesting $ mappend (recurseOnList first) (recurseOnList second) : rest
+ _ -> recurseOnList first : fixListNesting (second:rest)
+
+-- This function walks the Block structure for fixListNesting,
+-- because it's a bit complicated, what with converting to and from
+-- lists and so on.
+recurseOnList :: B.Blocks -> B.Blocks
+-- recurseOnList item | trace ("rOL: " ++ (show $ length $ B.toList item) ++ ", " ++ (show $ B.toList item)) False = undefined
+recurseOnList items
+ | length (B.toList items) == 1 =
+ let itemBlock = head $ B.toList items in
+ case itemBlock of
+ BulletList listItems -> B.bulletList $ fixListNesting $ map B.fromList listItems
+ OrderedList _ listItems -> B.orderedList $ fixListNesting $ map B.fromList listItems
+ _ -> items
+
+ -- The otherwise works because we constructed the blocks, and we
+ -- know for a fact that no mappends have been run on them; each
+ -- Blocks consists of exactly one Block.
+ --
+ -- Anything that's not like that has already been processed by
+ -- fixListNesting; don't bother to process it again.
+ | otherwise = items
+
+
+-- Turn the list if list items into a tree by breaking off the first
+-- item, splitting the remainder of the list into items that are in
+-- the tree of the first item and those that aren't, wrapping the
+-- tree of the first item in its list time, and recursing on both
+-- sections.
+spanFoldUpList :: ListNesting -> [(ListNesting, B.Blocks)] -> [B.Blocks]
+spanFoldUpList _ [] = []
+spanFoldUpList ln [first] =
+ listWrap ln (fst first) [snd first]
+spanFoldUpList ln (first:rest) =
+ let (span1, span2) = span (splitListNesting (fst first)) rest
+ newTree1 = listWrap ln (fst first) $ snd first : spanFoldUpList (fst first) span1
+ newTree2 = spanFoldUpList ln span2
+ in
+ newTree1 ++ newTree2
+
+-- Decide if the second item should be in the tree of the first
+-- item, which is true if the second item is at a deeper nesting
+-- level and of the same type.
+splitListNesting :: ListNesting -> (ListNesting, B.Blocks) -> Bool
+splitListNesting ln1 (ln2, _)
+ | lnnest ln1 < lnnest ln2 =
+ True
+ | ln1 == ln2 =
+ True
+ | otherwise =
+ False
+
+-- If we've moved to a deeper nesting level, wrap the new level in
+-- the appropriate type of list.
+listWrap :: ListNesting -> ListNesting -> [B.Blocks] -> [B.Blocks]
+listWrap upperLN curLN retTree =
+ if upperLN == curLN then
+ retTree
+ else
+ case lntype curLN of
+ None -> []
+ Bullet -> [B.bulletList retTree]
+ Numbered -> [B.orderedList retTree]
+
+listItem :: PandocMonad m => TikiWikiParser m (ListNesting, B.Blocks)
+listItem = choice [
+ bulletItem
+ , numberedItem
+ ]
+
+
+-- * Start each line
+-- * with an asterisk (*).
+-- ** More asterisks gives deeper
+-- *** and deeper levels.
+--
+bulletItem :: PandocMonad m => TikiWikiParser m (ListNesting, B.Blocks)
+bulletItem = try $ do
+ prefix <- many1 $ char '*'
+ many1 $ char ' '
+ content <- listItemLine (length prefix)
+ return (LN Bullet (length prefix), B.plain content)
+
+-- # Start each line
+-- # with a number (1.).
+-- ## More number signs gives deeper
+-- ### and deeper
+--
+numberedItem :: PandocMonad m => TikiWikiParser m (ListNesting, B.Blocks)
+numberedItem = try $ do
+ prefix <- many1 $ char '#'
+ many1 $ char ' '
+ content <- listItemLine (length prefix)
+ return (LN Numbered (length prefix), B.plain content)
+
+listItemLine :: PandocMonad m => Int -> TikiWikiParser m B.Inlines
+listItemLine nest = lineContent >>= parseContent
+ where
+ lineContent = do
+ content <- anyLine
+ continuation <- optionMaybe listContinuation
+ return $ filterSpaces content ++ "\n" ++ Data.Maybe.fromMaybe "" continuation
+ filterSpaces = reverse . dropWhile (== ' ') . reverse
+ listContinuation = string (replicate nest '+') >> lineContent
+ parseContent x = do
+ parsed <- parseFromString (many1 inline) x
+ return $ mconcat parsed
+
+-- Turn the CODE macro attributes into Pandoc code block attributes.
+mungeAttrs :: [(String, String)] -> (String, [String], [(String, String)])
+mungeAttrs rawAttrs = ("", classes, rawAttrs)
+ where
+ -- "colors" is TikiWiki CODE macro for "name of language to do
+ -- highlighting for"; turn the value into a class
+ color = fromMaybe "" $ lookup "colors" rawAttrs
+ -- ln = 1 means line numbering. It's also the default. So we
+ -- emit numberLines as a class unless ln = 0
+ lnRaw = fromMaybe "1" $ lookup "ln" rawAttrs
+ ln = if lnRaw == "0" then
+ ""
+ else
+ "numberLines"
+ classes = filter (/= "") [color, ln]
+
+codeMacro :: PandocMonad m => TikiWikiParser m B.Blocks
+codeMacro = try $ do
+ string "{CODE("
+ rawAttrs <- macroAttrs
+ string ")}"
+ body <- manyTill anyChar (try (string "{CODE}"))
+ newline
+ if not (null rawAttrs)
+ then
+ return $ B.codeBlockWith (mungeAttrs rawAttrs) body
+ else
+ return $ B.codeBlock body
+
+
+--
+-- inline parsers
+--
+
+inline :: PandocMonad m => TikiWikiParser m B.Inlines
+inline = choice [ whitespace
+ , noparse
+ , strong
+ , emph
+ , nbsp
+ , image
+ , htmlComment
+ , strikeout
+ , code
+ , wikiLink
+ , notExternalLink
+ , externalLink
+ , superTag
+ , superMacro
+ , subTag
+ , subMacro
+ , escapedChar
+ , colored
+ , centered
+ , underlined
+ , boxed
+ , breakChars
+ , str
+ , symbol
+ ] <?> "inline"
+
+whitespace :: PandocMonad m => TikiWikiParser m B.Inlines
+whitespace = lb <|> regsp
+ where lb = try $ skipMany spaceChar >> linebreak >> return B.space
+ regsp = try $ skipMany1 spaceChar >> return B.space
+
+-- UNSUPPORTED, as there doesn't seem to be any facility in calibre
+-- for this
+nbsp :: PandocMonad m => TikiWikiParser m B.Inlines
+nbsp = try $ do
+ string "~hs~"
+ return $ B.str " NOT SUPPORTED BEGIN: ~hs~ (non-breaking space) :END "
+
+-- UNSUPPORTED, as the desired behaviour (that the data be
+-- *retained* and stored as a comment) doesn't exist in calibre, and
+-- silently throwing data out seemed bad.
+htmlComment :: PandocMonad m => TikiWikiParser m B.Inlines
+htmlComment = try $ do
+ string "~hc~"
+ inner <- many1 $ noneOf "~"
+ string "~/hc~"
+ return $ B.str $ " NOT SUPPORTED: ~hc~ (html comment opener) BEGIN: " ++ inner ++ " ~/hc~ :END "
+
+linebreak :: PandocMonad m => TikiWikiParser m B.Inlines
+linebreak = newline >> notFollowedBy newline >> (lastNewline <|> innerNewline)
+ where lastNewline = eof >> return mempty
+ innerNewline = return B.space
+
+between :: (Monoid c, PandocMonad m, Show b) => TikiWikiParser m a -> TikiWikiParser m b -> (TikiWikiParser m b -> TikiWikiParser m c) -> TikiWikiParser m c
+between start end p =
+ mconcat <$> try (start >> notFollowedBy whitespace >> many1Till (p end) end)
+
+enclosed :: (Monoid b, PandocMonad m, Show a) => TikiWikiParser m a -> (TikiWikiParser m a -> TikiWikiParser m b) -> TikiWikiParser m b
+enclosed sep p = between sep (try $ sep <* endMarker) p
+ where
+ endMarker = lookAhead $ skip endSpace <|> skip (oneOf ".,!?:)|'_") <|> eof
+ endSpace = (spaceChar <|> newline) >> return B.space
+
+
+nestedInlines :: (Show a, PandocMonad m) => TikiWikiParser m a -> TikiWikiParser m B.Inlines
+nestedInlines end = innerSpace <|> nestedInline
+ where
+ innerSpace = try $ whitespace <* notFollowedBy end
+ nestedInline = notFollowedBy whitespace >> nested inline
+
+-- {img attId="39" imalign="right" link="http://info.tikiwiki.org" alt="Panama Hat"}
+--
+-- {img attId="37", thumb="mouseover", styleimage="border", desc="150"}
+--
+-- {img src="img/wiki_up/393px-Pears.jpg" thumb="y" imalign="center" stylebox="border" button="y" desc="Pretty pears" max="200" rel="box"}
+--
+image :: PandocMonad m => TikiWikiParser m B.Inlines
+image = try $ do
+ string "{img "
+ rawAttrs <- sepEndBy1 imageAttr spaces
+ string "}"
+ let src = fromMaybe "" $ lookup "src" rawAttrs
+ let title = fromMaybe src $ lookup "desc" rawAttrs
+ let alt = fromMaybe title $ lookup "alt" rawAttrs
+ let classes = map fst $ filter (\(_,b) -> b == "" || b == "y") rawAttrs
+ if not (null src)
+ then
+ return $ B.imageWith ("", classes, rawAttrs) src title (B.str alt)
+ else
+ return $ B.str $ " NOT SUPPORTED: image without src attribute BEGIN: {img " ++ printAttrs rawAttrs ++ "} :END "
+ where
+ printAttrs attrs = unwords $ map (\(a, b) -> a ++ "=\"" ++ b ++ "\"") attrs
+
+imageAttr :: PandocMonad m => TikiWikiParser m (String, String)
+imageAttr = try $ do
+ key <- many1 (noneOf "=} \t\n")
+ char '='
+ optional $ char '"'
+ value <- many1 (noneOf "}\"\n")
+ optional $ char '"'
+ optional $ char ','
+ return (key, value)
+
+
+-- __strong__
+strong :: PandocMonad m => TikiWikiParser m B.Inlines
+strong = try $ fmap B.strong (enclosed (string "__") nestedInlines)
+
+-- ''emph''
+emph :: PandocMonad m => TikiWikiParser m B.Inlines
+emph = try $ fmap B.emph (enclosed (string "''") nestedInlines)
+
+-- ~246~
+escapedChar :: PandocMonad m => TikiWikiParser m B.Inlines
+escapedChar = try $ do
+ string "~"
+ inner <- many1 $ oneOf "0123456789"
+ string "~"
+ return $B.str [toEnum (read inner :: Int) :: Char]
+
+-- UNSUPPORTED, as there doesn't seem to be any facility in calibre
+-- for this
+centered :: PandocMonad m => TikiWikiParser m B.Inlines
+centered = try $ do
+ string "::"
+ inner <- many1 $ noneOf ":\n"
+ string "::"
+ return $ B.str $ " NOT SUPPORTED: :: (centered) BEGIN: ::" ++ inner ++ ":: :END "
+
+-- UNSUPPORTED, as there doesn't seem to be any facility in calibre
+-- for this
+colored :: PandocMonad m => TikiWikiParser m B.Inlines
+colored = try $ do
+ string "~~"
+ inner <- many1 $ noneOf "~\n"
+ string "~~"
+ return $ B.str $ " NOT SUPPORTED: ~~ (colored) BEGIN: ~~" ++ inner ++ "~~ :END "
+
+-- UNSUPPORTED, as there doesn't seem to be any facility in calibre
+-- for this
+underlined :: PandocMonad m => TikiWikiParser m B.Inlines
+underlined = try $ do
+ string "==="
+ inner <- many1 $ noneOf "=\n"
+ string "==="
+ return $ B.str $ " NOT SUPPORTED: ==== (underlined) BEGIN: ===" ++ inner ++ "=== :END "
+
+-- UNSUPPORTED, as there doesn't seem to be any facility in calibre
+-- for this
+boxed :: PandocMonad m => TikiWikiParser m B.Inlines
+boxed = try $ do
+ string "^"
+ inner <- many1 $ noneOf "^\n"
+ string "^"
+ return $ B.str $ " NOT SUPPORTED: ^ (boxed) BEGIN: ^" ++ inner ++ "^ :END "
+
+-- --text--
+strikeout :: PandocMonad m => TikiWikiParser m B.Inlines
+strikeout = try $ fmap B.strikeout (enclosed (string "--") nestedInlines)
+
+nestedString :: (Show a, PandocMonad m) => TikiWikiParser m a -> TikiWikiParser m String
+nestedString end = innerSpace <|> count 1 nonspaceChar
+ where
+ innerSpace = try $ many1 spaceChar <* notFollowedBy end
+
+breakChars :: PandocMonad m => TikiWikiParser m B.Inlines
+breakChars = try $ string "%%%" >> return B.linebreak
+
+-- superscript: foo{TAG(tag=>sup)}super{TAG}foo / bar{SUP()}super2{SUP}bar
+superTag :: PandocMonad m => TikiWikiParser m B.Inlines
+superTag = try $ fmap (B.superscript . B.text . fromEntities) ( between (string "{TAG(tag=>sup)}") (string "{TAG}") nestedString)
+
+superMacro :: PandocMonad m => TikiWikiParser m B.Inlines
+superMacro = try $ do
+ string "{SUP("
+ manyTill anyChar (string ")}")
+ body <- manyTill anyChar (string "{SUP}")
+ return $ B.superscript $ B.text body
+
+-- subscript: baz{TAG(tag=>sub)}sub{TAG}qux / qux{SUB()}sub2{SUB}qux
+subTag :: PandocMonad m => TikiWikiParser m B.Inlines
+subTag = try $ fmap (B.subscript . B.text . fromEntities) ( between (string "{TAG(tag=>sub)}") (string "{TAG}") nestedString)
+
+subMacro :: PandocMonad m => TikiWikiParser m B.Inlines
+subMacro = try $ do
+ string "{SUB("
+ manyTill anyChar (string ")}")
+ body <- manyTill anyChar (string "{SUB}")
+ return $ B.subscript $ B.text body
+
+-- -+text+-
+code :: PandocMonad m => TikiWikiParser m B.Inlines
+code = try $ fmap (B.code . fromEntities) ( between (string "-+") (string "+-") nestedString)
+
+macroAttr :: PandocMonad m => TikiWikiParser m (String, String)
+macroAttr = try $ do
+ key <- many1 (noneOf "=)")
+ char '='
+ optional $ char '"'
+ value <- many1 (noneOf " )\"")
+ optional $ char '"'
+ return (key, value)
+
+macroAttrs :: PandocMonad m => TikiWikiParser m [(String, String)]
+macroAttrs = try $ sepEndBy macroAttr spaces
+
+-- ~np~ __not bold__ ~/np~
+noparse :: PandocMonad m => TikiWikiParser m B.Inlines
+noparse = try $ do
+ string "~np~"
+ body <- manyTill anyChar (string "~/np~")
+ return $ B.str body
+
+str :: PandocMonad m => TikiWikiParser m B.Inlines
+str = fmap B.str (many1 alphaNum <|> count 1 characterReference)
+
+symbol :: PandocMonad m => TikiWikiParser m B.Inlines
+symbol = fmap B.str (count 1 nonspaceChar)
+
+-- [[not a link]
+notExternalLink :: PandocMonad m => TikiWikiParser m B.Inlines
+notExternalLink = try $ do
+ start <- string "[["
+ body <- many (noneOf "\n[]")
+ end <- string "]"
+ return $ B.text (start ++ body ++ end)
+
+-- [http://www.somesite.org url|Some Site title]
+-- ((internal link))
+--
+-- The ((...)) wiki links and [...] external links are handled
+-- exactly the same; this abstracts that out
+makeLink :: PandocMonad m => String -> String -> String -> TikiWikiParser m B.Inlines
+makeLink start middle end = try $ do
+ st <- getState
+ guard $ stateAllowLinks st
+ setState $ st{ stateAllowLinks = False }
+ (url, title, anchor) <- wikiLinkText start middle end
+ parsedTitle <- parseFromString (many1 inline) title
+ setState $ st{ stateAllowLinks = True }
+ return $ B.link (url++anchor) "" $mconcat parsedTitle
+
+wikiLinkText :: PandocMonad m => String -> String -> String -> TikiWikiParser m (String, String, String)
+wikiLinkText start middle end = do
+ string start
+ url <- many1 (noneOf $ middle ++ "\n")
+ seg1 <- option url linkContent
+ seg2 <- option "" linkContent
+ string end
+ if seg2 /= ""
+ then
+ return (url, seg2, seg1)
+ else
+ return (url, seg1, "")
+ where
+ linkContent = do
+ char '|'
+ many (noneOf middle)
+
+externalLink :: PandocMonad m => TikiWikiParser m B.Inlines
+externalLink = makeLink "[" "]|" "]"
+
+-- NB: this wiki linking is unlikely to work for anyone besides me
+-- (rlpowell); it happens to work for me because my Hakyll code has
+-- post-processing that treats pandoc .md titles as valid link
+-- targets, so something like
+-- [see also this other post](My Other Page) is perfectly valid.
+wikiLink :: PandocMonad m => TikiWikiParser m B.Inlines
+wikiLink = makeLink "((" ")|" "))"
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-18 13:24:27 +0000