1{-# LANGUAGE FlexibleContexts #-} 2{-# LANGUAGE OverloadedStrings #-} 3 4{- | 5 Module : Text.Pandoc.Readers.TikiWiki 6 Copyright : Copyright (C) 2017 Robin Lee Powell 7 License : GNU GPL, version 2 or above 8 9 Maintainer : Robin Lee Powell <robinleepowell@gmail.com> 10 Stability : alpha 11 Portability : portable 12 13Conversion of TikiWiki text to 'Pandoc' document. 14-} 15 16module Text.Pandoc.Readers.TikiWiki ( readTikiWiki 17 ) where 18 19import Control.Monad 20import Control.Monad.Except (throwError) 21import qualified Data.Foldable as F 22import Data.List (dropWhileEnd) 23import Data.Maybe (fromMaybe) 24import Data.Text (Text) 25import qualified Data.Text as T 26import qualified Text.Pandoc.Builder as B 27import Text.Pandoc.Class.CommonState (CommonState (..)) 28import Text.Pandoc.Class.PandocMonad (PandocMonad (..)) 29import Text.Pandoc.Definition 30import Text.Pandoc.Logging (Verbosity (..)) 31import Text.Pandoc.Options 32import Text.Pandoc.Parsing hiding (enclosed, nested) 33import Text.Pandoc.Shared (crFilter, safeRead) 34import Text.Pandoc.XML (fromEntities) 35import Text.Printf (printf) 36 37-- | Read TikiWiki from an input string and return a Pandoc document. 38readTikiWiki :: PandocMonad m 39 => ReaderOptions 40 -> Text 41 -> m Pandoc 42readTikiWiki opts s = do 43 res <- readWithM parseTikiWiki def{ stateOptions = opts } 44 (crFilter s <> "\n\n") 45 case res of 46 Left e -> throwError e 47 Right d -> return d 48 49type TikiWikiParser = ParserT Text ParserState 50 51-- 52-- utility functions 53-- 54 55tryMsg :: Text -> TikiWikiParser m a -> TikiWikiParser m a 56tryMsg msg p = try p <?> T.unpack msg 57 58skip :: TikiWikiParser m a -> TikiWikiParser m () 59skip parser = Control.Monad.void parser 60 61nested :: PandocMonad m => TikiWikiParser m a -> TikiWikiParser m a 62nested p = do 63 nestlevel <- stateMaxNestingLevel <$> getState 64 guard $ nestlevel > 0 65 updateState $ \st -> st{ stateMaxNestingLevel = stateMaxNestingLevel st - 1 } 66 res <- p 67 updateState $ \st -> st{ stateMaxNestingLevel = nestlevel } 68 return res 69 70-- 71-- main parser 72-- 73 74parseTikiWiki :: PandocMonad m => TikiWikiParser m Pandoc 75parseTikiWiki = do 76 bs <- mconcat <$> many block 77 spaces 78 eof 79 return $ B.doc bs 80 81block :: PandocMonad m => TikiWikiParser m B.Blocks 82block = do 83 verbosity <- getsCommonState stVerbosity 84 pos <- getPosition 85 res <- mempty <$ skipMany1 blankline 86 <|> blockElements 87 <|> para 88 skipMany blankline 89 when (verbosity >= INFO) $ 90 trace (T.pack $ printf "line %d: %s" (sourceLine pos) (take 60 $ show $ B.toList res)) 91 return res 92 93blockElements :: PandocMonad m => TikiWikiParser m B.Blocks 94blockElements = choice [ table 95 , hr 96 , header 97 , mixedList 98 , definitionList 99 , codeMacro 100 ] 101 102-- top 103-- ---- 104-- bottom 105-- 106-- ---- 107-- 108hr :: PandocMonad m => TikiWikiParser m B.Blocks 109hr = try $ do 110 string "----" 111 many (char '-') 112 newline 113 return B.horizontalRule 114 115-- ! header 116-- 117-- !! header level two 118-- 119-- !!! header level 3 120-- 121header :: PandocMonad m => TikiWikiParser m B.Blocks 122header = tryMsg "header" $ do 123 level <- fmap length (many1 (char '!')) 124 guard $ level <= 6 125 skipSpaces 126 content <- B.trimInlines . mconcat <$> manyTill inline newline 127 attr <- registerHeader nullAttr content 128 return $B.headerWith attr level content 129 130tableRow :: PandocMonad m => TikiWikiParser m [B.Blocks] 131tableRow = try $ do 132-- row <- sepBy1 (many1Till inline $ oneOf "\n|") (try $ string "|" <* notFollowedBy (oneOf "|\n")) 133-- return $ map (B.plain . mconcat) row 134 row <- sepBy1 (many1 (noneOf "\n|") >>= parseColumn . T.pack) (try $ string "|" <* notFollowedBy (oneOf "|\n")) 135 return $ map B.plain row 136 where 137 parseColumn x = do 138 parsed <- parseFromString (many1 inline) x 139 return $ mconcat parsed 140 141 142 143-- Tables: 144-- 145-- ||foo|| 146-- 147-- ||row1-column1|row1-column2||row2-column1|row2-column2|| 148-- 149-- ||row1-column1|row1-column2 150-- row2-column1|row2-column2|| 151-- 152-- ||row1-column1|row1-column2 153-- row2-column1|row2-column2||row3-column1|row3-column2|| 154-- 155-- || Orange | Apple | more 156-- Bread | Pie | more 157-- Butter | Ice cream | and more || 158-- 159table :: PandocMonad m => TikiWikiParser m B.Blocks 160table = try $ do 161 string "||" 162 rows <- sepBy1 tableRow (try $ string "\n" <|> (string "||" <* notFollowedBy (string "\n"))) 163 string "||" 164 newline 165 -- return $ B.simpleTable (headers rows) $ trace ("rows: " ++ (show rows)) rows 166 return $B.simpleTable (headers rows) rows 167 where 168 -- The headers are as many empty strings as the number of columns 169 -- in the first row 170 headers rows = map (B.plain . B.str) $replicate (length $ head rows) "" 171 172para :: PandocMonad m => TikiWikiParser m B.Blocks 173para = fmap (result . mconcat) ( many1Till inline endOfParaElement) 174 where 175 endOfParaElement = lookAhead $ endOfInput <|> endOfPara <|> newBlockElement 176 endOfInput = try $ skipMany blankline >> skipSpaces >> eof 177 endOfPara = try $ blankline >> skipMany1 blankline 178 newBlockElement = try $ blankline >> skip blockElements 179 result content = if F.all (==Space) content 180 then mempty 181 else B.para $ B.trimInlines content 182 183-- ;item 1: definition 1 184-- ;item 2: definition 2-1 185-- + definition 2-2 186-- ;item ''3'': definition ''3'' 187-- 188definitionList :: PandocMonad m => TikiWikiParser m B.Blocks 189definitionList = tryMsg "definitionList" $ do 190 elements <-many1 parseDefinitionListItem 191 return $ B.definitionList elements 192 where 193 parseDefinitionListItem :: PandocMonad m => TikiWikiParser m (B.Inlines, [B.Blocks]) 194 parseDefinitionListItem = do 195 skipSpaces >> char ';' <* skipSpaces 196 term <- many1Till inline $ char ':' <* skipSpaces 197 line <- listItemLine 1 198 return (mconcat term, [B.plain line]) 199 200data ListType = None | Numbered | Bullet deriving (Ord, Eq, Show) 201 202data ListNesting = LN { lntype :: ListType, lnnest :: Int } deriving (Ord, Eq, Show) 203 204-- The first argument is a stack (most recent == head) of our list 205-- nesting status; the list type and the nesting level; if we're in 206-- a number list in a bullet list it'd be 207-- [LN Numbered 2, LN Bullet 1] 208-- 209-- Mixed list example: 210-- 211-- # one 212-- # two 213-- ** two point one 214-- ** two point two 215-- # three 216-- # four 217-- 218mixedList :: PandocMonad m => TikiWikiParser m B.Blocks 219mixedList = try $ do 220 items <- try $ many1 listItem 221 return $ mconcat $ fixListNesting $ spanFoldUpList (LN None 0) items 222 223-- See the "Handling Lists" section of DESIGN-CODE for why this 224-- function exists. It's to post-process the lists and do some 225-- mappends. 226-- 227-- We need to walk the tree two items at a time, so we can see what 228-- we're going to join *to* before we get there. 229-- 230-- Because of that, it seemed easier to do it by hand than to try to 231-- figre out a fold or something. 232fixListNesting :: [B.Blocks] -> [B.Blocks] 233fixListNesting [] = [] 234fixListNesting [first] = [recurseOnList first] 235-- fixListNesting nestall | trace ("\n\nfixListNesting: " ++ (show nestall)) False = undefined 236-- fixListNesting nestall@(first:second:rest) = 237fixListNesting (first:second:rest) = 238 let secondBlock = head $ B.toList second in 239 case secondBlock of 240 BulletList _ -> fixListNesting $ mappend (recurseOnList first) (recurseOnList second) : rest 241 OrderedList _ _ -> fixListNesting $ mappend (recurseOnList first) (recurseOnList second) : rest 242 _ -> recurseOnList first : fixListNesting (second:rest) 243 244-- This function walks the Block structure for fixListNesting, 245-- because it's a bit complicated, what with converting to and from 246-- lists and so on. 247recurseOnList :: B.Blocks -> B.Blocks 248-- recurseOnList item | trace ("rOL: " ++ (show $ length $ B.toList item) ++ ", " ++ (show $ B.toList item)) False = undefined 249recurseOnList items 250 | length (B.toList items) == 1 = 251 let itemBlock = head $ B.toList items in 252 case itemBlock of 253 BulletList listItems -> B.bulletList $ fixListNesting $ map B.fromList listItems 254 OrderedList _ listItems -> B.orderedList $ fixListNesting $ map B.fromList listItems 255 _ -> items 256 257 -- The otherwise works because we constructed the blocks, and we 258 -- know for a fact that no mappends have been run on them; each 259 -- Blocks consists of exactly one Block. 260 -- 261 -- Anything that's not like that has already been processed by 262 -- fixListNesting; don't bother to process it again. 263 | otherwise = items 264 265 266-- Turn the list if list items into a tree by breaking off the first 267-- item, splitting the remainder of the list into items that are in 268-- the tree of the first item and those that aren't, wrapping the 269-- tree of the first item in its list time, and recursing on both 270-- sections. 271spanFoldUpList :: ListNesting -> [(ListNesting, B.Blocks)] -> [B.Blocks] 272spanFoldUpList _ [] = [] 273spanFoldUpList ln [first] = 274 listWrap ln (fst first) [snd first] 275spanFoldUpList ln (first:rest) = 276 let (span1, span2) = span (splitListNesting (fst first)) rest 277 newTree1 = listWrap ln (fst first) $ snd first : spanFoldUpList (fst first) span1 278 newTree2 = spanFoldUpList ln span2 279 in 280 newTree1 ++ newTree2 281 282-- Decide if the second item should be in the tree of the first 283-- item, which is true if the second item is at a deeper nesting 284-- level and of the same type. 285splitListNesting :: ListNesting -> (ListNesting, B.Blocks) -> Bool 286splitListNesting ln1 (ln2, _) 287 | lnnest ln1 < lnnest ln2 = 288 True 289 | ln1 == ln2 = 290 True 291 | otherwise = 292 False 293 294-- If we've moved to a deeper nesting level, wrap the new level in 295-- the appropriate type of list. 296listWrap :: ListNesting -> ListNesting -> [B.Blocks] -> [B.Blocks] 297listWrap upperLN curLN retTree = 298 if upperLN == curLN then 299 retTree 300 else 301 case lntype curLN of 302 None -> [] 303 Bullet -> [B.bulletList retTree] 304 Numbered -> [B.orderedList retTree] 305 306listItem :: PandocMonad m => TikiWikiParser m (ListNesting, B.Blocks) 307listItem = choice [ 308 bulletItem 309 , numberedItem 310 ] 311 312 313-- * Start each line 314-- * with an asterisk (*). 315-- ** More asterisks gives deeper 316-- *** and deeper levels. 317-- 318bulletItem :: PandocMonad m => TikiWikiParser m (ListNesting, B.Blocks) 319bulletItem = try $ do 320 prefix <- many1 $ char '*' 321 many $ char ' ' 322 content <- listItemLine (length prefix) 323 return (LN Bullet (length prefix), B.plain content) 324 325-- # Start each line 326-- # with a number (1.). 327-- ## More number signs gives deeper 328-- ### and deeper 329-- 330numberedItem :: PandocMonad m => TikiWikiParser m (ListNesting, B.Blocks) 331numberedItem = try $ do 332 prefix <- many1 $ char '#' 333 many $ char ' ' 334 content <- listItemLine (length prefix) 335 return (LN Numbered (length prefix), B.plain content) 336 337listItemLine :: PandocMonad m => Int -> TikiWikiParser m B.Inlines 338listItemLine nest = lineContent >>= parseContent 339 where 340 lineContent = do 341 content <- anyLine 342 continuation <- optionMaybe listContinuation 343 return $ filterSpaces content <> "\n" <> Data.Maybe.fromMaybe "" continuation 344 filterSpaces = T.dropWhileEnd (== ' ') 345 listContinuation = string (replicate nest '+') >> lineContent 346 parseContent x = do 347 parsed <- parseFromString (many1 inline) x 348 return $ mconcat $ dropWhileEnd (== B.space) parsed 349 350-- Turn the CODE macro attributes into Pandoc code block attributes. 351mungeAttrs :: [(Text, Text)] -> (Text, [Text], [(Text, Text)]) 352mungeAttrs rawAttrs = ("", classes, rawAttrs) 353 where 354 -- "colors" is TikiWiki CODE macro for "name of language to do 355 -- highlighting for"; turn the value into a class 356 color = fromMaybe "" $ lookup "colors" rawAttrs 357 -- ln = 1 means line numbering. It's also the default. So we 358 -- emit numberLines as a class unless ln = 0 359 lnRaw = fromMaybe "1" $ lookup "ln" rawAttrs 360 ln = if lnRaw == "0" then 361 "" 362 else 363 "numberLines" 364 classes = filter (/= "") [color, ln] 365 366codeMacro :: PandocMonad m => TikiWikiParser m B.Blocks 367codeMacro = try $ do 368 string "{CODE(" 369 rawAttrs <- macroAttrs 370 string ")}" 371 body <- T.pack <$> manyTill anyChar (try (string "{CODE}")) 372 newline 373 if not (null rawAttrs) 374 then 375 return $ B.codeBlockWith (mungeAttrs rawAttrs) body 376 else 377 return $ B.codeBlock body 378 379 380-- 381-- inline parsers 382-- 383 384inline :: PandocMonad m => TikiWikiParser m B.Inlines 385inline = choice [ whitespace 386 , noparse 387 , strong 388 , emph 389 , nbsp 390 , image 391 , htmlComment 392 , strikeout 393 , code 394 , wikiLink 395 , notExternalLink 396 , externalLink 397 , superTag 398 , superMacro 399 , subTag 400 , subMacro 401 , escapedChar 402 , colored 403 , centered 404 , underlined 405 , boxed 406 , breakChars 407 , str 408 , symbol 409 ] <?> "inline" 410 411whitespace :: PandocMonad m => TikiWikiParser m B.Inlines 412whitespace = lb <|> regsp 413 where lb = try $ skipMany spaceChar >> linebreak >> return B.space 414 regsp = try $ skipMany1 spaceChar >> return B.space 415 416-- UNSUPPORTED, as there doesn't seem to be any facility in calibre 417-- for this 418nbsp :: PandocMonad m => TikiWikiParser m B.Inlines 419nbsp = try $ do 420 string "~hs~" 421 return $ B.str " NOT SUPPORTED BEGIN: ~hs~ (non-breaking space) :END " 422 423-- UNSUPPORTED, as the desired behaviour (that the data be 424-- *retained* and stored as a comment) doesn't exist in calibre, and 425-- silently throwing data out seemed bad. 426htmlComment :: PandocMonad m => TikiWikiParser m B.Inlines 427htmlComment = try $ do 428 string "~hc~" 429 inner <- fmap T.pack $ many1 $ noneOf "~" 430 string "~/hc~" 431 return $ B.str $ " NOT SUPPORTED: ~hc~ (html comment opener) BEGIN: " <> inner <> " ~/hc~ :END " 432 433linebreak :: PandocMonad m => TikiWikiParser m B.Inlines 434linebreak = newline >> notFollowedBy newline >> (lastNewline <|> innerNewline) 435 where lastNewline = eof >> return mempty 436 innerNewline = return B.space 437 438between :: (Monoid c, PandocMonad m, Show b) => TikiWikiParser m a -> TikiWikiParser m b -> (TikiWikiParser m b -> TikiWikiParser m c) -> TikiWikiParser m c 439between start end p = 440 mconcat <$> try (start >> notFollowedBy whitespace >> many1Till (p end) end) 441 442enclosed :: (Monoid b, PandocMonad m, Show a) => TikiWikiParser m a -> (TikiWikiParser m a -> TikiWikiParser m b) -> TikiWikiParser m b 443enclosed sep p = between sep (try $ sep <* endMarker) p 444 where 445 endMarker = lookAhead $ skip endSpace <|> skip (oneOf ".,!?:)|'_") <|> eof 446 endSpace = (spaceChar <|> newline) >> return B.space 447 448 449nestedInlines :: (Show a, PandocMonad m) => TikiWikiParser m a -> TikiWikiParser m B.Inlines 450nestedInlines end = innerSpace <|> nestedInline 451 where 452 innerSpace = try $ whitespace <* notFollowedBy end 453 nestedInline = notFollowedBy whitespace >> nested inline 454 455-- {img attId="39" imalign="right" link="http://info.tikiwiki.org" alt="Panama Hat"} 456-- 457-- {img attId="37", thumb="mouseover", styleimage="border", desc="150"} 458-- 459-- {img src="img/wiki_up/393px-Pears.jpg" thumb="y" imalign="center" stylebox="border" button="y" desc="Pretty pears" max="200" rel="box"} 460-- 461image :: PandocMonad m => TikiWikiParser m B.Inlines 462image = try $ do 463 string "{img " 464 rawAttrs <- sepEndBy1 imageAttr spaces 465 string "}" 466 let src = fromMaybe "" $ lookup "src" rawAttrs 467 let title = fromMaybe src $ lookup "desc" rawAttrs 468 let alt = fromMaybe title $ lookup "alt" rawAttrs 469 let classes = map fst $ filter (\(_,b) -> b == "" || b == "y") rawAttrs 470 if not (T.null src) 471 then 472 return $ B.imageWith ("", classes, rawAttrs) src title (B.str alt) 473 else 474 return $ B.str $ " NOT SUPPORTED: image without src attribute BEGIN: {img " <> printAttrs rawAttrs <> "} :END " 475 where 476 printAttrs attrs = T.unwords $ map (\(a, b) -> a <> "=\"" <> b <> "\"") attrs 477 478imageAttr :: PandocMonad m => TikiWikiParser m (Text, Text) 479imageAttr = try $ do 480 key <- many1 (noneOf "=} \t\n") 481 char '=' 482 optional $ char '"' 483 value <- many1 (noneOf "}\"\n") 484 optional $ char '"' 485 optional $ char ',' 486 return (T.pack key, T.pack value) 487 488 489-- __strong__ 490strong :: PandocMonad m => TikiWikiParser m B.Inlines 491strong = try $ fmap B.strong (enclosed (string "__") nestedInlines) 492 493-- ''emph'' 494emph :: PandocMonad m => TikiWikiParser m B.Inlines 495emph = try $ fmap B.emph (enclosed (string "''") nestedInlines) 496 497-- ~246~ 498escapedChar :: PandocMonad m => TikiWikiParser m B.Inlines 499escapedChar = try $ do 500 string "~" 501 mNumber <- safeRead . T.pack <$> many1 digit 502 string "~" 503 return $ B.str $ 504 case mNumber of 505 Just number -> T.singleton $ toEnum (number :: Int) 506 Nothing -> "" 507 508-- UNSUPPORTED, as there doesn't seem to be any facility in calibre 509-- for this 510centered :: PandocMonad m => TikiWikiParser m B.Inlines 511centered = try $ do 512 string "::" 513 inner <- fmap T.pack $ many1 $ noneOf ":\n" 514 string "::" 515 return $ B.str $ " NOT SUPPORTED: :: (centered) BEGIN: ::" <> inner <> ":: :END " 516 517-- UNSUPPORTED, as there doesn't seem to be any facility in calibre 518-- for this 519colored :: PandocMonad m => TikiWikiParser m B.Inlines 520colored = try $ do 521 string "~~" 522 inner <- fmap T.pack $ many1 $ noneOf "~\n" 523 string "~~" 524 return $ B.str $ " NOT SUPPORTED: ~~ (colored) BEGIN: ~~" <> inner <> "~~ :END " 525 526-- UNSUPPORTED, as there doesn't seem to be any facility in calibre 527-- for this 528underlined :: PandocMonad m => TikiWikiParser m B.Inlines 529underlined = try $ do 530 string "===" 531 inner <- fmap T.pack $ many1 $ noneOf "=\n" 532 string "===" 533 return $ B.str $ " NOT SUPPORTED: ==== (underlined) BEGIN: ===" <> inner <> "=== :END " 534 535-- UNSUPPORTED, as there doesn't seem to be any facility in calibre 536-- for this 537boxed :: PandocMonad m => TikiWikiParser m B.Inlines 538boxed = try $ do 539 string "^" 540 inner <- fmap T.pack $ many1 $ noneOf "^\n" 541 string "^" 542 return $ B.str $ " NOT SUPPORTED: ^ (boxed) BEGIN: ^" <> inner <> "^ :END " 543 544-- --text-- 545strikeout :: PandocMonad m => TikiWikiParser m B.Inlines 546strikeout = try $ fmap B.strikeout (enclosed (string "--") nestedInlines) 547 548nestedString :: (Show a, PandocMonad m) => TikiWikiParser m a -> TikiWikiParser m Text 549nestedString end = innerSpace <|> countChar 1 nonspaceChar 550 where 551 innerSpace = try $ T.pack <$> many1 spaceChar <* notFollowedBy end 552 553breakChars :: PandocMonad m => TikiWikiParser m B.Inlines 554breakChars = try $ string "%%%" >> return B.linebreak 555 556-- superscript: foo{TAG(tag=>sup)}super{TAG}foo / bar{SUP()}super2{SUP}bar 557superTag :: PandocMonad m => TikiWikiParser m B.Inlines 558superTag = try $ fmap (B.superscript . B.text . fromEntities) ( between (string "{TAG(tag=>sup)}") (string "{TAG}") nestedString) 559 560superMacro :: PandocMonad m => TikiWikiParser m B.Inlines 561superMacro = try $ do 562 string "{SUP(" 563 manyTill anyChar (string ")}") 564 body <- manyTill anyChar (string "{SUP}") 565 return $ B.superscript $ B.text $ T.pack body 566 567-- subscript: baz{TAG(tag=>sub)}sub{TAG}qux / qux{SUB()}sub2{SUB}qux 568subTag :: PandocMonad m => TikiWikiParser m B.Inlines 569subTag = try $ fmap (B.subscript . B.text . fromEntities) ( between (string "{TAG(tag=>sub)}") (string "{TAG}") nestedString) 570 571subMacro :: PandocMonad m => TikiWikiParser m B.Inlines 572subMacro = try $ do 573 string "{SUB(" 574 manyTill anyChar (string ")}") 575 body <- manyTill anyChar (string "{SUB}") 576 return $ B.subscript $ B.text $ T.pack body 577 578-- -+text+- 579code :: PandocMonad m => TikiWikiParser m B.Inlines 580code = try $ fmap (B.code . fromEntities) ( between (string "-+") (string "+-") nestedString) 581 582macroAttr :: PandocMonad m => TikiWikiParser m (Text, Text) 583macroAttr = try $ do 584 key <- many1 (noneOf "=)") 585 char '=' 586 optional $ char '"' 587 value <- many1 (noneOf " )\"") 588 optional $ char '"' 589 return (T.pack key, T.pack value) 590 591macroAttrs :: PandocMonad m => TikiWikiParser m [(Text, Text)] 592macroAttrs = try $ sepEndBy macroAttr spaces 593 594-- ~np~ __not bold__ ~/np~ 595noparse :: PandocMonad m => TikiWikiParser m B.Inlines 596noparse = try $ do 597 string "~np~" 598 body <- manyTill anyChar (string "~/np~") 599 return $ B.str $ T.pack body 600 601str :: PandocMonad m => TikiWikiParser m B.Inlines 602str = fmap B.str (T.pack <$> many1 alphaNum <|> countChar 1 characterReference) 603 604symbol :: PandocMonad m => TikiWikiParser m B.Inlines 605symbol = fmap B.str (countChar 1 nonspaceChar) 606 607-- [[not a link] 608notExternalLink :: PandocMonad m => TikiWikiParser m B.Inlines 609notExternalLink = try $ do 610 start <- string "[[" 611 body <- many (noneOf "\n[]") 612 end <- string "]" 613 return $ B.text $ T.pack $ start ++ body ++ end 614 615-- [http://www.somesite.org url|Some Site title] 616-- ((internal link)) 617-- 618-- The ((...)) wiki links and [...] external links are handled 619-- exactly the same; this abstracts that out 620makeLink :: PandocMonad m => Text -> Text -> Text -> TikiWikiParser m B.Inlines 621makeLink start middle end = try $ do 622 st <- getState 623 guard $ stateAllowLinks st 624 setState $ st{ stateAllowLinks = False } 625 (url, title, anchor) <- wikiLinkText start middle end 626 parsedTitle <- parseFromString (many1 inline) title 627 setState $ st{ stateAllowLinks = True } 628 return $ B.link (url <> anchor) "" $ mconcat parsedTitle 629 630wikiLinkText :: PandocMonad m => Text -> Text -> Text -> TikiWikiParser m (Text, Text, Text) 631wikiLinkText start middle end = do 632 string (T.unpack start) 633 url <- T.pack <$> many1 (noneOf $ T.unpack middle ++ "\n") 634 seg1 <- option url linkContent 635 seg2 <- option "" linkContent 636 string (T.unpack end) 637 if seg2 /= "" 638 then 639 return (url, seg2, seg1) 640 else 641 return (url, seg1, "") 642 where 643 linkContent = do 644 char '|' 645 T.pack <$> many (noneOf $ T.unpack middle) 646 647externalLink :: PandocMonad m => TikiWikiParser m B.Inlines 648externalLink = makeLink "[" "]|" "]" 649 650-- NB: this wiki linking is unlikely to work for anyone besides me 651-- (rlpowell); it happens to work for me because my Hakyll code has 652-- post-processing that treats pandoc .md titles as valid link 653-- targets, so something like 654-- [see also this other post](My Other Page) is perfectly valid. 655wikiLink :: PandocMonad m => TikiWikiParser m B.Inlines 656wikiLink = makeLink "((" ")|" "))" 657