@@ -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+}