18459b9 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Add reader for Haddock markup based on Haddock's own lexer/parser.

18459b9David Lazar14 years ago

pandoc.cabal+5−1

compare with master

unifiedsplit

@@ -223,6 +223,7 @@ Library

223 Build-Depends: base >= 4.2 && <5,

224 syb >= 0.1 && < 0.5,

225 containers >= 0.1 && < 0.6,

226+ array >= 0.3 && < 0.5,

226 parsec >= 3.1 && < 3.2,

227 parsec >= 3.1 && < 3.2,

227 mtl >= 1.1 && < 2.2,

228 mtl >= 1.1 && < 2.2,

228 network >= 2 && < 2.5,

229 network >= 2 && < 2.5,

@@ -287,6 +288,7 @@ Library

287 Text.Pandoc.Readers.TeXMath,

288 Text.Pandoc.Readers.TeXMath,

288 Text.Pandoc.Readers.Textile,

289 Text.Pandoc.Readers.Textile,

289 Text.Pandoc.Readers.Native,

290 Text.Pandoc.Readers.Native,

291+ Text.Pandoc.Readers.Haddock,

290 Text.Pandoc.Writers.Native,

292 Text.Pandoc.Writers.Native,

291 Text.Pandoc.Writers.Docbook,

293 Text.Pandoc.Writers.Docbook,

292 Text.Pandoc.Writers.OPML,

294 Text.Pandoc.Writers.OPML,

@@ -313,7 +315,9 @@ Library

313 Text.Pandoc.XML,

315 Text.Pandoc.XML,

314 Text.Pandoc.Biblio,

316 Text.Pandoc.Biblio,

315 Text.Pandoc.SelfContained

317 Text.Pandoc.SelfContained

316− Other-Modules: Text.Pandoc.MIME,

318+ Other-Modules: Text.Pandoc.Readers.Haddock.Lex,

319+ Text.Pandoc.MIME,

320+ Text.Pandoc.Readers.Haddock.Parse,

317 Text.Pandoc.Parsing,

321 Text.Pandoc.Parsing,

318 Text.Pandoc.UUID,

322 Text.Pandoc.UUID,

319 Text.Pandoc.ImageSize,

323 Text.Pandoc.ImageSize,

src/Text/Pandoc.hs+3

@@ -73,6 +73,7 @@ module Text.Pandoc

73 , readTextile

74 , readDocBook

75 , readOPML

76+ , readHaddock

76 , readNative

77 , readNative

77 -- * Writers: converting /from/ Pandoc format

78 -- * Writers: converting /from/ Pandoc format

78 , Writer (..)

79 , Writer (..)

@@ -120,6 +121,7 @@ import Text.Pandoc.Readers.LaTeX

120import Text.Pandoc.Readers.HTML

121import Text.Pandoc.Readers.HTML

121import Text.Pandoc.Readers.Textile

122import Text.Pandoc.Readers.Textile

122import Text.Pandoc.Readers.Native

123import Text.Pandoc.Readers.Native

124+import Text.Pandoc.Readers.Haddock

123import Text.Pandoc.Writers.Native

125import Text.Pandoc.Writers.Native

124import Text.Pandoc.Writers.Markdown

126import Text.Pandoc.Writers.Markdown

125import Text.Pandoc.Writers.RST

127import Text.Pandoc.Writers.RST

@@ -200,6 +202,7 @@ readers = [("native" , \_ s -> return $ readNative s)

200 ,("textile" , \o s -> return $ readTextile o s) -- TODO : textile+lhs

202 ,("textile" , \o s -> return $ readTextile o s) -- TODO : textile+lhs

201 ,("html" , \o s -> return $ readHtml o s)

203 ,("html" , \o s -> return $ readHtml o s)

202 ,("latex" , \o s -> return $ readLaTeX o s)

204 ,("latex" , \o s -> return $ readLaTeX o s)

205+ ,("haddock" , \o s -> return $ readHaddock o s)

203 ]

