@@ -0,0 +1,507 @@
1+{-# LANGUAGE ViewPatterns #-}
2+
3+module Text.Pandoc.Readers.Txt2Tags ( readTxt2Tags
4+ , getT2TMeta
5+ , T2TMeta (..)
6+ , readTxt2TagsNoMacros)
7+ where
8+
9+import qualified Text.Pandoc.Builder as B
10+import Text.Pandoc.Builder ( Inlines, Blocks, (<>)
11+ , trimInlines )
12+import Text.Pandoc.Definition
13+import Text.Pandoc.Options
14+import Text.Pandoc.Shared (escapeURI,compactify', compactify'DL)
15+import Text.Pandoc.Parsing hiding (space, spaces, uri)
16+import Control.Applicative ((<$>), (<$), (<*>), (<*), (*>))
17+import Data.Char (toLower)
18+import Data.List (transpose, intersperse, intercalate)
19+import Data.Maybe (fromMaybe)
20+import Data.Monoid (Monoid, mconcat, mempty, mappend)
21+--import Network.URI (isURI) -- Not sure whether to use this function
22+import Control.Monad (void, guard, when)
23+import Data.Default
24+import Control.Monad.Reader (Reader, runReader, asks)
25+
26+type T2T = Parser String ParserState
27+
28+
29+type T2T = ParserT String ParserState (Reader T2TMeta)
30+
31+
32+-- | An object for the T2T macros meta information
33+-- the contents of each field is simply substituted verbatim into the file
34+data T2TMeta = T2TMeta {
35+ date :: String -- ^ Current date
36+ , mtime :: String -- ^ Last modification time of infile
37+ , infile :: FilePath -- ^ Input file
38+ , outfile :: FilePath -- ^ Output file
39+ } deriving Show
40+
41+instance Default T2TMeta where
42+ def = T2TMeta "" "" "" ""
43+
44+-- | Get the meta information required by Txt2Tags macros
45+getT2TMeta :: FilePath -> FilePath -> IO T2TMeta
46+getT2TMeta inp out = do
47+ curDate <- formatTime defaultTimeLocale "%F" <$> getZonedTime
48+ let getModTime = formatTime defaultTimeLocale "%F"
49+ <$> getModificationTime inp
50+ curMtime <- catchIOError getModTime (const (return ""))
51+
52+ return $ T2TMeta curDate curMtime inp out
53+
54+-- | Read Txt2Tags from an input string returning a Pandoc document
55+readTxt2Tags :: T2TMeta -> ReaderOptions -> String -> Pandoc
56+readTxt2Tags t opts s = flip runReader t $ readWithM parseT2T (def {stateOptions = opts}) (s ++ "\n\n")
57+
58+-- | Read Txt2Tags (ignoring all macros) from an input string returning
59+-- a Pandoc document
60+readTxt2TagsNoMacros :: ReaderOptions -> String -> Pandoc
61+readTxt2TagsNoMacros = readTxt2Tags def
62+
63+parseT2T :: T2T Pandoc
64+parseT2T = do
65+ _ <- (Nothing <$ try blankline) <|> (Just <$> (count 3 anyLine))
66+ config <- manyTill setting (notFollowedBy setting)
67+ -- TODO: Handle settings better
68+ let settings = foldr (\(k,v) -> B.setMeta k (MetaString v)) nullMeta config
69+ updateState (\s -> s {stateMeta = settings})
70+ body <- mconcat <$> manyTill block eof
71+ return $ Pandoc mempty (B.toList body)
72+
73+type Keyword = String
74+type Value = String
75+
76+setting :: T2T (Keyword, Value)
77+setting = do
78+ string "%!"
79+ keyword <- ignoreSpacesCap (many1 alphaNum)
80+ char ':'
81+ value <- ignoreSpacesCap (manyTill anyChar (newline))
82+ return (keyword, value)
83+
84+-- Blocks
85+
86+parseBlocks :: T2T Blocks
87+parseBlocks = mconcat <$> manyTill block eof
88+
89+block :: T2T Blocks
90+block = do
91+ choice
92+ [ mempty <$ blanklines
93+ , quote
94+ , hrule -- hrule must go above title
95+ , title
96+ , commentBlock
97+ , verbatim
98+ , rawBlock
99+ , taggedBlock
100+ , list
101+ , table
102+ , para
103+ ]
104+
105+title :: T2T Blocks
106+title = try $ balancedTitle '+' <|> balancedTitle '='
107+
108+balancedTitle :: Char -> T2T Blocks
109+balancedTitle c = try $ do
110+ spaces
111+ level <- length <$> many1 (char c)
112+ guard (level <= 5) -- Max header level 5
113+ heading <- manyTill (noneOf "\n\r") (count level (char c))
114+ label <- optionMaybe (enclosed (char '[') (char ']') (alphaNum <|> oneOf "_-"))
115+ many spaceChar *> newline
116+ let attr = maybe nullAttr (\x -> (x, [], [])) label
117+ return $ B.headerWith attr level (trimInlines $ B.text heading)
118+
119+para :: T2T Blocks
120+para = try $ do
121+ ils <- parseInlines
122+ nl <- option False (True <$ newline)
123+ option (B.plain ils) (guard nl >> notFollowedBy listStart >> return (B.para ils))
124+ where
125+ listStart = try bulletListStart <|> orderedListStart
126+
127+commentBlock :: T2T Blocks
128+commentBlock = try (blockMarkupArea (anyLine) (const mempty) "%%%") <|> comment
129+
130+-- Seperator and Strong line treated the same
131+hrule :: T2T Blocks
132+hrule = try $ do
133+ spaces
134+ line <- many1 (oneOf "=-_")
135+ guard (length line >= 20)
136+ B.horizontalRule <$ blankline
137+
138+quote :: T2T Blocks
139+quote = try $ do
140+ lookAhead tab
141+ rawQuote <- many1 (tab *> optional spaces *> anyLine)
142+ contents <- parseFromString parseBlocks (intercalate "\n" rawQuote ++ "\n\n")
143+ return $ B.blockQuote contents
144+
145+commentLine :: T2T Inlines
146+commentLine = comment
147+
148+-- List Parsing code from Org Reader
149+
150+list :: T2T Blocks
151+list = choice [bulletList, orderedList, definitionList]
152+
153+bulletList :: T2T Blocks
154+bulletList = B.bulletList . compactify'
155+ <$> many1 (listItem bulletListStart parseBlocks)
156+
157+orderedList :: T2T Blocks
158+orderedList = B.orderedList . compactify'
159+ <$> many1 (listItem orderedListStart parseBlocks)
160+
161+definitionList :: T2T Blocks
162+definitionList = try $ do
163+ B.definitionList . compactify'DL <$>
164+ many1 (listItem definitionListStart definitionListEnd)
165+
166+definitionListEnd :: T2T (Inlines, [Blocks])
167+definitionListEnd = (,) <$> (mconcat <$> manyTill inline newline) <*> ((:[]) <$> parseBlocks)
168+
169+genericListStart :: T2T Char
170+ -> T2T Int
171+genericListStart listMarker = try $
172+ (2+) <$> (length <$> many spaceChar
173+ <* listMarker <* space <* notFollowedBy space)
174+
175+-- parses bullet list \start and returns its length (excl. following whitespace)
176+bulletListStart :: T2T Int
177+bulletListStart = genericListStart (char '-')
178+
179+orderedListStart :: T2T Int
180+orderedListStart = genericListStart (char '+' )
181+
182+definitionListStart :: T2T Int
183+definitionListStart = genericListStart (char ':')
184+
185+-- parse raw text for one list item, excluding start marker and continuations
186+listItem :: T2T Int
187+ -> T2T a
188+ -> T2T a
189+listItem start end = try $ do
190+ markerLength <- try start
191+ firstLine <- anyLineNewline
192+ blank <- option "" ("\n" <$ blankline)
193+ rest <- concat <$> many (listContinuation markerLength)
194+ parseFromString end $ firstLine ++ blank ++ rest
195+
196+-- continuation of a list item - indented and separated by blankline or endline.
197+-- Note: nested lists are parsed as continuations.
198+listContinuation :: Int
199+ -> T2T String
200+listContinuation markerLength = try $
201+ notFollowedBy' (blankline >> blankline)
202+ *> (mappend <$> (concat <$> many1 listLine)
203+ <*> many blankline)
204+ where listLine = try $ indentWith markerLength *> anyLineNewline
205+
206+anyLineNewline :: T2T String
207+anyLineNewline = (++ "\n") <$> anyLine
208+
209+indentWith :: Int -> T2T String
210+indentWith n = count n space
211+
212+-- Table
213+
214+table :: T2T Blocks
215+table = try $ do
216+ header <- fmap snd <$> option mempty (try headerRow)
217+ rows <- many1 (many commentLine *> tableRow)
218+ let columns = transpose rows
219+ let ncolumns = length columns
220+ let aligns = map (foldr1 findAlign) (map (map fst) columns)
221+ let rows' = map (map snd) rows
222+ let size = maximum (map length rows')
223+ let rowsPadded = map (pad size) rows'
224+ let headerPadded = if (not (null header)) then pad size header else mempty
225+ return $ B.table mempty
226+ (zip aligns (replicate ncolumns 0.0))
227+ headerPadded rowsPadded
228+
229+pad :: (Show a, Monoid a) => Int -> [a] -> [a]
230+pad n xs = xs ++ (replicate (n - length xs) mempty)
231+
232+
233+findAlign :: Alignment -> Alignment -> Alignment
234+findAlign x y
235+ | x == y = x
236+ | otherwise = AlignDefault
237+
238+headerRow :: T2T [(Alignment, Blocks)]
239+headerRow = genericRow (string "||")
240+
241+tableRow :: T2T [(Alignment, Blocks)]
242+tableRow = genericRow (char '|')
243+
244+genericRow :: T2T a -> T2T [(Alignment, Blocks)]
245+genericRow start = try $ do
246+ spaces *> start
247+ manyTill tableCell newline <?> "genericRow"
248+
249+
250+tableCell :: T2T (Alignment, Blocks)
251+tableCell = try $ do
252+ leftSpaces <- length <$> lookAhead (many1 space) -- Case of empty cell means we must lookAhead
253+ content <- (manyTill inline (try $ lookAhead (cellEnd)))
254+ rightSpaces <- length <$> many space
255+ let align =
256+ case compare leftSpaces rightSpaces of
257+ LT -> AlignLeft
258+ EQ -> AlignCenter
259+ GT -> AlignRight
260+ endOfCell
261+ return $ (align, B.plain (B.trimInlines $ mconcat content))
262+ where
263+ cellEnd = (void newline <|> (many1 space *> endOfCell))
264+
265+endOfCell :: T2T ()
266+endOfCell = try (skipMany1 $ char '|') <|> ( () <$ lookAhead newline)
267+
268+-- Raw area
269+
270+verbatim :: T2T Blocks
271+verbatim = genericBlock anyLineNewline B.codeBlock "```"
272+
273+rawBlock :: T2T Blocks
274+rawBlock = genericBlock anyLineNewline (B.para . B.str) "\"\"\""
275+
276+taggedBlock :: T2T Blocks
277+taggedBlock = do
278+ target <- getTarget
279+ genericBlock anyLineNewline (B.rawBlock target) "'''"
280+
281+-- Generic
282+
283+genericBlock :: Monoid a => T2T a -> (a -> Blocks) -> String -> T2T Blocks
284+genericBlock p f s = blockMarkupArea p f s <|> blockMarkupLine p f s
285+
286+blockMarkupArea :: Monoid a => (T2T a) -> (a -> Blocks) -> String -> T2T Blocks
287+blockMarkupArea p f s = try $ (do
288+ string s *> blankline
289+ f . mconcat <$> (manyTill p (eof <|> void (string s *> blankline))))
290+
291+blockMarkupLine :: T2T a -> (a -> Blocks) -> String -> T2T Blocks
292+blockMarkupLine p f s = try (f <$> (string s *> space *> p))
293+
294+-- Can be in either block or inline position
295+comment :: Monoid a => T2T a
296+comment = try $ do
297+ atStart
298+ mempty <$ (char '%' *> anyLine)
299+
300+-- Inline
301+
302+parseInlines :: T2T Inlines
303+parseInlines = trimInlines . mconcat <$> many1 inline
304+
305+inline :: T2T Inlines
306+inline = do
307+ choice
308+ [ endline
309+ , commentLine
310+ , whitespace
311+ , url
312+ , link
313+ , image
314+ , bold
315+ , underline
316+ , code
317+ , raw
318+ , tagged
319+ , strike
320+ , italic
321+ , code
322+ , str
323+ , symbol
324+ ]
325+
326+bold :: T2T Inlines
327+bold = inlineMarkup inline B.strong '*' (B.str)
328+
329+underline :: T2T Inlines
330+underline = inlineMarkup inline B.emph '_' (B.str)
331+
332+strike :: T2T Inlines
333+strike = inlineMarkup inline B.strikeout '-' (B.str)
334+
335+italic :: T2T Inlines
336+italic = inlineMarkup inline B.emph '/' (B.str)
337+
338+code :: T2T Inlines
339+code = inlineMarkup ((:[]) <$> anyChar) B.code '`' id
340+
341+raw :: T2T Inlines
342+raw = inlineMarkup ((:[]) <$> anyChar) B.text '"' id
343+
344+tagged :: T2T Inlines
345+tagged = do
346+ target <- getTarget
347+ inlineMarkup ((:[]) <$> anyChar) (B.rawInline target) '\'' id
348+
349+-- Parser for markup indicated by a double character.
350+-- Inline markup is greedy and glued
351+-- Greedy meaning ***a*** = Bold [Str "*a*"]
352+-- Glued meaning that markup must be tight to content
353+-- Markup can't pass newlines
354+inlineMarkup :: Monoid a
355+ => (T2T a) -- Content parser
356+ -> (a -> Inlines) -- Constructor
357+ -> Char -- Fence
358+ -> (String -> a) -- Special Case to handle ******
359+ -> T2T Inlines
360+inlineMarkup p f c special = try $ do
361+ start <- many1 (char c)
362+ let l = length start
363+ guard (l >= 2)
364+ when (l == 2) (void $ notFollowedBy space)
365+ -- We must make sure that there is no space before the start of the
366+ -- closing tags
367+ body <- optionMaybe (try $ manyTill (noneOf "\n\r") $
368+ (try $ lookAhead (noneOf " " >> string [c,c] )))
369+ case body of
370+ Just middle -> do
371+ lastChar <- anyChar
372+ end <- many1 (char c)
373+ let parser inp = parseFromString (mconcat <$> many p) inp
374+ let start' = special (drop 2 start)
375+ body' <- parser (middle ++ [lastChar])
376+ let end' = special (drop 2 end)
377+ return $ f (start' <> body' <> end')
378+ Nothing -> do -- Either bad or case such as *****
379+ guard (l >= 5)
380+ let body' = (replicate (l - 4) c)
381+ return $ f (special body')
382+
383+link :: T2T Inlines
384+link = try imageLink <|> titleLink
385+
386+-- Link with title
387+titleLink :: T2T Inlines
388+titleLink = try $ do
389+ char '['
390+ notFollowedBy space
391+ tokens <- sepBy1 (many $ noneOf " ]") space
392+ guard (length tokens >= 2)
393+ char ']'
394+ let link' = last tokens
395+ guard (length link' > 0)
396+ let tit = concat (intersperse " " (init tokens))
397+ return $ B.link link' "" (B.text tit)
398+
399+-- Link with image
400+imageLink :: T2T Inlines
401+imageLink = try $ do
402+ char '['
403+ body <- image
404+ many1 space
405+ l <- manyTill (noneOf "\n\r ") (char ']')
406+ return (B.link l "" body)
407+
408+-- raw URLs in text are automatically linked
409+url :: T2T Inlines
410+url = try $ do
411+ (rawUrl, escapedUrl) <- (try uri <|> emailAddress)
412+ return $ B.link rawUrl "" (B.str escapedUrl)
413+
414+uri :: T2T (String, String)
415+uri = try $ do
416+ address <- t2tURI
417+ return (address, escapeURI address)
418+
419+-- The definition of a URI in the T2T source differs from the
420+-- actual definition. This is a transcription of the definition in
421+-- the source of v2.6
422+--isT2TURI :: String -> Bool
423+--isT2TURI (parse t2tURI "" -> Right _) = True
424+--isT2TURI _ = False
425+
426+t2tURI :: T2T String
427+t2tURI = do
428+ start <- try ((++) <$> proto <*> urlLogin) <|> guess
429+ domain <- many1 chars
430+ sep <- many (char '/')
431+ form' <- option mempty ((:) <$> char '?' <*> many1 form)
432+ anchor' <- option mempty ((:) <$> char '#' <*> many anchor)
433+ return (start ++ domain ++ sep ++ form' ++ anchor')
434+ where
435+ protos = ["http", "https", "ftp", "telnet", "gopher", "wais"]
436+ proto = (++) <$> oneOfStrings protos <*> string "://"
437+ guess = (++) <$> (((++) <$> stringAnyCase "www" <*> option mempty ((:[]) <$> oneOf "23"))
438+ <|> stringAnyCase "ftp") <*> ((:[]) <$> char '.')
439+ login = alphaNum <|> oneOf "_.-"
440+ pass = many (noneOf " @")
441+ chars = alphaNum <|> oneOf "%._/~:,=$@&+-"
442+ anchor = alphaNum <|> oneOf "%._0"
443+ form = chars <|> oneOf ";*"
444+ urlLogin = option mempty $ try ((\x y z -> x ++ y ++ [z]) <$> many1 login <*> option mempty ((:) <$> char ':' <*> pass) <*> char '@')
445+
446+
447+image :: T2T Inlines
448+image = try $ do
449+ -- List taken from txt2tags source
450+ let extensions = [".jpg", ".jpeg", ".gif", ".png", ".eps", ".bmp"]
451+ char '['
452+ path <- manyTill (noneOf "\n\t\r ") (try $ lookAhead (oneOfStrings extensions))
453+ ext <- oneOfStrings extensions
454+ char ']'
455+ return $ B.image (path ++ ext) "" mempty
456+
457+-- Characters used in markup
458+specialChars :: String
459+specialChars = "%*-_/|:+"
460+
461+tab :: T2T Char
462+tab = char '\t'
463+
464+space :: T2T Char
465+space = char ' '
466+
467+spaces :: T2T String
468+spaces = many space
469+
470+endline :: T2T Inlines
471+endline = try $ do
472+ newline
473+ notFollowedBy blankline
474+ notFollowedBy hrule
475+ notFollowedBy title
476+ notFollowedBy verbatim
477+ notFollowedBy rawBlock
478+ notFollowedBy taggedBlock
479+ notFollowedBy quote
480+ notFollowedBy list
481+ notFollowedBy table
482+ return $ B.space
483+
484+str :: T2T Inlines
485+str = try $ do
486+ B.str <$> many1 (noneOf $ specialChars ++ "\n\r ")
487+
488+whitespace :: T2T Inlines
489+whitespace = try $ B.space <$ spaceChar
490+
491+symbol :: T2T Inlines
492+symbol = B.str . (:[]) <$> oneOf specialChars
493+
494+-- Utility
495+
496+getTarget :: T2T String
497+getTarget = do
498+ mv <- lookupMeta "target" . stateMeta <$> getState
499+ let MetaString target = fromMaybe (MetaString "html") mv
500+ return target
501+
502+atStart :: T2T ()
503+atStart = (sourceColumn <$> getPosition) >>= guard . (== 1)
504+
505+ignoreSpacesCap :: T2T String -> T2T String
506+ignoreSpacesCap p = map toLower <$> (spaces *> p <* spaces)
507+