@@ -0,0 +1,306 @@
1+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ViewPatterns#-}
2+{-
3+Copyright (C) 2016 Mathieu Duponchelle <mathieu.duponchelle@opencreed.com>
4+
5+This program is free software; you can redistribute it and/or modify
6+it under the terms of the GNU General Public License as published by
7+the Free Software Foundation; either version 2 of the License, or
8+(at your option) any later version.
9+
10+This program is distributed in the hope that it will be useful,
11+but WITHOUT ANY WARRANTY; without even the implied warranty of
12+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13+GNU General Public License for more details.
14+
15+You should have received a copy of the GNU General Public License
16+along with this program; if not, write to the Free Software
17+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18+-}
19+
20+{- |
21+ Module : Text.Pandoc.Readers.Mallard
22+ Copyright : Copyright (C) 2016 John MacFarlane
23+ License : GNU GPL, version 2 or above
24+
25+ Maintainer : John MacFarlane <jgm@berkeley.edu>
26+ Stability : alpha
27+ Portability : portable
28+
29+Conversion of 'Mallard' to 'Pandoc' document.
30+
31+http://projectmallard.org/
32+-}
33+
34+module Text.Pandoc.Readers.Mallard ( readMallard ) where
35+
36+import Debug.Trace
37+import Data.Char (toUpper)
38+import Text.Pandoc.Options
39+import Text.Pandoc.Definition
40+import Text.Pandoc.Builder
41+import Text.XML.Light
42+import Text.Pandoc.Compat.TagSoupEntity (lookupEntity)
43+import Data.Generics
44+import Data.Char (isSpace)
45+import Control.Monad.State
46+import Text.Pandoc.Error (PandocError)
47+import Text.Pandoc.Compat.Except
48+import Data.Default
49+
50+type DB = ExceptT PandocError (State DBState)
51+
52+data DBState = DBState{ dbSectionLevel :: Int
53+ , dbMeta :: Meta
54+ , dbAcceptsMeta :: Bool
55+ , dbPage :: Bool
56+ , dbContent :: [Content]
57+ } deriving Show
58+
59+instance Default DBState where
60+ def = DBState{ dbSectionLevel = 0
61+ , dbMeta = mempty
62+ , dbAcceptsMeta = False
63+ , dbPage = False
64+ , dbContent = [] }
65+
66+
67+readMallard :: ReaderOptions -> String -> Either PandocError Pandoc
68+readMallard _ inp = (\blocks -> Pandoc (dbMeta st') (toList . mconcat $ blocks)) <$> bs
69+ where (bs , st') = flip runState (def{ dbContent = tree }) . runExceptT . mapM parseBlock $ tree
70+ tree = normalizeTree . parseXML $ inp
71+
72+-- normalize input, consolidating adjacent Text and CRef elements
73+normalizeTree :: [Content] -> [Content]
74+normalizeTree = everywhere (mkT go)
75+ where go :: [Content] -> [Content]
76+ go (Text (CData CDataRaw _ _):xs) = xs
77+ go (Text (CData CDataText s1 z):Text (CData CDataText s2 _):xs) =
78+ Text (CData CDataText (s1 ++ s2) z):xs
79+ go (Text (CData CDataText s1 z):CRef r:xs) =
80+ Text (CData CDataText (s1 ++ convertEntity r) z):xs
81+ go (CRef r:Text (CData CDataText s1 z):xs) =
82+ Text (CData CDataText (convertEntity r ++ s1) z):xs
83+ go (CRef r1:CRef r2:xs) =
84+ Text (CData CDataText (convertEntity r1 ++ convertEntity r2) Nothing):xs
85+ go xs = xs
86+
87+convertEntity :: String -> String
88+convertEntity e = maybe (map toUpper e) (:[]) (lookupEntity e)
89+
90+acceptingMetadata :: DB a -> DB a
91+acceptingMetadata p = do
92+ modify (\s -> s { dbAcceptsMeta = True } )
93+ res <- p
94+ modify (\s -> s { dbAcceptsMeta = False })
95+ return res
96+
97+checkInMeta :: Monoid a => DB () -> DB a
98+checkInMeta p = do
99+ accepts <- dbAcceptsMeta <$> get
100+ when accepts p
101+ return mempty
102+
103+addMeta :: ToMetaValue a => String -> a -> DB ()
104+addMeta field val = modify (setMeta field val)
105+
106+instance HasMeta DBState where
107+ setMeta field v s = s {dbMeta = setMeta field v (dbMeta s)}
108+ deleteMeta field s = s {dbMeta = deleteMeta field (dbMeta s)}
109+
110+getBlocks :: Element -> DB Blocks
111+getBlocks e = mconcat <$> (mapM parseBlock $ elContent e)
112+
113+-- Trim leading and trailing newline characters
114+trimNl :: String -> String
115+trimNl = reverse . go . reverse . go
116+ where go ('\n':xs) = xs
117+ go xs = xs
118+
119+strContentRecursive :: Element -> String
120+strContentRecursive = strContent .
121+ (\e' -> e'{ elContent = map elementToStr $ elContent e' })
122+
123+elementToStr :: Content -> Content
124+elementToStr (Elem e') = Text $ CData CDataText (strContentRecursive e') Nothing
125+elementToStr x = x
126+
127+isBlockElement :: Content -> Bool
128+isBlockElement (Elem e) = qName (elName e) `elem` blocktags
129+ where blocktags = ["cite","code","comment","credit","desc","example","include",
130+ "info","links","list","listing","media","note","p","page","revision",
131+ "section","title"]
132+isBlockElement _ = False
133+
134+getInlines :: Element -> DB Inlines
135+getInlines e' = (trimInlines . mconcat) <$> (mapM parseInline $ elContent e')
136+
137+-- convenience function to get an attribute value, defaulting to ""
138+attrValue :: String -> Element -> String
139+attrValue attr elt =
140+ case lookupAttrBy (\x -> qName x == attr) (elAttribs elt) of
141+ Just z -> z
142+ Nothing -> ""
143+
144+-- convenience function
145+named :: String -> Element -> Bool
146+named s e = qName (elName e) == s
147+
148+parseImage :: Element -> DB Inlines
149+parseImage e = do
150+ (imageUrl, attr) <-
151+ let atVal a = attrValue a e
152+ w = case atVal "width" of
153+ "" -> []
154+ d -> [("width", d)]
155+ h = case atVal "depth" of
156+ "" -> []
157+ d -> [("height", d)]
158+ atr = (atVal "id", words $ atVal "role", w ++ h)
159+ in return (atVal "src", atr)
160+ let getCaption el = case filterChild (\x -> named "caption" x
161+ || named "textobject" x
162+ || named "alt" x) el of
163+ Nothing -> return mempty
164+ Just z -> mconcat <$> (mapM parseInline $ elContent z)
165+ let (caption, title) = (getCaption e, "")
166+ liftM (imageWith attr imageUrl title) caption
167+
168+parseBlock :: Content -> DB Blocks
169+parseBlock (Text (CData CDataRaw _ _)) = return mempty -- DOCTYPE
170+parseBlock (Text (CData _ s _)) = if all isSpace s
171+ then return mempty
172+ else return $ plain $ trimInlines $ text s
173+parseBlock (CRef x) = return $ plain $ str $ map toUpper x
174+parseBlock (Elem e) =
175+ case qName (elName e) of
176+ "?xml" -> return mempty
177+ "cite" -> return mempty
178+ "code" -> return $ codeBlock $ strContent e
179+ "comment" -> return mempty
180+ "credit" -> checkInMeta getCredit
181+ "desc" -> checkInMeta getDesc
182+ "example" -> parseBlockquote
183+ "include" -> return mempty
184+ "info" -> metaBlock
185+ "links" -> parseLinks
186+ "list" -> bulletList <$> listitems
187+ "media" -> parseMedia
188+ "listing" -> parseListing
189+ "note" -> blockQuote . (para (strong $ str "Note") <>)
190+ <$> getBlocks e
191+ "p" -> parseMixed para (elContent e)
192+ "page" -> modify (\st -> st{ dbPage = True }) >> sect 0
193+ "revision" -> checkInMeta getRevision
194+ "section" -> gets dbSectionLevel >>= sect . (+1)
195+ "title" -> return mempty
196+ _ -> getBlocks e
197+ where getCredit = do
198+ authorname <- case filterChild (named "name") e of
199+ Just t -> getInlines t
200+ Nothing -> return mempty
201+ addMeta "author-name" authorname
202+ authoremail <- case filterChild (named "email") e of
203+ Just t -> getInlines t
204+ Nothing -> return mempty
205+ addMeta "author-email" authoremail
206+ date <- case filterChild (named "years") e of
207+ Just t -> getInlines t
208+ Nothing -> return mempty
209+ addMeta "authoring-date" date
210+ getDesc = do
211+ desc <- getInlines e
212+ addMeta "description" (desc)
213+ listitems = mapM getBlocks $ filterChildren (named "item") e
214+ parseBlockquote = do
215+ attrib <- case filterChild (named "cite") e of
216+ Nothing -> return mempty
217+ Just z -> (para . (str "— " <>) . mconcat)
218+ <$> (mapM parseInline $ elContent z)
219+ contents <- getBlocks e
220+ return $ blockQuote (contents <> attrib)
221+ parseInfoLink t = case (attrValue "type" t) of
222+ "guide" -> do
223+ addMeta "guide-xref" (str(attrValue "xref" t))
224+ addMeta "guide-group" (str(attrValue "group" t))
225+ "next" -> do
226+ addMeta "next-xref" (str(attrValue "xref" t))
227+ "seealso" -> do
228+ addMeta "seealso-xref" (str(attrValue "xref" t))
229+ _ -> return mempty
230+ metaBlock = do
231+ mapM parseInfoLink $ filterChildren (named "link") e
232+ acceptingMetadata (getBlocks e) >> return mempty
233+ parseLinks = do
234+ headerText <- case filterChild (named "title") e of
235+ Just t -> headerWith ("",[],[]) 2 <$> getInlines t
236+ Nothing -> return mempty
237+ let title = ""
238+ let xref = attrValue "groups" e
239+ let backlink = link xref title mempty
240+ return (headerText <> (para (backlink)))
241+ getRevision = do
242+ addMeta "revision-date" (str(attrValue "date" e))
243+ addMeta "revision-version" (str(attrValue "version" e))
244+ addMeta "revision-status" (str(attrValue "status" e))
245+ parseMedia = do
246+ case attrValue "type" e of
247+ "image" -> para <$> parseImage e
248+ _ -> getBlocks e
249+ parseListing = do
250+ return $ codeBlockWith ("Hello", [], [])
251+ $ trimNl $ strContentRecursive e
252+ parseMixed container conts = do
253+ let (ils,rest) = break isBlockElement conts
254+ ils' <- (trimInlines . mconcat) <$> mapM parseInline ils
255+ let p = if ils' == mempty then mempty else container ils'
256+ case rest of
257+ [] -> return p
258+ (r:rs) -> do
259+ b <- parseBlock r
260+ x <- parseMixed container rs
261+ return $ p <> b <> x
262+ sect n = do ispage <- gets dbPage
263+ let n' = if ispage || n == 0 then n + 1 else n
264+ headerText <- case filterChild (named "title") e `mplus`
265+ (filterChild (named "info") e >>=
266+ filterChild (named "title")) of
267+ Just t -> getInlines t
268+ Nothing -> return mempty
269+ case n of
270+ 0 -> do addMeta "title" headerText
271+ _ -> return mempty
272+ modify $ \st -> st{ dbSectionLevel = n }
273+ b <- getBlocks e
274+ let ident = attrValue "id" e
275+ modify $ \st -> st{ dbSectionLevel = n - 1 }
276+ return $ headerWith (ident,[],[]) n' headerText <> b
277+
278+parseInline :: Content -> DB Inlines
279+parseInline (Text (CData _ s _)) = return $ text s
280+parseInline (CRef ref) =
281+ return $ maybe (text $ map toUpper ref) (text . (:[])) $ lookupEntity ref
282+parseInline (Elem e) =
283+ case qName (elName e) of
284+ "app" -> emph <$> innerInlines
285+ "cmd" -> strong <$> innerInlines
286+ "file" -> return mempty
287+ "gui" -> strong <$> innerInlines
288+ "em" -> case attrValue "style" e of
289+ "bold" -> strong <$> innerInlines
290+ "strong" -> strong <$> innerInlines
291+ "strikethrough" -> strikeout <$> innerInlines
292+ _ -> emph <$> innerInlines
293+ "input" -> spanWith nullAttr <$> innerInlines
294+ "link" -> getLink
295+ _ -> innerInlines
296+ where innerInlines = (trimInlines . mconcat) <$>
297+ (mapM parseInline $ elContent e)
298+ getLink = do
299+ acc <- gets dbAcceptsMeta
300+ case acc of
301+ False -> link (getHRef) "" <$> innerInlines
302+ True -> return mempty
303+ getHRef = case findAttr (QName "href" Nothing Nothing) e of
304+ Just h -> h
305+ _ -> attrValue "xref" e
306+