206 ]

204

207

205data Writer = PureStringWriter (WriterOptions -> Pandoc -> String)

208data Writer = PureStringWriter (WriterOptions -> Pandoc -> String)

src/Text/Pandoc/Readers/Haddock.hsnew file+39

@@ -0,0 +1,39 @@

1+{- |

2+ Module : Text.Pandoc.Readers.Haddock

4+ License : GNU GPL, version 2 or above

6+ Maintainer : David Lazar <lazar6@illinois.edu>

7+ Stability : alpha

9+Conversion of Haddock markup to 'Pandoc' document.

10+-}

11+module Text.Pandoc.Readers.Haddock

12+ ( readHaddock

13+ ) where

14+

15+import Text.Pandoc.Builder

16+import Text.Pandoc.Options

17+import Text.Pandoc.Readers.Haddock.Lex

18+import Text.Pandoc.Readers.Haddock.Parse

19+

20+-- | Parse Haddock markup and return a 'Pandoc' document.

21+readHaddock :: ReaderOptions -- ^ Reader options

22+ -> String -- ^ String to parse

23+ -> Pandoc

24+readHaddock _ s = Pandoc (Meta [] [] []) blocks

25+ where

26+ blocks = case parseParas (tokenise s (0,0)) of

27+ Nothing -> []

28+ Just x -> mergeLists (toList x)

29+

30+-- similar to 'docAppend' in Haddock.Doc

31+mergeLists :: [Block] -> [Block]

32+mergeLists (BulletList xs : BulletList ys : blocks)

33+ = mergeLists (BulletList (xs ++ ys) : blocks)

34+mergeLists (OrderedList _ xs : OrderedList a ys : blocks)

35+ = mergeLists (OrderedList a (xs ++ ys) : blocks)

36+mergeLists (DefinitionList xs : DefinitionList ys : blocks)

37+ = mergeLists (DefinitionList (xs ++ ys) : blocks)

38+mergeLists (x : blocks) = x : mergeLists blocks

39+mergeLists [] = []

src/Text/Pandoc/Readers/Haddock/Lex.xnew file+169

@@ -0,0 +1,169 @@

1+--

2+-- Haddock - A Haskell Documentation Tool

3+--

4+-- (c) Simon Marlow 2002

5+--

6+-- This file was modified and integrated into GHC by David Waern 2006.

7+-- Then moved back into Haddock by Isaac Dupree in 2009 :-)

8+-- Then copied into Pandoc by David Lazar in 2013 :-D

10+{

11+{-# LANGUAGE BangPatterns #-} -- Generated by Alex

12+{-# OPTIONS -Wwarn -w #-}

13+-- The above warning supression flag is a temporary kludge.

14+-- While working on this module you are encouraged to remove it and fix

15+-- any warnings in the module. See

16+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings

17+-- for details

18+

19+module Text.Pandoc.Readers.Haddock.Lex (

20+ Token(..),

21+ LToken,

22+ tokenise

23+ ) where

24+

25+import Data.Char

26+import Numeric (readHex)

27+}

28+

29+%wrapper "posn"

30+

31+$ws = $white # \n

32+$digit = [0-9]

33+$hexdigit = [0-9a-fA-F]

34+$special = [\"\@]

35+$alphanum = [A-Za-z0-9]

36+$ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:]

37+

38+:-

39+

40+-- beginning of a paragraph

41+<0,para> {

42+ $ws* \n ;

43+ $ws* \> { begin birdtrack }

44+ $ws* prop \> .* \n { strtoken TokProperty `andBegin` property}

45+ $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr }

46+ $ws* [\*\-] { token TokBullet `andBegin` string }

47+ $ws* \[ { token TokDefStart `andBegin` def }

48+ $ws* $ $digit+ $ { token TokNumber `andBegin` string }

49+ $ws* $digit+ \. { token TokNumber `andBegin` string }

50+ $ws* { begin string }

51+}

52+

53+-- beginning of a line

54+<line> {

55+ $ws* \> { begin birdtrack }

56+ $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr }

57+ $ws* \n { token TokPara `andBegin` para }

58+

59+ -- Here, we really want to be able to say

60+ -- $ws* (\n | <eof>) { token TokPara `andBegin` para}

61+ -- because otherwise a trailing line of whitespace will result in

62+ -- a spurious TokString at the end of a docstring. We don't have <eof>,

63+ -- though (NOW I realise what it was for :-). To get around this, we always

64+ -- append \n to the end of a docstring.

65+ () { begin string }

66+}

67+

68+<birdtrack> .* \n? { strtokenNL TokBirdTrack `andBegin` line }

69+

70+<property> () { token TokPara `andBegin` para }

71+

72+<example> {

73+ $ws* \n { token TokPara `andBegin` para }

74+ $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr }

75+ () { begin exampleresult }

76+}

77+

78+<exampleexpr> .* \n { strtokenNL TokExampleExpression `andBegin` example }

79+

80+<exampleresult> .* \n { strtokenNL TokExampleResult `andBegin` example }

81+

82+<string,def> {

83+ $special { strtoken $ \s -> TokSpecial (head s) }

84+ \<\< [^\>]* \>\> { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) }

85+ \< [^\>]* \> { strtoken $ \s -> TokURL (init (tail s)) }

86+ \# [^\#]* \# { strtoken $ \s -> TokAName (init (tail s)) }

87+ \/ [^\/]* \/ { strtoken $ \s -> TokEmphasis (init (tail s)) }

88+ [\'\`] $ident+ [\'\`] { strtoken $ \s -> TokIdent (init (tail s)) }

89+ \\ . { strtoken (TokString . tail) }

90+ "&#" $digit+ \; { strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] }

91+ "&#" [xX] $hexdigit+ \;

92+ { strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] }

93+ -- allow special characters through if they don't fit one of the previous

94+ -- patterns.

95+ [\/\'\`\<\#\&\\] { strtoken TokString }

96+ [^ $special \/ \< \# \n \'\` \& \\ \]]* \n { strtokenNL TokString `andBegin` line }

97+ [^ $special \/ \< \# \n \'\` \& \\ \]]+ { strtoken TokString }

98+}

99+

100+<def> {

101+ \] { token TokDefEnd `andBegin` string }

102+}

103+

104+-- ']' doesn't have any special meaning outside of the [...] at the beginning

105+-- of a definition paragraph.

106+<string> {

107+ \] { strtoken TokString }

108+}

109+

110+{

111+-- | A located token

112+type LToken = (Token, AlexPosn)

113+

114+data Token

115+ = TokPara

116+ | TokNumber

117+ | TokBullet

118+ | TokDefStart

119+ | TokDefEnd

120+ | TokSpecial Char

121+ | TokIdent String

122+ | TokString String

123+ | TokURL String

124+ | TokPic String

125+ | TokEmphasis String

126+ | TokAName String

127+ | TokBirdTrack String

128+ | TokProperty String

129+ | TokExamplePrompt String

130+ | TokExampleExpression String

131+ | TokExampleResult String

132+-- deriving Show

133+

134+tokenPos :: LToken -> (Int, Int)

135+tokenPos t = let AlexPn _ line col = snd t in (line, col)

136+

137+type StartCode = Int

138+type Action = AlexPosn -> String -> StartCode -> (StartCode -> [LToken]) -> [LToken]

139+

140+tokenise :: String -> (Int, Int) -> [LToken]

141+tokenise str (line, col) = go (posn,'\n',[],eofHack str) para

142+ where posn = AlexPn 0 line col

143+ go inp@(pos,_,_,str) sc =

144+ case alexScan inp sc of

145+ AlexEOF -> []

146+ AlexError _ -> []

147+ AlexSkip inp' len -> go inp' sc

148+ AlexToken inp' len act -> act pos (take len str) sc (\sc -> go inp' sc)

149+

150+-- NB. we add a final \n to the string, (see comment in the beginning of line

151+-- production above).

152+eofHack str = str++"\n"

153+

154+andBegin :: Action -> StartCode -> Action

155+andBegin act new_sc = \pos str _ cont -> act pos str new_sc cont

156+

157+token :: Token -> Action

158+token t = \pos _ sc cont -> (t, pos) : cont sc

159+

160+strtoken, strtokenNL :: (String -> Token) -> Action

161+strtoken t = \pos str sc cont -> (t str, pos) : cont sc

162+strtokenNL t = \pos str sc cont -> (t (filter (/= '\r') str), pos) : cont sc

163+-- ^ We only want LF line endings in our internal doc string format, so we

164+-- filter out all CRs.

165+

166+begin :: StartCode -> Action

167+begin sc = \_ _ _ cont -> cont sc

168+

169+}

src/Text/Pandoc/Readers/Haddock/Parse.ynew file+179

@@ -0,0 +1,179 @@

1+-- This code was copied from the 'haddock' package, modified, and integrated

2+-- into Pandoc by David Lazar.

3+{

4+{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6

5+{-# OPTIONS -Wwarn -w #-}

6+-- The above warning supression flag is a temporary kludge.

7+-- While working on this module you are encouraged to remove it and fix

8+-- any warnings in the module. See

9+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings

10+-- for details

11+

12+module Text.Pandoc.Readers.Haddock.Parse (parseString, parseParas) where

13+

14+import Text.Pandoc.Readers.Haddock.Lex

15+import Text.Pandoc.Builder

16+import Data.Generics (everywhere, mkT)

17+import Data.Char (isSpace)

18+import Data.Maybe (fromMaybe)

19+import Data.List (stripPrefix)

20+import Data.Monoid (mempty)

21+}

22+

23+%expect 0

24+

25+%tokentype { LToken }

26+

27+%token

28+ '/' { (TokSpecial '/',_) }

29+ '@' { (TokSpecial '@',_) }

30+ '[' { (TokDefStart,_) }

31+ ']' { (TokDefEnd,_) }

32+ DQUO { (TokSpecial '\"',_) }

33+ URL { (TokURL $$,_) }

34+ PIC { (TokPic $$,_) }

35+ ANAME { (TokAName $$,_) }

36+ '/../' { (TokEmphasis $$,_) }

37+ '-' { (TokBullet,_) }

38+ '(n)' { (TokNumber,_) }

39+ '>..' { (TokBirdTrack $$,_) }

40+ PROP { (TokProperty $$,_) }

41+ PROMPT { (TokExamplePrompt $$,_) }

42+ RESULT { (TokExampleResult $$,_) }

43+ EXP { (TokExampleExpression $$,_) }

44+ IDENT { (TokIdent $$,_) }

45+ PARA { (TokPara,_) }

46+ STRING { (TokString $$,_) }

47+

48+%monad { Maybe }

49+

50+%name parseParas doc

51+%name parseString seq

52+

53+%%

54+

55+doc :: { Blocks }

56+ : apara PARA doc { $1 <> $3 }

57+ | PARA doc { $2 }

58+ | apara { $1 }

59+ | {- empty -} { mempty }

60+

61+apara :: { Blocks }

62+ : ulpara { bulletList [$1] }

63+ | olpara { orderedList [$1] }

64+ | defpara { definitionList [$1] }

65+ | para { $1 }

66+

67+ulpara :: { Blocks }

68+ : '-' para { $2 }

69+

70+olpara :: { Blocks }

71+ : '(n)' para { $2 }

72+

73+defpara :: { (Inlines, [Blocks]) }

74+ : '[' seq ']' seq { ($2, [plain $4]) }

75+

76+para :: { Blocks }

77+ : seq { para $1 }

78+ | codepara { codeBlock $1 }

79+ | property { $1 }

80+ | examples { $1 }

81+

82+codepara :: { String }

83+ : '>..' codepara { $1 ++ $2 }

84+ | '>..' { $1 }

85+

86+property :: { Blocks }

87+ : PROP { makeProperty $1 }

88+

89+examples :: { Blocks }

90+ : example examples { $1 <> $2 }

91+ | example { $1 }

92+

93+example :: { Blocks }

94+ : PROMPT EXP result { makeExample $1 $2 (lines $3) }

95+ | PROMPT EXP { makeExample $1 $2 [] }

96+

97+result :: { String }

98+ : RESULT result { $1 ++ $2 }

99+ | RESULT { $1 }

100+

101+seq :: { Inlines }

102+ : elem seq { $1 <> $2 }

103+ | elem { $1 }

104+

105+elem :: { Inlines }

106+ : elem1 { $1 }

107+ | '@' seq1 '@' { monospace $2 }

108+

109+seq1 :: { Inlines }

110+ : PARA seq1 { linebreak <> $2 }

111+ | elem1 seq1 { $1 <> $2 }

112+ | elem1 { $1 }

113+

114+elem1 :: { Inlines }

115+ : STRING { str $1 }

116+ | '/../' { emph (str $1) }

117+ | URL { makeHyperlink $1 }

118+ | PIC { image $1 $1 mempty }

119+ | ANAME { mempty } -- TODO

120+ | IDENT { code $1 }

121+ | DQUO strings DQUO { code $2 }

122+

123+strings :: { String }

124+ : STRING { $1 }

125+ | STRING strings { $1 ++ $2 }

126+

127+{

128+happyError :: [LToken] -> Maybe a

129+happyError toks = Nothing

130+

131+monospace :: Inlines -> Inlines

132+monospace = everywhere (mkT go)

133+ where

134+ go (Str s) = Code nullAttr s

135+ go Space = Code nullAttr " "

136+ go x = x

137+

138+-- | Create a `Hyperlink` from given string.

139+--

140+-- A hyperlink consists of a URL and an optional label. The label is separated

141+-- from the url by one or more whitespace characters.

142+makeHyperlink :: String -> Inlines

143+makeHyperlink input = case break isSpace $ strip input of

144+ (url, "") -> link url url (str url)

145+ (url, lb) -> link url url (str label)

146+ where label = dropWhile isSpace lb

147+

148+makeProperty :: String -> Blocks

149+makeProperty s = case strip s of

150+ 'p':'r':'o':'p':'>':xs ->

151+ codeBlockWith ([], ["property"], []) (dropWhile isSpace xs)

152+ xs ->

153+ error $ "makeProperty: invalid input " ++ show xs

154+

155+-- | Create an 'Example', stripping superfluous characters as appropriate

156+makeExample :: String -> String -> [String] -> Blocks

157+makeExample prompt expression result =

158+ para $ codeWith ([], ["expr"], []) (strip expression ++ "\n")

159+ <> codeWith ([], ["result"], []) (unlines result')

160+ where

161+ -- 1. drop trailing whitespace from the prompt, remember the prefix

162+ (prefix, _) = span isSpace prompt

163+

164+ -- 2. drop, if possible, the exact same sequence of whitespace

165+ -- characters from each result line

166+ --

167+ -- 3. interpret lines that only contain the string "<BLANKLINE>" as an

168+ -- empty line

169+ result' = map (substituteBlankLine . tryStripPrefix prefix) result

170+ where

171+ tryStripPrefix xs ys = fromMaybe ys $ stripPrefix xs ys

172+

173+ substituteBlankLine "<BLANKLINE>" = ""

174+ substituteBlankLine line = line

175+

176+-- | Remove all leading and trailing whitespace

177+strip :: String -> String

178+strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse

179+}