f068093 · typeable/pandoc

git.iko.soy/typeable/pandoc

Added odt reader

Fully implemented features: * Paragraphs * Headers * Basic styling * Unordered lists * Ordered lists * External Links * Internal Links * Footnotes, Endnotes * Blockquotes Partly implemented features: * Citations Very basic, but pandoc can't do much more * Tables No headers, no sizing, limited styling

commitf06809355527394f3c32c0e46e6f9cb48786b668 authorMarLinn <MarLinn@users.noreply.github.com> dateThu 23 Jul 2015, 09:06 (11 years ago) parent8390d93

79 files changed+4368−12

compare with master

unifiedsplit

pandoc.cabal+17−2

@@ -210,7 +210,9 @@ Extra-Source-Files:

210210 tests/epub/*.native

211211 tests/txt2tags.t2t

212212 tests/twiki-reader.twiki

213−

213+ tests/odt/odt/*.odt

214+ tests/odt/markdown/*.md

215+ tests/odt/native/*.native

214216Source-repository head

215217 type: git

216218 location: git://github.com/jgm/pandoc.git

@@ -327,6 +329,7 @@ Library

327329 Text.Pandoc.Readers.TWiki,

328330 Text.Pandoc.Readers.Txt2Tags,

329331 Text.Pandoc.Readers.Docx,

332+ Text.Pandoc.Readers.Odt,

330333 Text.Pandoc.Readers.EPUB,

331334 Text.Pandoc.Writers.Native,

332335 Text.Pandoc.Writers.Docbook,

@@ -364,7 +367,18 @@ Library

364367 Text.Pandoc.Readers.Docx.Parse,

365368 Text.Pandoc.Readers.Docx.Fonts,

366369 Text.Pandoc.Readers.Docx.Util,

367− Text.Pandoc.Readers.Docx.StyleMap

370+ Text.Pandoc.Readers.Docx.StyleMap,

371+ Text.Pandoc.Readers.Odt.Base,

372+ Text.Pandoc.Readers.Odt.Namespaces,

373+ Text.Pandoc.Readers.Odt.StyleReader,

374+ Text.Pandoc.Readers.Odt.ContentReader,

375+ Text.Pandoc.Readers.Odt.Generic.Fallible,

376+ Text.Pandoc.Readers.Odt.Generic.SetMap,

377+ Text.Pandoc.Readers.Odt.Generic.Utils,

378+ Text.Pandoc.Readers.Odt.Generic.Namespaces,

379+ Text.Pandoc.Readers.Odt.Generic.XMLConverter,

380+ Text.Pandoc.Readers.Odt.Arrows.State,

381+ Text.Pandoc.Readers.Odt.Arrows.Utils,

368382 Text.Pandoc.Writers.Shared,

369383 Text.Pandoc.Asciify,

370384 Text.Pandoc.MIME,

@@ -459,6 +473,7 @@ Test-Suite test-pandoc

459473 Tests.Readers.Org

460474 Tests.Readers.RST

461475 Tests.Readers.Docx

476+ Tests.Readers.Odt

462477 Tests.Readers.Txt2Tags

463478 Tests.Readers.EPUB

464479 Tests.Writers.Native

pandoc.hs+1−3

@@ -954,7 +954,7 @@ defaultReaderName fallback (x:xs) =

954954 ".docx" -> "docx"

955955 ".t2t" -> "t2t"

956956 ".epub" -> "epub"

957− ".odt" -> "odt" -- so we get an "unknown reader" error

957+ ".odt" -> "odt"

958958 ".pdf" -> "pdf" -- so we get an "unknown reader" error

959959 ".doc" -> "doc" -- so we get an "unknown reader" error

960960 _ -> defaultReaderName fallback xs

@@ -1180,8 +1180,6 @@ main = do

11801180 Right r -> return r

11811181 Left e -> err 7 e'

11821182 where e' = case readerName' of

1183− "odt" -> e ++

1184− "\nPandoc can convert to ODT, but not from ODT.\nTry using LibreOffice to export as HTML, and convert that with pandoc."

11851183 "pdf" -> e ++

11861184 "\nPandoc can convert to PDF, but not from PDF."

11871185 "doc" -> e ++

src/Text/Pandoc.hs+4−1

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

6767 , Reader (..)

6868 , mkStringReader

6969 , readDocx

70+ , readOdt

7071 , readMarkdown

7172 , readCommonMark

7273 , readMediaWiki

@@ -85,7 +86,7 @@ module Text.Pandoc

8586 , readTxt2TagsNoMacros

8687 , readEPUB

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

88− , Writer (..)

89+ , Writer (..)

8990 , writeNative

9091 , writeJSON

9192 , writeMarkdown

@@ -141,6 +142,7 @@ import Text.Pandoc.Readers.Native

141142import Text.Pandoc.Readers.Haddock

142143import Text.Pandoc.Readers.TWiki

143144import Text.Pandoc.Readers.Docx

145+import Text.Pandoc.Readers.Odt

144146import Text.Pandoc.Readers.Txt2Tags

145147import Text.Pandoc.Readers.EPUB

146148import Text.Pandoc.Writers.Native

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

247249 ,("haddock" , mkStringReader readHaddock)

248250 ,("twiki" , mkStringReader readTWiki)

249251 ,("docx" , mkBSReader readDocx)

252+ ,("odt" , mkBSReader readOdt)

250253 ,("t2t" , mkStringReader readTxt2TagsNoMacros)

251254 ,("epub" , mkBSReader readEPUB)

252255 ]

src/Text/Pandoc/Readers/Odt.hsnew file+86

@@ -0,0 +1,86 @@

1+{-# LANGUAGE PatternGuards #-}

3+{-

6+This program is free software; you can redistribute it and/or modify

7+it under the terms of the GNU General Public License as published by

8+the Free Software Foundation; either version 2 of the License, or

9+(at your option) any later version.

10+

11+This program is distributed in the hope that it will be useful,

12+but WITHOUT ANY WARRANTY; without even the implied warranty of

13+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

14+GNU General Public License for more details.

15+

16+You should have received a copy of the GNU General Public License

17+along with this program; if not, write to the Free Software

18+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

19+-}

20+

21+{- |

22+ Module : Text.Pandoc.Reader.Odt

24+ License : GNU GPL, version 2 or above

25+

26+ Maintainer : Martin Linnemann <theCodingMarlin@googlemail.com>

27+ Stability : alpha

28+ Portability : portable

29+

30+Entry point to the odt reader.

31+-}

32+

33+module Text.Pandoc.Readers.Odt ( readOdt ) where

34+

35+import Codec.Archive.Zip

36+import qualified Text.XML.Light as XML

37+

38+import qualified Data.ByteString.Lazy as B

39+import Data.Monoid ( mempty )

40+

41+import Text.Pandoc.Definition

42+import Text.Pandoc.Error

43+import Text.Pandoc.Options

44+import Text.Pandoc.MediaBag

45+import qualified Text.Pandoc.UTF8 as UTF8

46+

47+import Text.Pandoc.Readers.Odt.ContentReader

48+import Text.Pandoc.Readers.Odt.StyleReader

49+

50+import Text.Pandoc.Readers.Odt.Generic.XMLConverter

51+import Text.Pandoc.Readers.Odt.Generic.Fallible

52+

53+--

54+readOdt :: ReaderOptions

55+ -> B.ByteString

56+ -> Either PandocError (Pandoc, MediaBag)

57+readOdt _ bytes = case bytesToOdt bytes of

58+ Right pandoc -> Right (pandoc , mempty)

59+ Left err -> Left err

60+

61+--

62+bytesToOdt :: B.ByteString -> Either PandocError Pandoc

63+bytesToOdt bytes = archiveToOdt $ toArchive bytes

64+

65+--

66+archiveToOdt :: Archive -> Either PandocError Pandoc

67+archiveToOdt archive

68+ | Just contentEntry <- findEntryByPath "content.xml" archive

69+ , Just stylesEntry <- findEntryByPath "styles.xml" archive

70+ , Just contentElem <- entryToXmlElem contentEntry

71+ , Just stylesElem <- entryToXmlElem stylesEntry

72+ , Right styles <- chooseMax (readStylesAt stylesElem )

73+ (readStylesAt contentElem)

74+ , startState <- readerState styles

75+ , Right pandoc <- runConverter' read_body

76+ startState

77+ contentElem

78+ = Right pandoc

79+

80+ | otherwise

81+ -- Not very detailed, but I don't think more information would be helpful

82+ = Left $ ParseFailure "Couldn't parse odt file."

83+

84+--

85+entryToXmlElem :: Entry -> Maybe XML.Element

86+entryToXmlElem = XML.parseXMLDoc . UTF8.toStringLazy . fromEntry

src/Text/Pandoc/Readers/Odt/Arrows/State.hsnew file+253

@@ -0,0 +1,253 @@

1+{-# LANGUAGE Arrows #-}

2+{-# LANGUAGE TupleSections #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-

7+This program is free software; you can redistribute it and/or modify

8+it under the terms of the GNU General Public License as published by

9+the Free Software Foundation; either version 2 of the License, or

10+(at your option) any later version.

11+

12+This program is distributed in the hope that it will be useful,

13+but WITHOUT ANY WARRANTY; without even the implied warranty of

14+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

15+GNU General Public License for more details.

16+

17+You should have received a copy of the GNU General Public License

18+along with this program; if not, write to the Free Software

19+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

20+-}

21+

22+{- |

23+ Module : Text.Pandoc.Readers.Odt.Arrows.State

25+ License : GNU GPL, version 2 or above

26+

27+ Maintainer : Martin Linnemann <theCodingMarlin@googlemail.com>

28+ Stability : alpha

29+ Portability : portable

30+

31+An arrow that transports a state. It is in essence a more powerful version of

32+the standard state monad. As it is such a simple extension, there are

33+other version out there that do exactly the same.

34+The implementation is duplicated, though, to add some useful features.

35+Most of these might be implemented without access to innards, but it's much

36+faster and easier to implement this way.

37+-}

38+

39+module Text.Pandoc.Readers.Odt.Arrows.State where

40+

41+import Prelude hiding ( foldr, foldl )

42+

43+import qualified Control.Category as Cat

44+import Control.Arrow

45+import Control.Monad

46+

47+import Data.Monoid

48+import Data.Foldable

49+

50+import Text.Pandoc.Readers.Odt.Arrows.Utils

51+import Text.Pandoc.Readers.Odt.Generic.Fallible

52+

53+

54+newtype ArrowState state a b = ArrowState

55+ { runArrowState :: (state, a) -> (state, b) }

56+

57+-- | Constructor

58+withState :: (state -> a -> (state, b)) -> ArrowState state a b

59+withState = ArrowState . uncurry

60+

61+-- | Constructor

62+withState' :: ((state, a) -> (state, b)) -> ArrowState state a b

63+withState' = ArrowState

64+

65+-- | Constructor

66+modifyState :: (state -> state ) -> ArrowState state a a

67+modifyState = ArrowState . first

68+

69+-- | Constructor

70+ignoringState :: ( a -> b ) -> ArrowState state a b

71+ignoringState = ArrowState . second

72+

73+-- | Constructor

74+fromState :: (state -> (state, b)) -> ArrowState state a b

75+fromState = ArrowState . (.fst)

76+

77+-- | Constructor

78+extractFromState :: (state -> b ) -> ArrowState state x b

79+extractFromState f = ArrowState $ \(state,_) -> (state, f state)

80+

81+-- | Constructor

82+withUnchangedState :: (state -> a -> b ) -> ArrowState state a b

83+withUnchangedState f = ArrowState $ \(state,a) -> (state, f state a)

84+

85+-- | Constructor

86+tryModifyState :: (state -> Either f state)

87+ -> ArrowState state a (Either f a)

88+tryModifyState f = ArrowState $ \(state,a)

89+ -> (state,).Left ||| (,Right a) $ f state

90+

91+instance Cat.Category (ArrowState s) where

92+ id = ArrowState id

93+ arrow2 . arrow1 = ArrowState $ (runArrowState arrow2).(runArrowState arrow1)

94+

95+instance Arrow (ArrowState state) where

96+ arr = ignoringState

97+ first a = ArrowState $ \(s,(aF,aS))

98+ -> second (,aS) $ runArrowState a (s,aF)

99+ second a = ArrowState $ \(s,(aF,aS))

100+ -> second (aF,) $ runArrowState a (s,aS)

101+

102+instance ArrowChoice (ArrowState state) where

103+ left a = ArrowState $ \(s,e) -> case e of

104+ Left l -> second Left $ runArrowState a (s,l)

105+ Right r -> (s, Right r)

106+ right a = ArrowState $ \(s,e) -> case e of

107+ Left l -> (s, Left l)

108+ Right r -> second Right $ runArrowState a (s,r)

109+

110+instance ArrowLoop (ArrowState state) where

111+ loop a = ArrowState $ \(s, x)

112+ -> let (s', (x', _d)) = runArrowState a (s, (x, _d))

113+ in (s', x')

114+

115+instance ArrowApply (ArrowState state) where

116+ app = ArrowState $ \(s, (f,b)) -> runArrowState f (s,b)

117+

118+

119+-- | Embedding of a state arrow in a state arrow with a different state type.

120+switchState :: (s -> s') -> (s' -> s) -> ArrowState s' x y -> ArrowState s x y

121+switchState there back a = ArrowState $ first there

122+ >>> runArrowState a

123+ >>> first back

124+

125+-- | Lift a state arrow to modify the state of an arrow

126+-- with a different state type.

127+liftToState :: (s -> s') -> ArrowState s' s s -> ArrowState s x x

128+liftToState unlift a = modifyState $ unlift &&& id

129+ >>> runArrowState a

130+ >>> snd

131+

132+-- | Switches the type of the state temporarily.

133+-- Drops the intermediate result state, behaving like the identity arrow,

134+-- save for side effects in the state.

135+withSubState :: ArrowState s x s2 -> ArrowState s2 s s -> ArrowState s x x

136+withSubState unlift a = keepingTheValue (withSubState unlift a) >>^ fst

137+

138+-- | Switches the type of the state temporarily.

139+-- Returns the resulting sub-state.

140+withSubState' :: ArrowState s x s' -> ArrowState s' s s -> ArrowState s x s'

141+withSubState' unlift a = ArrowState $ runArrowState unlift

142+ >>> switch

143+ >>> runArrowState a

144+ >>> switch

145+ where switch (x,y) = (y,x)

146+

147+-- | Switches the type of the state temporarily.

148+-- Drops the intermediate result state, behaving like a fallible

149+-- identity arrow, save for side effects in the state.

150+withSubStateF :: ArrowState s x (Either f s')

151+ -> ArrowState s' s (Either f s )

152+ -> ArrowState s x (Either f x )

153+withSubStateF unlift a = keepingTheValue (withSubStateF' unlift a)

154+ >>^ spreadChoice

155+ >>^ fmap fst

156+

157+-- | Switches the type of the state temporarily.

158+-- Returns the resulting sub-state.

159+withSubStateF' :: ArrowState s x (Either f s')

160+ -> ArrowState s' s (Either f s )

161+ -> ArrowState s x (Either f s')

162+withSubStateF' unlift a = ArrowState go

163+ where go p@(s,_) = tryRunning unlift

164+ ( tryRunning a (second Right) )

165+ p

166+ where tryRunning a' b v = case runArrowState a' v of

167+ (_ , Left f) -> (s, Left f)

168+ (x , Right y) -> b (y,x)

169+

170+-- | Fold a state arrow through something 'Foldable'. Collect the results

171+-- in a 'Monoid'.

172+-- Intermediate form of a fold between one with "only" a 'Monoid'

173+-- and one with any function.

174+foldS :: (Foldable f, Monoid m) => ArrowState s x m -> ArrowState s (f x) m

175+foldS a = ArrowState $ \(s,f) -> foldr a' (s,mempty) f

176+ where a' x (s',m) = second (m <>) $ runArrowState a (s',x)

177+

178+-- | Fold a state arrow through something 'Foldable'. Collect the results

179+-- in a 'Monoid'.

180+-- Intermediate form of a fold between one with "only" a 'Monoid'

181+-- and one with any function.

182+foldSL :: (Foldable f, Monoid m) => ArrowState s x m -> ArrowState s (f x) m

183+foldSL a = ArrowState $ \(s,f) -> foldl a' (s,mempty) f

184+ where a' (s',m) x = second (m <>) $ runArrowState a (s',x)

185+

186+-- | Fold a fallible state arrow through something 'Foldable'. Collect the

187+-- results in a 'Monoid'.

188+-- Intermediate form of a fold between one with "only" a 'Monoid'

189+-- and one with any function.

190+-- If the iteration fails, the state will be reset to the initial one.

191+foldS' :: (Foldable f, Monoid m)

192+ => ArrowState s x (Either e m)

193+ -> ArrowState s (f x) (Either e m)

194+foldS' a = ArrowState $ \(s,f) -> foldr (a' s) (s,Right mempty) f

195+ where a' s x (s',Right m) = case runArrowState a (s',x) of

196+ (s'',Right m') -> (s'', Right (m <> m'))

197+ (_ ,Left e ) -> (s , Left e)

198+ a' _ _ e = e

199+

200+-- | Fold a fallible state arrow through something 'Foldable'. Collect the

201+-- results in a 'Monoid'.

202+-- Intermediate form of a fold between one with "only" a 'Monoid'

203+-- and one with any function.

204+-- If the iteration fails, the state will be reset to the initial one.

205+foldSL' :: (Foldable f, Monoid m)

206+ => ArrowState s x (Either e m)

207+ -> ArrowState s (f x) (Either e m)

208+foldSL' a = ArrowState $ \(s,f) -> foldl (a' s) (s,Right mempty) f

209+ where a' s (s',Right m) x = case runArrowState a (s',x) of

210+ (s'',Right m') -> (s'', Right (m <> m'))

211+ (_ ,Left e ) -> (s , Left e)

212+ a' _ e _ = e

213+

214+-- | Fold a state arrow through something 'Foldable'. Collect the results in a

215+-- 'MonadPlus'.

216+iterateS :: (Foldable f, MonadPlus m)

217+ => ArrowState s x y

218+ -> ArrowState s (f x) (m y)

219+iterateS a = ArrowState $ \(s,f) -> foldr a' (s,mzero) f

220+ where a' x (s',m) = second ((mplus m).return) $ runArrowState a (s',x)

221+

222+-- | Fold a state arrow through something 'Foldable'. Collect the results in a

223+-- 'MonadPlus'.

224+iterateSL :: (Foldable f, MonadPlus m)

225+ => ArrowState s x y

226+ -> ArrowState s (f x) (m y)

227+iterateSL a = ArrowState $ \(s,f) -> foldl a' (s,mzero) f

228+ where a' (s',m) x = second ((mplus m).return) $ runArrowState a (s',x)

229+

230+

231+-- | Fold a fallible state arrow through something 'Foldable'.

232+-- Collect the results in a 'MonadPlus'.

233+-- If the iteration fails, the state will be reset to the initial one.

234+iterateS' :: (Foldable f, MonadPlus m)

235+ => ArrowState s x (Either e y )

236+ -> ArrowState s (f x) (Either e (m y))

237+iterateS' a = ArrowState $ \(s,f) -> foldr (a' s) (s,Right mzero) f

238+ where a' s x (s',Right m) = case runArrowState a (s',x) of

239+ (s'',Right m') -> (s'',Right $ mplus m $ return m')

240+ (_ ,Left e ) -> (s ,Left e )

241+ a' _ _ e = e

242+

243+-- | Fold a fallible state arrow through something 'Foldable'.

244+-- Collect the results in a 'MonadPlus'.

245+-- If the iteration fails, the state will be reset to the initial one.

246+iterateSL' :: (Foldable f, MonadPlus m)

247+ => ArrowState s x (Either e y )

248+ -> ArrowState s (f x) (Either e (m y))

249+iterateSL' a = ArrowState $ \(s,f) -> foldl (a' s) (s,Right mzero) f

250+ where a' s (s',Right m) x = case runArrowState a (s',x) of

251+ (s'',Right m') -> (s'',Right $ mplus m $ return m')

252+ (_ ,Left e ) -> (s ,Left e )

253+ a' _ e _ = e

src/Text/Pandoc/Readers/Odt/Arrows/Utils.hsnew file+497

@@ -0,0 +1,497 @@

1+{-

4+This program is free software; you can redistribute it and/or modify

5+it under the terms of the GNU General Public License as published by

6+the Free Software Foundation; either version 2 of the License, or

7+(at your option) any later version.

9+This program is distributed in the hope that it will be useful,

10+but WITHOUT ANY WARRANTY; without even the implied warranty of

11+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

12+GNU General Public License for more details.

13+

14+You should have received a copy of the GNU General Public License

15+along with this program; if not, write to the Free Software

16+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

17+-}

18+

19+{- |

20+ Module : Text.Pandoc.Readers.Odt.Arrows.Utils

22+ License : GNU GPL, version 2 or above

23+

24+ Maintainer : Martin Linnemann <theCodingMarlin@googlemail.com>

25+ Stability : alpha

26+ Portability : portable

27+

28+Utility functions for Arrows (Kleisli monads).

29+

30+Some general notes on notation:

31+

32+* "^" is meant to stand for a pure function that is lifted into an arrow

33+based on its usage for that purpose in "Control.Arrow".

34+* "?" is meant to stand for the usage of a 'FallibleArrow' or a pure function

35+with an equivalent return value.

36+* "_" stands for the dropping of a value.

37+-}

38+

39+-- We export everything

40+module Text.Pandoc.Readers.Odt.Arrows.Utils where

41+

42+import Control.Arrow

43+import Control.Monad ( join, MonadPlus(..) )

44+

45+import Data.Monoid

46+import qualified Data.Foldable as F

47+

48+import Text.Pandoc.Readers.Odt.Generic.Fallible

49+import Text.Pandoc.Readers.Odt.Generic.Utils

50+

51+

52+and2 :: (Arrow a) => a b c -> a b c' -> a b (c,c')

53+and2 = (&&&)

54+

55+and3 :: (Arrow a)

56+ => a b c0->a b c1->a b c2

57+ -> a b (c0,c1,c2 )

58+and4 :: (Arrow a)

59+ => a b c0->a b c1->a b c2->a b c3

60+ -> a b (c0,c1,c2,c3 )

61+and5 :: (Arrow a)

62+ => a b c0->a b c1->a b c2->a b c3->a b c4

63+ -> a b (c0,c1,c2,c3,c4 )

64+and6 :: (Arrow a)

65+ => a b c0->a b c1->a b c2->a b c3->a b c4->a b c5

66+ -> a b (c0,c1,c2,c3,c4,c5 )

67+and7 :: (Arrow a)

68+ => a b c0->a b c1->a b c2->a b c3->a b c4->a b c5->a b c6

69+ -> a b (c0,c1,c2,c3,c4,c5,c6 )

70+and8 :: (Arrow a)

71+ => a b c0->a b c1->a b c2->a b c3->a b c4->a b c5->a b c6->a b c7

72+ -> a b (c0,c1,c2,c3,c4,c5,c6,c7)

73+

74+and3 a b c = (and2 a b ) &&& c

75+ >>^ \((z,y ) , x) -> (z,y,x )

76+and4 a b c d = (and3 a b c ) &&& d

77+ >>^ \((z,y,x ) , w) -> (z,y,x,w )

78+and5 a b c d e = (and4 a b c d ) &&& e

79+ >>^ \((z,y,x,w ) , v) -> (z,y,x,w,v )

80+and6 a b c d e f = (and5 a b c d e ) &&& f

81+ >>^ \((z,y,x,w,v ) , u) -> (z,y,x,w,v,u )

82+and7 a b c d e f g = (and6 a b c d e f ) &&& g

83+ >>^ \((z,y,x,w,v,u ) , t) -> (z,y,x,w,v,u,t )

84+and8 a b c d e f g h = (and7 a b c d e f g) &&& h

85+ >>^ \((z,y,x,w,v,u,t) , s) -> (z,y,x,w,v,u,t,s)

86+

87+liftA2 :: (Arrow a) => (x -> y -> z) -> a b x -> a b y -> a b z

88+liftA2 f a b = a &&& b >>^ uncurry f

89+

90+liftA3 :: (Arrow a) => (z->y->x -> r)

91+ -> a b z->a b y->a b x

92+ -> a b r

93+liftA4 :: (Arrow a) => (z->y->x->w -> r)

94+ -> a b z->a b y->a b x->a b w

95+ -> a b r

96+liftA5 :: (Arrow a) => (z->y->x->w->v -> r)

97+ -> a b z->a b y->a b x->a b w->a b v

98+ -> a b r

99+liftA6 :: (Arrow a) => (z->y->x->w->v->u -> r)

100+ -> a b z->a b y->a b x->a b w->a b v->a b u

101+ -> a b r

102+liftA7 :: (Arrow a) => (z->y->x->w->v->u->t -> r)

103+ -> a b z->a b y->a b x->a b w->a b v->a b u->a b t

104+ -> a b r

105+liftA8 :: (Arrow a) => (z->y->x->w->v->u->t->s -> r)

106+ -> a b z->a b y->a b x->a b w->a b v->a b u->a b t->a b s

107+ -> a b r

108+

109+liftA3 fun a b c = and3 a b c >>^ uncurry3 fun

110+liftA4 fun a b c d = and4 a b c d >>^ uncurry4 fun

111+liftA5 fun a b c d e = and5 a b c d e >>^ uncurry5 fun

112+liftA6 fun a b c d e f = and6 a b c d e f >>^ uncurry6 fun

113+liftA7 fun a b c d e f g = and7 a b c d e f g >>^ uncurry7 fun

114+liftA8 fun a b c d e f g h = and8 a b c d e f g h >>^ uncurry8 fun

115+

116+liftA :: (Arrow a) => (y -> z) -> a b y -> a b z

117+liftA fun a = a >>^ fun

118+

119+

120+-- | Duplicate a value to subsequently feed it into different arrows.

121+-- Can almost always be replaced with '(&&&)', 'keepingTheValue',

122+-- or even '(|||)'.

123+-- Aequivalent to

124+-- > returnA &&& returnA

125+duplicate :: (Arrow a) => a b (b,b)

126+duplicate = arr $ join (,)

127+

128+-- | Lifts the combination of two values into an arrow.

129+joinOn :: (Arrow a) => (x -> y -> z) -> a (x,y) z

130+joinOn = arr.uncurry

131+

132+-- | Applies a function to the uncurried result-pair of an arrow-application.

133+-- (The §-symbol was chosen to evoke an association with pairs through the

134+-- shared first character)

135+(>>§) :: (Arrow a) => a x (b,c) -> (b -> c -> d) -> a x d

136+a >>§ f = a >>^ uncurry f

137+

138+-- | '(>>§)' with its arguments flipped

139+(§<<) :: (Arrow a) => (b -> c -> d) -> a x (b,c) -> a x d

140+(§<<) = flip (>>§)

141+

142+-- | Precomposition with an uncurried function

143+(§>>) :: (Arrow a) => (b -> c -> d) -> a d r -> a (b,c) r

144+f §>> a = uncurry f ^>> a

145+

146+-- | Precomposition with an uncurried function (right to left variant)

147+(<<§) :: (Arrow a) => a d r -> (b -> c -> d) -> a (b,c) r

148+(<<§) = flip (§>>)

149+

150+infixr 2 >>§, §<<, §>>, <<§

151+

152+

153+-- | Duplicate a value and apply an arrow to the second instance.

154+-- Aequivalent to

155+-- > \a -> duplicate >>> second a

156+-- or

157+-- > \a -> returnA &&& a

158+keepingTheValue :: (Arrow a) => a b c -> a b (b,c)

159+keepingTheValue a = returnA &&& a

160+

161+-- | Duplicate a value and apply an arrow to the first instance.

162+-- Aequivalent to

163+-- > \a -> duplicate >>> first a

164+-- or

165+-- > \a -> a &&& returnA

166+keepingTheValue' :: (Arrow a) => a b c -> a b (c,b)

167+keepingTheValue' a = a &&& returnA

168+

169+-- | 'bind' from the "Maybe"-Monad lifted into an 'ArrowChoice'.

170+-- Actually, it's the more complex '(>=>)', because 'bind' alone does not

171+-- combine as nicely in arrow form.

172+-- The current implementation is not the most efficient one, because it can

173+-- not return directly if a 'Nothing' is encountered. That in turn follows

174+-- from the type system, as 'Nothing' has an "invisible" type parameter that

175+-- can not be dropped early.

176+--

177+-- Also, there probably is a way to generalize this to other monads

178+-- or applicatives, but I'm leaving that as an exercise to the reader.

179+-- I have a feeling there is a new Arrow-typeclass to be found that is less

180+-- restrictive than 'ArrowApply'. If it is already out there,

181+-- I have not seen it yet. ('ArrowPlus' for example is not general enough.)

182+(>>>=) :: (ArrowChoice a) => a x (Maybe b) -> a b (Maybe c) -> a x (Maybe c)

183+a1 >>>= a2 = a1 >>> maybeToChoice >>> right a2 >>> choiceToMaybe >>^ join

184+

185+infixr 2 >>>=

186+

187+-- | 'mplus' Lifted into an arrow. No 'ArrowPlus' required.

188+-- (But still different from a true bind)

189+(>++<) :: (Arrow a, MonadPlus m) => a x (m b) -> a x (m b) -> a x (m b)

190+(>++<) = liftA2 mplus

191+

192+-- | Left-compose with a pure function

193+leftLift :: (ArrowChoice a) => (l -> l') -> a (Either l r) (Either l' r)

194+leftLift = left.arr

195+

196+-- | Right-compose with a pure function

197+rightLift :: (ArrowChoice a) => (r -> r') -> a (Either l r) (Either l r')

198+rightLift = right.arr

199+

200+

201+( ^+++ ) :: (ArrowChoice a) => (b -> c) -> a b' c' -> a (Either b b') (Either c c')

202+( +++^ ) :: (ArrowChoice a) => a b c -> (b' -> c') -> a (Either b b') (Either c c')

203+( ^+++^ ) :: (ArrowChoice a) => (b -> c) -> (b' -> c') -> a (Either b b') (Either c c')

204+

205+l ^+++ r = leftLift l >>> right r

206+l +++^ r = left l >>> rightLift r

207+l ^+++^ r = leftLift l >>> rightLift r

208+

209+infixr 2 ^+++, +++^, ^+++^

210+

211+( ^||| ) :: (ArrowChoice a) => (b -> d) -> a c d -> a (Either b c) d

212+( |||^ ) :: (ArrowChoice a) => a b d -> (c -> d) -> a (Either b c) d

213+( ^|||^ ) :: (ArrowChoice a) => (b -> d) -> (c -> d) -> a (Either b c) d

214+

215+l ^||| r = arr l ||| r

216+l |||^ r = l ||| arr r

217+l ^|||^ r = arr l ||| arr r

218+

219+infixr 2 ^||| , |||^, ^|||^

220+

221+( ^&&& ) :: (Arrow a) => (b -> c) -> a b c' -> a b (c,c')

222+( &&&^ ) :: (Arrow a) => a b c -> (b -> c') -> a b (c,c')

223+( ^&&&^ ) :: (Arrow a) => (b -> c) -> (b -> c') -> a b (c,c')

224+

225+l ^&&& r = arr l &&& r

226+l &&&^ r = l &&& arr r

227+l ^&&&^ r = arr l &&& arr r

228+

229+infixr 3 ^&&&, &&&^, ^&&&^

230+

231+( ^*** ) :: (Arrow a) => (b -> c) -> a b' c' -> a (b,b') (c,c')

232+( ***^ ) :: (Arrow a) => a b c -> (b' -> c') -> a (b,b') (c,c')

233+( ^***^ ) :: (Arrow a) => (b -> c) -> (b' -> c') -> a (b,b') (c,c')

234+

235+l ^*** r = arr l *** r

236+l ***^ r = l *** arr r

237+l ^***^ r = arr l *** arr r

238+

239+infixr 3 ^***, ***^, ^***^

240+

241+-- | A version of

242+--

243+-- >>> \p -> arr (\x -> if p x the Right x else Left x)

244+--

245+-- but with p being an arrow

246+choose :: (ArrowChoice a) => a b Bool -> a b (Either b b)

247+choose checkValue = keepingTheValue checkValue >>^ select

248+ where select (x,True ) = Right x

249+ select (x,False ) = Left x

250+

251+-- | Converts @Right a@ into @Just a@ and @Left _@ into @Nothing@.

252+choiceToMaybe :: (ArrowChoice a) => a (Either l r) (Maybe r)

253+choiceToMaybe = arr eitherToMaybe

254+

255+-- | Converts @Nothing@ into @Left ()@ and @Just a@ into @Right a@.

256+maybeToChoice :: (ArrowChoice a) => a (Maybe b) (Fallible b)

257+maybeToChoice = arr maybeToEither

258+

259+-- | Lifts a constant value into an arrow

260+returnV :: (Arrow a) => c -> a x c

261+returnV = arr.const

262+

263+-- | 'returnA' dropping everything

264+returnA_ :: (Arrow a) => a _b ()

265+returnA_ = returnV ()

266+

267+-- | Wrapper for an arrow that can be evaluated im parallel. All

268+-- Arrows can be evaluated in parallel, as long as they return a

269+-- monoid.

270+newtype ParallelArrow a b c = CoEval { evalParallelArrow :: a b c }

271+ deriving (Eq, Ord, Show)

272+

273+instance (Arrow a, Monoid m) => Monoid (ParallelArrow a b m) where

274+ mempty = CoEval $ returnV mempty

275+ (CoEval a) `mappend` (CoEval ~b) = CoEval $ a &&& b >>§ mappend

276+

277+-- | Evaluates a collection of arrows in a parallel fashion.

278+--

279+-- This is in essence a fold of '(&&&)' over the collection,

280+-- so the actual execution order and parallelity depends on the

281+-- implementation of '(&&&)' in the arrow in question.

282+-- The default implementation of '(&&&)' for example keeps the

283+-- order as given in the collection.

284+--

285+-- This function can be seen as a generalization of

286+-- 'Control.Applicative.sequenceA' to arrows or as an alternative to

287+-- a fold with 'Control.Applicative.WrappedArrow', which

288+-- substitutes the monoid with function application.

289+--

290+coEval :: (Arrow a, F.Foldable f, Monoid m) => f (a b m) -> a b m

291+coEval = evalParallelArrow . (F.foldMap CoEval)

292+

293+-- | Defines Left as failure, Right as success

294+type FallibleArrow a input failure success = a input (Either failure success)

295+

296+type ReFallibleArrow a failure success success'

297+ = FallibleArrow a (Either failure success) failure success'

298+

299+-- | Wrapper for fallible arrows. Fallible arrows are all arrows that return

300+-- an Either value where left is a faliure and right is a success value.

301+newtype AlternativeArrow a input failure success

302+ = TryArrow { evalAlternativeArrow :: FallibleArrow a input failure success }

303+

304+

305+instance (ArrowChoice a, Monoid failure)

306+ => Monoid (AlternativeArrow a input failure success) where

307+ mempty = TryArrow $ returnV $ Left mempty

308+ (TryArrow a) `mappend` (TryArrow b)

309+ = TryArrow $ a &&& b

310+ >>^ \(a',~b')

311+ -> ( (\a'' -> left (mappend a'') b') ||| Right )

312+ a'

313+

314+-- | Evaluates a collection of fallible arrows, trying each one in succession.

315+-- Left values are interpreted as failures, right values as successes.

316+--

317+-- The evaluation is stopped once an arrow succeeds.

318+-- Up to that point, all failures are collected in the failure-monoid.

319+-- Note that '()' is a monoid, and thus can serve as a failure-collector if

320+-- you are uninterested in the exact failures.

321+--

322+-- This is in essence a fold of '(&&&)' over the collection, enhanced with a

323+-- little bit of repackaging, so the actual execution order depends on the

324+-- implementation of '(&&&)' in the arrow in question.

325+-- The default implementation of '(&&&)' for example keeps the

326+-- order as given in the collection.

327+--

328+tryArrows :: (ArrowChoice a, F.Foldable f, Monoid failure)

329+ => f (FallibleArrow a b failure success)

330+ -> FallibleArrow a b failure success

331+tryArrows = evalAlternativeArrow . (F.foldMap TryArrow)

332+

333+--

334+liftSuccess :: (ArrowChoice a)

335+ => (success -> success')

336+ -> ReFallibleArrow a failure success success'

337+liftSuccess = rightLift

338+

339+--

340+liftAsSuccess :: (ArrowChoice a)

341+ => a x success

342+ -> FallibleArrow a x failure success

343+liftAsSuccess a = a >>^ Right

344+

345+--

346+asFallibleArrow :: (ArrowChoice a)

347+ => a x success

348+ -> FallibleArrow a x failure success

349+asFallibleArrow a = a >>^ Right

350+

351+-- | Raises an error into a 'ReFallibleArrow' if the arrow is already in

352+-- "error mode"

353+liftError :: (ArrowChoice a, Monoid failure)

354+ => failure

355+ -> ReFallibleArrow a failure success success

356+liftError e = leftLift (e <>)

357+

358+-- | Raises an error into a 'FallibleArrow', droping both the arrow input

359+-- and any previously stored error value.

360+_raiseA :: (ArrowChoice a)

361+ => failure

362+ -> FallibleArrow a x failure success

363+_raiseA e = returnV (Left e)

364+

365+-- | Raises an empty error into a 'FallibleArrow', droping both the arrow input

366+-- and any previously stored error value.

367+_raiseAEmpty :: (ArrowChoice a, Monoid failure)

368+ => FallibleArrow a x failure success

369+_raiseAEmpty = _raiseA mempty

370+

371+-- | Raises an error into a 'ReFallibleArrow', possibly appending the new error

372+-- to an existing one

373+raiseA :: (ArrowChoice a, Monoid failure)

374+ => failure

375+ -> ReFallibleArrow a failure success success

376+raiseA e = arr $ Left.(either (<> e) (const e))

377+

378+-- | Raises an empty error into a 'ReFallibleArrow'. If there already is an

379+-- error, nothing changes.

380+-- (Note that this function is only aequivalent to @raiseA mempty@ iff the

381+-- failure monoid follows the monoid laws.)

382+raiseAEmpty :: (ArrowChoice a, Monoid failure)

383+ => ReFallibleArrow a failure success success

384+raiseAEmpty = arr (fromRight (const mempty) >>> Left)

385+

386+

387+-- | Execute the second arrow if the first succeeds

388+(>>?) :: (ArrowChoice a, Monoid failure)

389+ => FallibleArrow a x failure success

390+ -> FallibleArrow a success failure success'

391+ -> FallibleArrow a x failure success'

392+a >>? b = a >>> Left ^||| b

393+

394+-- | Execute the lifted second arrow if the first succeeds

395+(>>?^) :: (ArrowChoice a, Monoid failure)

396+ => FallibleArrow a x failure success

397+ -> (success -> success')

398+ -> FallibleArrow a x failure success'

399+a >>?^ f = a >>^ Left ^|||^ Right . f

400+

401+-- | Execute the lifted second arrow if the first succeeds

402+(>>?^?) :: (ArrowChoice a, Monoid failure)

403+ => FallibleArrow a x failure success

404+ -> (success -> Either failure success')

405+ -> FallibleArrow a x failure success'

406+a >>?^? b = a >>> Left ^|||^ b

407+

408+-- | Execute the second arrow if the lifted first arrow succeeds

409+(^>>?) :: (ArrowChoice a, Monoid failure)

410+ => (x -> Either failure success)

411+ -> FallibleArrow a success failure success'

412+ -> FallibleArrow a x failure success'

413+a ^>>? b = a ^>> Left ^||| b

414+

415+-- | Execute the lifted second arrow if the lifted first arrow succeeds

416+(^>>?^) :: (ArrowChoice a, Monoid failure)

417+ => (x -> Either failure success)

418+ -> (success -> success')

419+ -> FallibleArrow a x failure success'

420+a ^>>?^ f = arr $ a >>> right f

421+

422+-- | Execute the lifted second arrow if the lifted first arrow succeeds

423+(^>>?^?) :: (ArrowChoice a, Monoid failure)

424+ => (x -> Either failure success)

425+ -> (success -> Either failure success')

426+ -> FallibleArrow a x failure success'

427+a ^>>?^? f = a ^>> Left ^|||^ f

428+

429+-- | Execute the second, non-fallible arrow if the first arrow succeeds

430+(>>?!) :: (ArrowChoice a, Monoid failure)

431+ => FallibleArrow a x failure success

432+ -> a success success'

433+ -> FallibleArrow a x failure success'

434+a >>?! f = a >>> right f

435+

436+---

437+(>>?§) :: (ArrowChoice a, Monoid f)

438+ => FallibleArrow a x f (b,b')

439+ -> (b -> b' -> c)

440+ -> FallibleArrow a x f c

441+a >>?§ f = a >>?^ (uncurry f)

442+

443+---

444+(^>>?§) :: (ArrowChoice a, Monoid f)

445+ => (x -> Either f (b,b'))

446+ -> (b -> b' -> c)

447+ -> FallibleArrow a x f c

448+a ^>>?§ f = arr a >>?^ (uncurry f)

449+

450+---

451+(>>?§?) :: (ArrowChoice a, Monoid f)

452+ => FallibleArrow a x f (b,b')

453+ -> (b -> b' -> (Either f c))

454+ -> FallibleArrow a x f c

455+a >>?§? f = a >>?^? (uncurry f)

456+

457+infixr 1 >>?, >>?^, >>?^?

458+infixr 1 ^>>?, ^>>?^, ^>>?^?, >>?!

459+infixr 1 >>?§, ^>>?§, >>?§?

460+

461+-- | Keep values that are Right, replace Left values by a constant.

462+ifFailedUse :: (ArrowChoice a) => v -> a (Either f v) v

463+ifFailedUse v = arr $ either (const v) id

464+

465+-- | '(&&)' lifted into an arrow

466+(<&&>) :: (Arrow a) => a x Bool -> a x Bool -> a x Bool

467+(<&&>) = liftA2 (&&)

468+

469+-- | '(||)' lifted into an arrow

470+(<||>) :: (Arrow a) => a x Bool -> a x Bool -> a x Bool

471+(<||>) = liftA2 (||)

472+

473+-- | An equivalent of '(&&)' in a fallible arrow

474+(>&&<) :: (ArrowChoice a, Monoid f) => FallibleArrow a x f s

475+ -> FallibleArrow a x f s'

476+ -> FallibleArrow a x f (s,s')

477+(>&&<) = liftA2 chooseMin

478+

479+-- | An equivalent of '(||)' in some forms of fallible arrows

480+(>||<) :: (ArrowChoice a, Monoid f, Monoid s) => FallibleArrow a x f s

481+ -> FallibleArrow a x f s

482+ -> FallibleArrow a x f s

483+(>||<) = liftA2 chooseMax

484+

485+-- | An arrow version of a short-circuit (<|>)

486+ifFailedDo :: (ArrowChoice a)

487+ => FallibleArrow a x f y

488+ -> FallibleArrow a x f y

489+ -> FallibleArrow a x f y

490+ifFailedDo a b = keepingTheValue a >>> repackage ^>> (b |||^ Right)

491+ where repackage (x , Left _) = Left x

492+ repackage (_ , Right y) = Right y

493+

494+infixr 4 <&&>, <||>, >&&<, >||<

495+infixr 1 `ifFailedDo`

496+

497+

src/Text/Pandoc/Readers/Odt/Base.hsnew file+43

@@ -0,0 +1,43 @@

1+{-# LANGUAGE PatternGuards #-}

3+{-

6+This program is free software; you can redistribute it and/or modify

7+it under the terms of the GNU General Public License as published by

8+the Free Software Foundation; either version 2 of the License, or

9+(at your option) any later version.

10+

11+This program is distributed in the hope that it will be useful,

12+but WITHOUT ANY WARRANTY; without even the implied warranty of

13+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

14+GNU General Public License for more details.

15+

16+You should have received a copy of the GNU General Public License

17+along with this program; if not, write to the Free Software

18+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

19+-}

20+

21+{- |

22+ Module : Text.Pandoc.Readers.Odt.Base

24+ License : GNU GPL, version 2 or above

25+

26+ Maintainer : Martin Linnemann <theCodingMarlin@googlemail.com>

27+ Stability : alpha

28+ Portability : portable

29+

30+Core types of the odt reader.

31+-}

32+

33+module Text.Pandoc.Readers.Odt.Base where

34+

35+import Text.Pandoc.Readers.Odt.Generic.XMLConverter

36+import Text.Pandoc.Readers.Odt.Namespaces

37+

38+type OdtConverterState s = XMLConverterState Namespace s

39+

40+type XMLReader s a b = FallibleXMLConverter Namespace s a b

41+

42+type XMLReaderSafe s a b = XMLConverter Namespace s a b

43+

src/Text/Pandoc/Readers/Odt/ContentReader.hsnew file+790

@@ -0,0 +1,790 @@

1+{-# LANGUAGE Arrows #-}

2+{-# LANGUAGE TupleSections #-}

3+{-# LANGUAGE PatternGuards #-}

4+{-# LANGUAGE ViewPatterns #-}

5+{-# LANGUAGE RecordWildCards #-}

7+{-

10+This program is free software; you can redistribute it and/or modify

11+it under the terms of the GNU General Public License as published by

12+the Free Software Foundation; either version 2 of the License, or

13+(at your option) any later version.

14+

15+This program is distributed in the hope that it will be useful,

16+but WITHOUT ANY WARRANTY; without even the implied warranty of

17+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

18+GNU General Public License for more details.

19+

20+You should have received a copy of the GNU General Public License

21+along with this program; if not, write to the Free Software

22+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

23+-}

24+

25+{- |

26+ Module : Text.Pandoc.Readers.Odt.ContentReader

28+ License : GNU GPL, version 2 or above

29+

30+ Maintainer : Martin Linnemann <theCodingMarlin@googlemail.com>

31+ Stability : alpha

32+ Portability : portable

33+

34+The core of the odt reader that converts odt features into Pandoc types.

35+-}

36+

37+module Text.Pandoc.Readers.Odt.ContentReader

38+( readerState

39+, read_body

40+) where

41+

42+import Control.Arrow

43+import Control.Applicative hiding ( liftA, liftA2, liftA3 )

44+

45+import qualified Data.Map as M

46+import Data.List ( find )

47+import Data.Monoid

48+import Data.Maybe

49+

50+import qualified Text.XML.Light as XML

51+

52+import Text.Pandoc.Definition

53+import Text.Pandoc.Builder

54+import Text.Pandoc.Shared

55+

56+import Text.Pandoc.Readers.Odt.Base

57+import Text.Pandoc.Readers.Odt.Namespaces

58+import Text.Pandoc.Readers.Odt.StyleReader

59+

60+import Text.Pandoc.Readers.Odt.Arrows.Utils

61+import Text.Pandoc.Readers.Odt.Generic.XMLConverter

62+import Text.Pandoc.Readers.Odt.Generic.Fallible

63+import Text.Pandoc.Readers.Odt.Generic.Utils

64+

65+

66+--------------------------------------------------------------------------------

67+-- State

68+--------------------------------------------------------------------------------

69+

70+type Anchor = String

71+

72+data ReaderState

73+ = ReaderState { -- | A collection of styles read somewhere else.

74+ -- It is only queried here, not modified.

75+ styleSet :: Styles

76+ -- | A stack of the styles of parent elements.

77+ -- Used to look up inherited style properties.

78+ , styleTrace :: [Style]

79+ -- | Keeps track of the current depth in nested lists

80+ , currentListLevel :: ListLevel

81+ -- | Lists may provide their own style, but they don't have

82+ -- to. If they do not, the style of a parent list may be used

83+ -- or even a default list style from the paragraph style.

84+ -- This value keeps track of the closest list style there

85+ -- currently is.

86+ , currentListStyle :: Maybe ListStyle

87+ -- | A map from internal anchor names to "pretty" ones.

88+ -- The mapping is a purely cosmetic one.

89+ , bookmarkAnchors :: M.Map Anchor Anchor

90+

91+-- , sequences

92+-- , trackedChangeIDs

93+ }

94+ deriving ( Show )

95+

96+readerState :: Styles -> ReaderState

97+readerState styles = ReaderState styles [] 0 Nothing M.empty

98+

99+--

100+pushStyle' :: Style -> ReaderState -> ReaderState

101+pushStyle' style state = state { styleTrace = style : styleTrace state }

102+

103+--

104+popStyle' :: ReaderState -> ReaderState

105+popStyle' state = case styleTrace state of

106+ _:trace -> state { styleTrace = trace }

107+ _ -> state

108+

109+--

110+modifyListLevel :: (ListLevel -> ListLevel) -> (ReaderState -> ReaderState)

111+modifyListLevel f state = state { currentListLevel = f (currentListLevel state) }

112+

113+--

114+shiftListLevel :: ListLevel -> (ReaderState -> ReaderState)

115+shiftListLevel diff = modifyListLevel (+ diff)

116+

117+--

118+swapCurrentListStyle :: Maybe ListStyle -> ReaderState

119+ -> (ReaderState, Maybe ListStyle)

120+swapCurrentListStyle mListStyle state = ( state { currentListStyle = mListStyle }

121+ , currentListStyle state

122+ )

123+

124+--

125+lookupPrettyAnchor :: Anchor -> ReaderState -> Maybe Anchor

126+lookupPrettyAnchor anchor ReaderState{..} = M.lookup anchor bookmarkAnchors

127+

128+--

129+putPrettyAnchor :: Anchor -> Anchor -> ReaderState -> ReaderState

130+putPrettyAnchor ugly pretty state@ReaderState{..}

131+ = state { bookmarkAnchors = M.insert ugly pretty bookmarkAnchors }

132+

133+--

134+usedAnchors :: ReaderState -> [Anchor]

135+usedAnchors ReaderState{..} = M.elems bookmarkAnchors

136+

137+--------------------------------------------------------------------------------

138+-- Reader type and associated tools

139+--------------------------------------------------------------------------------

140+

141+type OdtReader a b = XMLReader ReaderState a b

142+

143+type OdtReaderSafe a b = XMLReaderSafe ReaderState a b

144+

145+-- | Extract something from the styles

146+fromStyles :: (a -> Styles -> b) -> OdtReaderSafe a b

147+fromStyles f = keepingTheValue

148+ (getExtraState >>^ styleSet)

149+ >>§ f

150+

151+--

152+getStyleByName :: OdtReader StyleName Style

153+getStyleByName = fromStyles lookupStyle >>^ maybeToChoice

154+

155+--

156+findStyleFamily :: OdtReader Style StyleFamily

157+findStyleFamily = fromStyles getStyleFamily >>^ maybeToChoice

158+

159+--

160+lookupListStyle :: OdtReader StyleName ListStyle

161+lookupListStyle = fromStyles lookupListStyleByName >>^ maybeToChoice

162+

163+--

164+switchCurrentListStyle :: OdtReaderSafe (Maybe ListStyle) (Maybe ListStyle)

165+switchCurrentListStyle = keepingTheValue getExtraState

166+ >>§ swapCurrentListStyle

167+ >>> first setExtraState

168+ >>^ snd

169+

170+--

171+pushStyle :: OdtReaderSafe Style Style

172+pushStyle = keepingTheValue (

173+ ( keepingTheValue getExtraState

174+ >>§ pushStyle'

175+ )

176+ >>> setExtraState

177+ )

178+ >>^ fst

179+

180+--

181+popStyle :: OdtReaderSafe x x

182+popStyle = keepingTheValue (

183+ getExtraState

184+ >>> arr popStyle'

185+ >>> setExtraState

186+ )

187+ >>^ fst

188+

189+--

190+getCurrentListLevel :: OdtReaderSafe _x ListLevel

191+getCurrentListLevel = getExtraState >>^ currentListLevel

192+

193+

194+type AnchorPrefix = String

195+

196+-- | An adaptation of 'uniqueIdent' from "Text.Pandoc.Shared" that generates a

197+-- unique identifier but without assuming that the id should be for a header.

198+-- Second argument is a list of already used identifiers.

199+uniqueIdentFrom :: AnchorPrefix -> [Anchor] -> Anchor

200+uniqueIdentFrom baseIdent usedIdents =

201+ let numIdent n = baseIdent ++ "-" ++ show n

202+ in if baseIdent `elem` usedIdents

203+ then case find (\x -> numIdent x `notElem` usedIdents) ([1..60000] :: [Int]) of

204+ Just x -> numIdent x

205+ Nothing -> baseIdent -- if we have more than 60,000, allow repeats

206+ else baseIdent

207+

208+-- | First argument: basis for a new "pretty" anchor if none exists yet

209+-- Second argument: a key ("ugly" anchor)

210+-- Returns: saved "pretty" anchor or created new one

211+getPrettyAnchor :: OdtReaderSafe (AnchorPrefix, Anchor) Anchor

212+getPrettyAnchor = proc (baseIdent, uglyAnchor) -> do

213+ state <- getExtraState -< ()

214+ case lookupPrettyAnchor uglyAnchor state of

215+ Just prettyAnchor -> returnA -< prettyAnchor

216+ Nothing -> do

217+ let newPretty = uniqueIdentFrom baseIdent (usedAnchors state)

218+ modifyExtraState (putPrettyAnchor uglyAnchor newPretty) -<< newPretty

219+

220+-- | Input: basis for a new header anchor

221+-- Ouput: saved new anchor

222+getHeaderAnchor :: OdtReaderSafe Inlines Anchor

223+getHeaderAnchor = proc title -> do

224+ state <- getExtraState -< ()

225+ let anchor = uniqueIdent (toList title) (usedAnchors state)

226+ modifyExtraState (putPrettyAnchor anchor anchor) -<< anchor

227+

228+

229+--------------------------------------------------------------------------------

230+-- Working with styles

231+--------------------------------------------------------------------------------

232+

233+--

234+readStyleByName :: OdtReader _x Style

235+readStyleByName = findAttr NsText "style-name" >>? getStyleByName

236+

237+--

238+isStyleToTrace :: OdtReader Style Bool

239+isStyleToTrace = findStyleFamily >>?^ (==FaText)

240+

241+--

242+withNewStyle :: OdtReaderSafe x Inlines -> OdtReaderSafe x Inlines

243+withNewStyle a = proc x -> do

244+ fStyle <- readStyleByName -< ()

245+ case fStyle of

246+ Right style -> do

247+ mFamily <- arr styleFamily -< style

248+ fTextProps <- arr ( maybeToChoice

249+ . textProperties

250+ . styleProperties

251+ ) -< style

252+ case fTextProps of

253+ Right textProps -> do

254+ state <- getExtraState -< ()

255+ let triple = (state, textProps, mFamily)

256+ modifier <- arr modifierFromStyleDiff -< triple

257+ fShouldTrace <- isStyleToTrace -< style

258+ case fShouldTrace of

259+ Right shouldTrace -> do

260+ if shouldTrace

261+ then do

262+ pushStyle -< style

263+ inlines <- a -< x

264+ popStyle -< ()

265+ arr modifier -<< inlines

266+ else

267+ -- In case anything goes wrong

268+ a -< x

269+ Left _ -> a -< x

270+ Left _ -> a -< x

271+ Left _ -> a -< x

272+

273+

274+type PropertyTriple = (ReaderState, TextProperties, Maybe StyleFamily)

275+type InlineModifier = Inlines -> Inlines

276+

277+-- | Given data about the local style changes, calculates how to modify

278+-- an instance of 'Inlines'

279+modifierFromStyleDiff :: PropertyTriple -> InlineModifier

280+modifierFromStyleDiff propertyTriple =

281+ composition $

282+ (getVPosModifier propertyTriple)

283+ : map (first ($ propertyTriple) >>> ifThen_else ignore)

284+ [ (hasEmphChanged , emph )

285+ , (hasChanged isStrong , strong )

286+ , (hasChanged strikethrough , strikeout )

287+ ]

288+ where

289+ ifThen_else else' (if',then') = if if' then then' else else'

290+

291+ ignore = id :: InlineModifier

292+

293+ getVPosModifier :: PropertyTriple -> InlineModifier

294+ getVPosModifier triple@(_,textProps,_) =

295+ let getVPos = Just . verticalPosition

296+ in case lookupPreviousValueM getVPos triple of

297+ Nothing -> ignore

298+ Just oldVPos -> getVPosModifier' (oldVPos,verticalPosition textProps)

299+

300+ getVPosModifier' (oldVPos , newVPos ) | oldVPos == newVPos = ignore

301+ getVPosModifier' ( _ , VPosSub ) = subscript

302+ getVPosModifier' ( _ , VPosSuper ) = superscript

303+ getVPosModifier' ( _ , _ ) = ignore

304+

305+ hasEmphChanged :: PropertyTriple -> Bool

306+ hasEmphChanged = swing any [ hasChanged isEmphasised

307+ , hasChangedM pitch

308+ , hasChanged underline

309+ ]

310+

311+ hasChanged property triple@(_, property -> newProperty, _) =

312+ maybe True (/=newProperty) (lookupPreviousValue property triple)

313+

314+ hasChangedM property triple@(_, textProps,_) =

315+ fromMaybe False $ (/=) <$> property textProps <*> lookupPreviousValueM property triple

316+

317+ lookupPreviousValue f = lookupPreviousStyleValue ((fmap f).textProperties)

318+

319+ lookupPreviousValueM f = lookupPreviousStyleValue ((f =<<).textProperties)

320+

321+ lookupPreviousStyleValue f (ReaderState{..},_,mFamily)

322+ = ( findBy f $ extendedStylePropertyChain styleTrace styleSet )

323+ <|> ( f =<< fmap (lookupDefaultStyle' styleSet) mFamily )

324+

325+

326+type ParaModifier = Blocks -> Blocks

327+

328+_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_ :: Int

329+_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_ :: Int

330+_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_ = 5

331+_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_ = 5

332+

333+-- | Returns either 'id' or 'blockQuote' depending on the current indentation

334+getParaModifier :: Style -> ParaModifier

335+getParaModifier Style{..} | Just props <- paraProperties styleProperties

336+ , isBlockQuote (indentation props)

337+ (margin_left props)

338+ = blockQuote

339+ | otherwise

340+ = id

341+ where

342+ isBlockQuote mIndent mMargin

343+ | LengthValueMM indent <- mIndent

344+ , indent > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_

345+ = True

346+ | LengthValueMM margin <- mMargin

347+ , margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_

348+ = True

349+ | LengthValueMM indent <- mIndent

350+ , LengthValueMM margin <- mMargin

351+ = indent + margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_

352+

353+ | PercentValue indent <- mIndent

354+ , indent > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_

355+ = True

356+ | PercentValue margin <- mMargin

357+ , margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_

358+ = True

359+ | PercentValue indent <- mIndent

360+ , PercentValue margin <- mMargin

361+ = indent + margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_

362+

363+ | otherwise

364+ = False

365+

366+--

367+constructPara :: OdtReaderSafe Blocks Blocks -> OdtReaderSafe Blocks Blocks

368+constructPara reader = proc blocks -> do

369+ fStyle <- readStyleByName -< blocks

370+ case fStyle of

371+ Left _ -> reader -< blocks

372+ Right style -> do

373+ let modifier = getParaModifier style

374+ blocks' <- reader -< blocks

375+ arr modifier -<< blocks'

376+

377+

378+

379+type ListConstructor = [Blocks] -> Blocks

380+

381+getListConstructor :: ListLevelStyle -> ListConstructor

382+getListConstructor ListLevelStyle{..} =

383+ case listLevelType of

384+ LltBullet -> bulletList

385+ LltImage -> bulletList

386+ LltNumbered -> let listNumberStyle = toListNumberStyle listItemFormat

387+ listNumberDelim = toListNumberDelim listItemPrefix

388+ listItemSuffix

389+ in orderedListWith (1, listNumberStyle, listNumberDelim)

390+ where

391+ toListNumberStyle LinfNone = DefaultStyle

392+ toListNumberStyle LinfNumber = Decimal

393+ toListNumberStyle LinfRomanLC = LowerRoman

394+ toListNumberStyle LinfRomanUC = UpperRoman

395+ toListNumberStyle LinfAlphaLC = LowerAlpha

396+ toListNumberStyle LinfAlphaUC = UpperAlpha

397+ toListNumberStyle (LinfString _) = Example

398+

399+ toListNumberDelim Nothing (Just ".") = Period

400+ toListNumberDelim (Just "" ) (Just ".") = Period

401+ toListNumberDelim Nothing (Just ")") = OneParen

402+ toListNumberDelim (Just "" ) (Just ")") = OneParen

403+ toListNumberDelim (Just "(") (Just ")") = TwoParens

404+ toListNumberDelim _ _ = DefaultDelim

405+

406+

407+-- | Determines which style to use for a list, which level to use of that

408+-- style, and which type of list to create as a result of this information.

409+-- Then prepares the state for eventual child lists and constructs the list from

410+-- the results.

411+-- Two main cases are handled: The list may provide its own style or it may

412+-- rely on a parent list's style. I the former case the current style in the

413+-- state must be switched before and after the call to the child converter

414+-- while in the latter the child converter can be called directly.

415+-- If anything goes wrong, a default ordered-list-constructor is used.

416+constructList :: OdtReaderSafe x [Blocks] -> OdtReaderSafe x Blocks

417+constructList reader = proc x -> do

418+ modifyExtraState (shiftListLevel 1) -< ()

419+ listLevel <- getCurrentListLevel -< ()

420+ fStyleName <- findAttr NsText "style-name" -< ()

421+ case fStyleName of

422+ Right styleName -> do

423+ fListStyle <- lookupListStyle -< styleName

424+ case fListStyle of

425+ Right listStyle -> do

426+ fLLS <- arr (uncurry getListLevelStyle) -< (listLevel,listStyle)

427+ case fLLS of

428+ Just listLevelStyle -> do

429+ oldListStyle <- switchCurrentListStyle -< Just listStyle

430+ blocks <- constructListWith listLevelStyle -<< x

431+ switchCurrentListStyle -< oldListStyle

432+ returnA -< blocks

433+ Nothing -> constructOrderedList -< x

434+ Left _ -> constructOrderedList -< x

435+ Left _ -> do

436+ state <- getExtraState -< ()

437+ mListStyle <- arr currentListStyle -< state

438+ case mListStyle of

439+ Just listStyle -> do

440+ fLLS <- arr (uncurry getListLevelStyle) -< (listLevel,listStyle)

441+ case fLLS of

442+ Just listLevelStyle -> constructListWith listLevelStyle -<< x

443+ Nothing -> constructOrderedList -< x

444+ Nothing -> constructOrderedList -< x

445+ where

446+ constructOrderedList =

447+ reader

448+ >>> modifyExtraState (shiftListLevel (-1))

449+ >>^ orderedList

450+ constructListWith listLevelStyle =

451+ reader

452+ >>> getListConstructor listLevelStyle

453+ ^>> modifyExtraState (shiftListLevel (-1))

454+

455+--------------------------------------------------------------------------------

456+-- Readers

457+--------------------------------------------------------------------------------

458+

459+type ElementMatcher result = (Namespace, ElementName, OdtReader result result)

460+

461+type InlineMatcher = ElementMatcher Inlines

462+

463+type BlockMatcher = ElementMatcher Blocks

464+

465+

466+--

467+matchingElement :: (Monoid e)

468+ => Namespace -> ElementName

469+ -> OdtReaderSafe e e

470+ -> ElementMatcher e

471+matchingElement ns name reader = (ns, name, asResultAccumulator reader)

472+ where

473+ asResultAccumulator :: (ArrowChoice a, Monoid m) => a m m -> a m (Fallible m)

474+ asResultAccumulator a = liftAsSuccess $ keepingTheValue a >>§ (<>)

475+

476+--

477+matchChildContent' :: (Monoid result)

478+ => [ElementMatcher result]

479+ -> OdtReaderSafe _x result

480+matchChildContent' ls = returnV mempty >>> matchContent' ls

481+

482+--

483+matchChildContent :: (Monoid result)

484+ => [ElementMatcher result]

485+ -> OdtReaderSafe (result, XML.Content) result

486+ -> OdtReaderSafe _x result

487+matchChildContent ls fallback = returnV mempty >>> matchContent ls fallback

488+

489+

490+--------------------------------------------

491+-- Matchers

492+--------------------------------------------

493+

494+----------------------

495+-- Basics

496+----------------------

497+

498+--

499+-- | Open Document allows several consecutive spaces if they are marked up

500+read_plain_text :: OdtReaderSafe (Inlines, XML.Content) Inlines

501+read_plain_text = fst ^&&& read_plain_text' >>§ recover

502+ where

503+ -- fallible version

504+ read_plain_text' :: OdtReader (Inlines, XML.Content) Inlines

505+ read_plain_text' = ( second ( arr extractText )

506+ >>^ spreadChoice >>?! second text

507+ )

508+ >>?§ (<>)

509+ --

510+ extractText :: XML.Content -> Fallible String

511+ extractText (XML.Text cData) = succeedWith (XML.cdData cData)

512+ extractText _ = failEmpty

513+

514+

515+-- specifically. I honor that, although the current implementation of '(<>)'

516+-- for 'Inlines' in "Text.Pandoc.Builder" will collaps them agein.

517+-- The rational is to be prepared for future modifications.

518+read_spaces :: InlineMatcher

519+read_spaces = matchingElement NsText "s" (

520+ readAttrWithDefault NsText "c" 1 -- how many spaces?

521+ >>^ fromList.(`replicate` Space)

522+ )

523+--

524+read_line_break :: InlineMatcher

525+read_line_break = matchingElement NsText "line-break"

526+ $ returnV linebreak

527+

528+--

529+read_span :: InlineMatcher

530+read_span = matchingElement NsText "span"

531+ $ withNewStyle

532+ $ matchChildContent [ read_span

533+ , read_spaces

534+ , read_line_break

535+ , read_link

536+ , read_note

537+ , read_citation

538+ , read_bookmark

539+ , read_bookmark_start

540+ , read_reference_start

541+ , read_bookmark_ref

542+ , read_reference_ref

543+ ] read_plain_text

544+

545+--

546+read_paragraph :: BlockMatcher

547+read_paragraph = matchingElement NsText "p"

548+ $ constructPara

549+ $ liftA para

550+ $ withNewStyle

551+ $ matchChildContent [ read_span

552+ , read_spaces

553+ , read_line_break

554+ , read_link

555+ , read_note

556+ , read_citation

557+ , read_bookmark

558+ , read_bookmark_start

559+ , read_reference_start

560+ , read_bookmark_ref

561+ , read_reference_ref

562+ ] read_plain_text

563+

564+

565+----------------------

566+-- Headers

567+----------------------

568+

569+--

570+read_header :: BlockMatcher

571+read_header = matchingElement NsText "h"

572+ $ proc blocks -> do

573+ level <- ( readAttrWithDefault NsText "outline-level" 1

574+ ) -< blocks

575+ children <- ( matchChildContent [ read_span

576+ , read_spaces

577+ , read_line_break

578+ , read_link

579+ , read_note

580+ , read_citation

581+ , read_bookmark

582+ , read_bookmark_start

583+ , read_reference_start

584+ , read_bookmark_ref

585+ , read_reference_ref

586+ ] read_plain_text

587+ ) -< blocks

588+ anchor <- getHeaderAnchor -< children

589+ let idAttr = (anchor, [], []) -- no classes, no key-value pairs

590+ arr (uncurry3 headerWith) -< (idAttr, level, children)

591+

592+----------------------

593+-- Lists

594+----------------------

595+

596+--

597+read_list :: BlockMatcher

598+read_list = matchingElement NsText "list"

599+-- $ withIncreasedListLevel

600+ $ constructList

601+-- $ liftA bulletList

602+ $ matchChildContent' [ read_list_item

603+ ]

604+--

605+read_list_item :: ElementMatcher [Blocks]

606+read_list_item = matchingElement NsText "list-item"

607+ $ liftA (compactify'.(:[]))

608+ ( matchChildContent' [ read_paragraph

609+ , read_header

610+ , read_list

611+ ]

612+ )

613+

614+

615+----------------------

616+-- Links

617+----------------------

618+

619+read_link :: InlineMatcher

620+read_link = matchingElement NsText "a"

621+ $ liftA3 link

622+ ( findAttrWithDefault NsXLink "href" "" )

623+ ( findAttrWithDefault NsOffice "title" "" )

624+ ( matchChildContent [ read_span

625+ , read_note

626+ , read_citation

627+ , read_bookmark

628+ , read_bookmark_start

629+ , read_reference_start

630+ , read_bookmark_ref

631+ , read_reference_ref

632+ ] read_plain_text )

633+

634+

635+-------------------------

636+-- Footnotes

637+-------------------------

638+

639+read_note :: InlineMatcher

640+read_note = matchingElement NsText "note"

641+ $ liftA note

642+ $ matchChildContent' [ read_note_body ]

643+

644+read_note_body :: BlockMatcher

645+read_note_body = matchingElement NsText "note-body"

646+ $ matchChildContent' [ read_paragraph ]

647+

648+-------------------------

649+-- Citations

650+-------------------------

651+

652+read_citation :: InlineMatcher

653+read_citation = matchingElement NsText "bibliography-mark"

654+ $ liftA2 cite

655+ ( liftA2 makeCitation

656+ ( findAttrWithDefault NsText "identifier" "" )

657+ ( readAttrWithDefault NsText "number" 0 )

658+ )

659+ ( matchChildContent [] read_plain_text )

660+ where

661+ makeCitation :: String -> Int -> [Citation]

662+ makeCitation citeId num = [Citation citeId [] [] NormalCitation num 0]

663+

664+

665+----------------------

666+-- Tables

667+----------------------

668+

669+--

670+read_table :: BlockMatcher

671+read_table = matchingElement NsTable "table"

672+ $ liftA (simpleTable [])

673+ $ matchChildContent' [ read_table_row

674+ ]

675+

676+--

677+read_table_row :: ElementMatcher [[Blocks]]

678+read_table_row = matchingElement NsTable "table-row"

679+ $ liftA (:[])

680+ $ matchChildContent' [ read_table_cell

681+ ]

682+

683+--

684+read_table_cell :: ElementMatcher [Blocks]

685+read_table_cell = matchingElement NsTable "table-cell"

686+ $ liftA (compactify'.(:[]))

687+ $ matchChildContent' [ read_paragraph

688+ ]

689+

690+----------------------

691+-- Internal links

692+----------------------

693+

694+_ANCHOR_PREFIX_ :: String

695+_ANCHOR_PREFIX_ = "anchor"

696+

697+--

698+readAnchorAttr :: OdtReader _x Anchor

699+readAnchorAttr = findAttr NsText "name"

700+

701+-- | Beware: may fail

702+findAnchorName :: OdtReader AnchorPrefix Anchor

703+findAnchorName = ( keepingTheValue readAnchorAttr

704+ >>^ spreadChoice

705+ ) >>?! getPrettyAnchor

706+

707+

708+--

709+maybeAddAnchorFrom :: OdtReader Inlines AnchorPrefix

710+ -> OdtReaderSafe Inlines Inlines

711+maybeAddAnchorFrom anchorReader =

712+ keepingTheValue (anchorReader >>? findAnchorName >>?^ toAnchorElem)

713+ >>>

714+ proc (inlines, fAnchorElem) -> do

715+ case fAnchorElem of

716+ Right anchorElem ->

717+ arr (anchorElem <>) -<< inlines

718+ Left _ -> returnA -< inlines

719+ where

720+ toAnchorElem :: Anchor -> Inlines

721+ toAnchorElem anchorID = spanWith (anchorID, [], []) mempty

722+ -- no classes, no key-value pairs

723+

724+--

725+read_bookmark :: InlineMatcher

726+read_bookmark = matchingElement NsText "bookmark"

727+ $ maybeAddAnchorFrom (liftAsSuccess $ returnV _ANCHOR_PREFIX_)

728+

729+--

730+read_bookmark_start :: InlineMatcher

731+read_bookmark_start = matchingElement NsText "bookmark-start"

732+ $ maybeAddAnchorFrom (liftAsSuccess $ returnV _ANCHOR_PREFIX_)

733+

734+--

735+read_reference_start :: InlineMatcher

736+read_reference_start = matchingElement NsText "reference-mark-start"

737+ $ maybeAddAnchorFrom readAnchorAttr

738+

739+-- | Beware: may fail

740+findAnchorRef :: OdtReader _x Anchor

741+findAnchorRef = ( findAttr NsText "ref-name"

742+ >>?^ (_ANCHOR_PREFIX_,)

743+ ) >>?! getPrettyAnchor

744+

745+

746+--

747+maybeInAnchorRef :: OdtReaderSafe Inlines Inlines

748+maybeInAnchorRef = proc inlines -> do

749+ fRef <- findAnchorRef -< ()

750+ case fRef of

751+ Right anchor ->

752+ arr (toAnchorRef anchor) -<< inlines

753+ Left _ -> returnA -< inlines

754+ where

755+ toAnchorRef :: Anchor -> Inlines -> Inlines

756+ toAnchorRef anchor = link ('#':anchor) "" -- no title

757+

758+--

759+read_bookmark_ref :: InlineMatcher

760+read_bookmark_ref = matchingElement NsText "bookmark-ref"

761+ $ maybeInAnchorRef

762+ <<< matchChildContent [] read_plain_text

763+

764+--

765+read_reference_ref :: InlineMatcher

766+read_reference_ref = matchingElement NsText "reference-ref"

767+ $ maybeInAnchorRef

768+ <<< matchChildContent [] read_plain_text

769+

770+

771+----------------------

772+-- Entry point

773+----------------------

774+

775+--read_plain_content :: OdtReaderSafe _x Inlines

776+--read_plain_content = strContent >>^ text

777+

778+read_text :: OdtReaderSafe _x Pandoc

779+read_text = matchChildContent' [ read_header

780+ , read_paragraph

781+ , read_list

782+ , read_table

783+ ]

784+ >>^ doc

785+

786+read_body :: OdtReader _x Pandoc

787+read_body = executeIn NsOffice "body"

788+ $ executeIn NsOffice "text"

789+ $ liftAsSuccess read_text

790+

src/Text/Pandoc/Readers/Odt/Generic/Fallible.hsnew file+260

@@ -0,0 +1,260 @@

1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3+{-

6+This program is free software; you can redistribute it and/or modify

7+it under the terms of the GNU General Public License as published by

8+the Free Software Foundation; either version 2 of the License, or

9+(at your option) any later version.

10+

11+This program is distributed in the hope that it will be useful,

12+but WITHOUT ANY WARRANTY; without even the implied warranty of

13+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

14+GNU General Public License for more details.

15+

16+You should have received a copy of the GNU General Public License

17+along with this program; if not, write to the Free Software

18+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

19+-}

20+

21+{- |

22+ Module : Text.Pandoc.Readers.Odt.Generic.Fallible

24+ License : GNU GPL, version 2 or above

25+

26+ Maintainer : Martin Linnemann <theCodingMarlin@googlemail.com>

27+ Stability : alpha

28+ Portability : portable

29+

30+Data types and utilities representing failure. Most of it is based on the

31+"Either" type in its usual configuration (left represents failure).

32+

33+In most cases, the failure type is implied or required to be a "Monoid".

34+

35+The choice of "Either" instead of a custom type makes it easier to write

36+compatible instances of "ArrowChoice".

37+-}

38+

39+-- We export everything

40+module Text.Pandoc.Readers.Odt.Generic.Fallible where

41+

42+import Control.Applicative

43+import Control.Monad

44+

45+import qualified Data.Foldable as F

46+import Data.Monoid

47+

48+-- | Default for now. Will probably become a class at some point.

49+type Failure = ()

50+

51+type Fallible a = Either Failure a

52+

53+

54+-- | False -> Left (), True -> Right ()

55+boolToEither :: Bool -> Fallible ()

56+boolToEither False = Left ()

57+boolToEither True = Right ()

58+

59+-- | False -> Left (), True -> Right ()

60+boolToChoice :: Bool -> Fallible ()

61+boolToChoice False = Left ()

62+boolToChoice True = Right ()

63+

64+--

65+maybeToEither :: Maybe a -> Fallible a

66+maybeToEither (Just a) = Right a

67+maybeToEither Nothing = Left ()

68+

69+--

70+eitherToMaybe :: Either _l a -> Maybe a

71+eitherToMaybe (Left _) = Nothing

72+eitherToMaybe (Right a) = Just a

73+

74+-- | > untagEither === either id id

75+untagEither :: Either a a -> a

76+untagEither (Left a) = a

77+untagEither (Right a) = a

78+

79+-- | > fromLeft f === either f id

80+fromLeft :: (a -> b) -> Either a b -> b

81+fromLeft f (Left a) = f a

82+fromLeft _ (Right b) = b

83+

84+-- | > fromRight f === either id f

85+fromRight :: (a -> b) -> Either b a -> b

86+fromRight _ (Left b) = b

87+fromRight f (Right a) = f a

88+

89+-- | > recover a === fromLeft (const a) === either (const a) id

90+recover :: a -> Either _f a -> a

91+recover a (Left _) = a

92+recover _ (Right a) = a

93+

94+-- | I would love to use 'fail'. Alas, 'Monad.fail'...

95+failWith :: failure -> Either failure _x

96+failWith f = Left f

97+

98+--

99+failEmpty :: (Monoid failure) => Either failure _x

100+failEmpty = failWith mempty

101+

102+--

103+succeedWith :: a -> Either _x a

104+succeedWith = Right

105+

106+--

107+collapseEither :: Either failure (Either failure x)

108+ -> Either failure x

109+collapseEither (Left f ) = Left f

110+collapseEither (Right (Left f)) = Left f

111+collapseEither (Right (Right x)) = Right x

112+

113+-- | If either of the values represents an error, the result is a

114+-- (possibly combined) error. If both values represent a success,

115+-- both are returned.

116+chooseMin :: (Monoid a) => Either a b -> Either a b' -> Either a (b,b')

117+chooseMin = chooseMinWith (,)

118+

119+-- | If either of the values represents an error, the result is a

120+-- (possibly combined) error. If both values represent a success,

121+-- a combination is returned.

122+chooseMinWith :: (Monoid a) => (b -> b' -> c)

123+ -> Either a b

124+ -> Either a b'

125+ -> Either a c

126+chooseMinWith (><) (Right a) (Right b) = Right $ a >< b

127+chooseMinWith _ (Left a) (Left b) = Left $ a <> b

128+chooseMinWith _ (Left a) _ = Left a

129+chooseMinWith _ _ (Left b) = Left b

130+

131+-- | If either of the values represents a non-error, the result is a

132+-- (possibly combined) non-error. If both values represent an error, an error

133+-- is returned.

134+chooseMax :: (Monoid a, Monoid b) => Either a b -> Either a b -> Either a b

135+chooseMax = chooseMaxWith (<>)

136+

137+-- | If either of the values represents a non-error, the result is a

138+-- (possibly combined) non-error. If both values represent an error, an error

139+-- is returned.

140+chooseMaxWith :: (Monoid a) => (b -> b -> b)

141+ -> Either a b

142+ -> Either a b

143+ -> Either a b

144+chooseMaxWith (><) (Right a) (Right b) = Right $ a >< b

145+chooseMaxWith _ (Left a) (Left b) = Left $ a <> b

146+chooseMaxWith _ (Right a) _ = Right a

147+chooseMaxWith _ _ (Right b) = Right b

148+

149+

150+-- | Class of containers that can escalate contained 'Either's.

151+-- The word "Vector" is meant in the sense of a disease transmitter.

152+class ChoiceVector v where

153+ spreadChoice :: v (Either f a) -> Either f (v a)

154+

155+-- Let's do a few examples first

156+

157+instance ChoiceVector Maybe where

158+ spreadChoice (Just (Left f)) = Left f

159+ spreadChoice (Just (Right x)) = Right (Just x)

160+ spreadChoice Nothing = Right Nothing

161+

162+instance ChoiceVector (Either l) where

163+ spreadChoice (Right (Left f)) = Left f

164+ spreadChoice (Right (Right x)) = Right (Right x)

165+ spreadChoice (Left x ) = Right (Left x)

166+

167+instance ChoiceVector ((,) a) where

168+ spreadChoice (_, Left f) = Left f

169+ spreadChoice (x, Right y) = Right (x,y)

170+ -- Wasn't there a newtype somewhere with the elements flipped?

171+

172+--

173+-- More instances later, first some discussion.

174+--

175+-- I'll have to freshen up on type system details to see how (or if) to do

176+-- something like

177+--

178+-- > instance (ChoiceVector a, ChoiceVector b) => ChoiceVector (a b) where

179+-- > :

180+--

181+-- But maybe it would be even better to use something like

182+--

183+-- > class ChoiceVector v v' f | v -> v' f where

184+-- > spreadChoice :: v -> Either f v'

185+--

186+-- That way, more places in @v@ could spread the cheer, e.g.:

187+--

188+-- As before:

189+-- -- ( a , Either f b) (a , b) f

190+-- > instance ChoiceVector ((,) a (Either f b)) ((,) a b) f where

191+-- > spreadChoice (_, Left f) = Left f

192+-- > spreadChoice (a, Right b) = Right (a,b)

193+--

194+-- But also:

195+-- -- ( Either f a , b) (a , b) f

196+-- > instance ChoiceVector ((,) (Either f a) b) ((,) a b) f where

197+-- > spreadChoice (Right a,b) = Right (a,b)

198+-- > spreadChoice (Left f,_) = Left f

199+--

200+-- And maybe even:

201+-- -- ( Either f a , Either f b) (a , b) f

202+-- > instance ChoiceVector ((,) (Either f a) (Either f b)) ((,) a b) f where

203+-- > spreadChoice (Right a , Right b) = Right (a,b)

204+-- > spreadChoice (Left f , _ ) = Left f

205+-- > spreadChoice ( _ , Left f) = Left f

206+--

207+-- Of course that would lead to a lot of overlapping instances...

208+-- But I can't think of a different way. A selector function might help,

209+-- but not even a "Data.Traversable" is powerful enough for that.

210+-- But maybe someone has already solved all this with a lens library.

211+--

212+-- Well, it's an interesting academic question. But for practical purposes,

213+-- I have more than enough right now.

214+

215+instance ChoiceVector ((,,) a b) where

216+ spreadChoice (_,_, Left f) = Left f

217+ spreadChoice (a,b, Right x) = Right (a,b,x)

218+

219+instance ChoiceVector ((,,,) a b c) where

220+ spreadChoice (_,_,_, Left f) = Left f

221+ spreadChoice (a,b,c, Right x) = Right (a,b,c,x)

222+

223+instance ChoiceVector ((,,,,) a b c d) where

224+ spreadChoice (_,_,_,_, Left f) = Left f

225+ spreadChoice (a,b,c,d, Right x) = Right (a,b,c,d,x)

226+

227+instance ChoiceVector (Const a) where

228+ spreadChoice (Const c) = Right (Const c) -- need to repackage because of implicit types

229+

230+-- | Fails on the first error

231+instance ChoiceVector [] where

232+ spreadChoice = sequence -- using the monad instance of Either.

233+ -- Could be generalized to "Data.Traversable" - but why play

234+ -- with UndecidableInstances unless this is really needed.

235+

236+-- | Wrapper for a list. While the normal list instance of 'ChoiceVector'

237+-- fails whenever it can, this type will never fail.

238+newtype SuccessList a = SuccessList { collectNonFailing :: [a] }

239+ deriving ( Eq, Ord, Show )

240+

241+instance ChoiceVector SuccessList where

242+ spreadChoice = Right . SuccessList . (foldr unTagRight []) . collectNonFailing

243+ where unTagRight (Right x) = (x:)

244+ unTagRight _ = id

245+

246+-- | Like 'catMaybes', but for 'Either'.

247+collectRights :: [Either _l r] -> [r]

248+collectRights = collectNonFailing . untag . spreadChoice . SuccessList

249+ where untag = fromLeft (error "Unexpected Left")

250+

251+-- | A version of 'collectRights' generalized to other containers. The

252+-- container must be both "reducible" and "buildable". Most general containers

253+-- should fullfill these requirements, but there is no single typeclass

254+-- (that I know of) for that.

255+-- Therefore, they are split between 'Foldable' and 'MonadPlus'.

256+-- (Note that 'Data.Traversable.Traversable' alone would not be enough, either.)

257+collectRightsF :: (F.Foldable c, MonadPlus c) => c (Either _l r) -> c r

258+collectRightsF = F.foldr unTagRight mzero

259+ where unTagRight (Right x) = mplus $ return x

260+ unTagRight _ = id

src/Text/Pandoc/Readers/Odt/Generic/Namespaces.hsnew file+62

@@ -0,0 +1,62 @@

1+{-

4+This program is free software; you can redistribute it and/or modify

5+it under the terms of the GNU General Public License as published by

6+the Free Software Foundation; either version 2 of the License, or

7+(at your option) any later version.

9+This program is distributed in the hope that it will be useful,

10+but WITHOUT ANY WARRANTY; without even the implied warranty of

11+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

12+GNU General Public License for more details.

13+

14+You should have received a copy of the GNU General Public License

15+along with this program; if not, write to the Free Software

16+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

17+-}

18+

19+{- |

20+ Module : Text.Pandoc.Readers.Odt.Generic.Namespaces

22+ License : GNU GPL, version 2 or above

23+

24+ Maintainer : Martin Linnemann <theCodingMarlin@googlemail.com>

25+ Stability : alpha

26+ Portability : portable

27+

28+A class containing a set of namespace identifiers. Used to convert between

29+typesafe Haskell namespace identifiers and unsafe "real world" namespaces.

30+-}

31+

32+module Text.Pandoc.Readers.Odt.Generic.Namespaces where

33+

34+import qualified Data.Map as M

35+

36+--

37+type NameSpaceIRI = String

38+

39+--

40+type NameSpaceIRIs nsID = M.Map nsID NameSpaceIRI

41+

42+--

43+class (Eq nsID, Ord nsID) => NameSpaceID nsID where

44+

45+ -- | Given a IRI, possibly update the map and return the id of the namespace.

46+ -- May fail if the namespace is unknown and the application does not

47+ -- allow unknown namespaces.

48+ getNamespaceID :: NameSpaceIRI

49+ -> NameSpaceIRIs nsID

50+ -> Maybe (NameSpaceIRIs nsID, nsID)

51+ -- | Given a namespace id, lookup its IRI. May be overriden for performance.

52+ getIRI :: nsID

53+ -> NameSpaceIRIs nsID

54+ -> Maybe NameSpaceIRI

55+ -- | The root element of an XML document has a namespace, too, and the

56+ -- "XML.Light-parser" is eager to remove the corresponding namespace

57+ -- attribute.

58+ -- As a result, at least this root namespace must be provided.

59+ getInitialIRImap :: NameSpaceIRIs nsID

60+

61+ getIRI = M.lookup

62+ getInitialIRImap = M.empty

src/Text/Pandoc/Readers/Odt/Generic/SetMap.hsnew file+48

@@ -0,0 +1,48 @@

1+{-

4+This program is free software; you can redistribute it and/or modify

5+it under the terms of the GNU General Public License as published by

6+the Free Software Foundation; either version 2 of the License, or

7+(at your option) any later version.

9+This program is distributed in the hope that it will be useful,

10+but WITHOUT ANY WARRANTY; without even the implied warranty of

11+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

12+GNU General Public License for more details.

13+

14+You should have received a copy of the GNU General Public License

15+along with this program; if not, write to the Free Software

16+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

17+-}

18+

19+{- |

20+ Module : Text.Pandoc.Readers.Odt.Generic.SetMap

22+ License : GNU GPL, version 2 or above

23+

24+ Maintainer : Martin Linnemann <theCodingMarlin@googlemail.com>

25+ Stability : alpha

26+ Portability : portable

27+

28+A map of values to sets of values.

29+-}

30+

31+module Text.Pandoc.Readers.Odt.Generic.SetMap where

32+

33+import qualified Data.Map as M

34+import qualified Data.Set as S

35+

36+type SetMap k v = M.Map k (S.Set v)

37+

38+empty :: SetMap k v

39+empty = M.empty

40+

41+fromList :: (Ord k, Ord v) => [(k,v)] -> SetMap k v

42+fromList = foldr (uncurry insert) empty

43+

44+insert :: (Ord k, Ord v) => k -> v -> SetMap k v -> SetMap k v

45+insert key value setMap = M.insertWith S.union key (S.singleton value) setMap

46+

47+union3 :: (Ord k) => SetMap k v -> SetMap k v -> SetMap k v -> SetMap k v

48+union3 sm1 sm2 sm3 = sm1 `M.union` sm2 `M.union` sm3

src/Text/Pandoc/Readers/Odt/Generic/Utils.hsnew file+171

@@ -0,0 +1,171 @@

1+{-# LANGUAGE TypeOperators #-}

2+{-# LANGUAGE TupleSections #-}

3+{-# LANGUAGE PatternGuards #-}

4+{-# LANGUAGE ViewPatterns #-}

6+{-

9+This program is free software; you can redistribute it and/or modify

10+it under the terms of the GNU General Public License as published by

11+the Free Software Foundation; either version 2 of the License, or

12+(at your option) any later version.

13+

14+This program is distributed in the hope that it will be useful,

15+but WITHOUT ANY WARRANTY; without even the implied warranty of

16+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

17+GNU General Public License for more details.

18+

19+You should have received a copy of the GNU General Public License

20+along with this program; if not, write to the Free Software

21+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

22+-}

23+

24+{- |

25+ Module : Text.Pandoc.Reader.Odt.Generic.Utils

27+ License : GNU GPL, version 2 or above

28+

29+ Maintainer : Martin Linnemann <theCodingMarlin@googlemail.com>

30+ Stability : alpha

31+ Portability : portable

32+

33+General utility functions for the odt reader.

34+-}

35+

36+module Text.Pandoc.Readers.Odt.Generic.Utils

37+( uncurry3

38+, uncurry4

39+, uncurry5

40+, uncurry6

41+, uncurry7

42+, uncurry8

43+, swap

44+, reverseComposition

45+, bool

46+, tryToRead

47+, Lookupable(..)

48+, readLookupables

49+, readLookupable

50+, readPercent

51+, findBy

52+, swing

53+, composition

54+) where

55+

56+import Control.Category ( Category, (>>>), (<<<) )

57+import qualified Control.Category as Cat ( id )

58+import Control.Monad ( msum )

59+

60+import qualified Data.Foldable as F ( Foldable, foldr )

61+import Data.Maybe

62+

63+

64+-- | Aequivalent to

65+-- > foldr (.) id

66+-- where '(.)' are 'id' are the ones from "Control.Category"

67+-- and 'foldr' is the one from "Data.Foldable".

68+-- The noun-form was chosen to be consistend with 'sum', 'product' etc

69+-- based on the discussion at

70+-- <https://groups.google.com/forum/#!topic/haskell-cafe/VkOZM1zaHOI>

71+-- (that I was not part of)

72+composition :: (Category cat, F.Foldable f) => f (cat a a) -> cat a a

73+composition = F.foldr (<<<) Cat.id

74+

75+-- | Aequivalent to

76+-- > foldr (flip (.)) id

77+-- where '(.)' are 'id' are the ones from "Control.Category"

78+-- and 'foldr' is the one from "Data.Foldable".

79+-- A reversed version of 'composition'.

80+reverseComposition :: (Category cat, F.Foldable f) => f (cat a a) -> cat a a

81+reverseComposition = F.foldr (>>>) Cat.id

82+

83+-- | 'Either' has 'either', 'Maybe' has 'maybe'. 'Bool' should have 'bool'.

84+-- Note that the first value is selected if the boolean value is 'False'.

85+-- That makes 'bool' consistent with the other two. Also, 'bool' now takes its

86+-- arguments in the exact opposite order compared to the normal if construct.

87+bool :: a -> a -> Bool -> a

88+bool x _ False = x

89+bool _ x True = x

90+

91+-- | This function often makes it possible to switch values with the functions

92+-- that are applied to them.

93+--

94+-- Examples:

95+-- > swing map :: [a -> b] -> a -> [b]

96+-- > swing any :: [a -> Bool] -> a -> Bool

97+-- > swing foldr :: b -> a -> [a -> b -> b] -> b

98+-- > swing scanr :: c -> a -> [a -> c -> c] -> c

99+-- > swing zipWith :: [a -> b -> c] -> a -> [b] -> [c]

100+-- > swing find :: [a -> Bool] -> a -> Maybe (a -> Bool)

101+--

102+-- Stolen from <https://wiki.haskell.org/Pointfree>

103+swing :: (((a -> b) -> b) -> c -> d) -> c -> a -> d

104+swing = flip.(.flip id)

105+-- swing f c a = f ($ a) c

106+

107+

108+-- | Alternative to 'read'/'reads'. The former of these throws errors

109+-- (nobody wants that) while the latter returns "to much" for simple purposes.

110+-- This function instead applies 'reads' and returns the first match (if any)

111+-- in a 'Maybe'.

112+tryToRead :: (Read r) => String -> Maybe r

113+tryToRead = reads >>> listToMaybe >>> fmap fst

114+

115+-- | A version of 'reads' that requires a '%' sign after the number

116+readPercent :: ReadS Int

117+readPercent s = [ (i,s') | (i , r ) <- reads s

118+ , ("%" , s') <- lex r

119+ ]

120+

121+-- | Data that can be looked up.

122+-- This is mostly a utility to read data with kind *.

123+class Lookupable a where

124+ lookupTable :: [(String, a)]

125+

126+-- | The idea is to use this function as if there was a declaration like

127+--

128+-- > instance (Lookupable a) => (Read a) where

129+-- > readsPrec _ = readLookupables

130+-- .

131+-- But including this code in this form would need UndecideableInstances.

132+-- That is a bad idea. Luckily 'readLookupable' (without the s at the end)

133+-- can be used directly in almost any case.

134+readLookupables :: (Lookupable a) => String -> [(a,String)]

135+readLookupables s = [ (a,rest) | (word,rest) <- lex s,

136+ let result = lookup word lookupTable,

137+ isJust result,

138+ let Just a = result

139+ ]

140+

141+-- | Very similar to a simple 'lookup' in the 'lookupTable', but with a lexer.

142+readLookupable :: (Lookupable a) => String -> Maybe a

143+readLookupable s = msum

144+ $ map ((`lookup` lookupTable).fst)

145+ $ lex s

146+

147+uncurry3 :: (a->b->c -> z) -> (a,b,c ) -> z

148+uncurry4 :: (a->b->c->d -> z) -> (a,b,c,d ) -> z

149+uncurry5 :: (a->b->c->d->e -> z) -> (a,b,c,d,e ) -> z

150+uncurry6 :: (a->b->c->d->e->f -> z) -> (a,b,c,d,e,f ) -> z

151+uncurry7 :: (a->b->c->d->e->f->g -> z) -> (a,b,c,d,e,f,g ) -> z

152+uncurry8 :: (a->b->c->d->e->f->g->h -> z) -> (a,b,c,d,e,f,g,h) -> z

153+

154+uncurry3 fun (a,b,c ) = fun a b c

155+uncurry4 fun (a,b,c,d ) = fun a b c d

156+uncurry5 fun (a,b,c,d,e ) = fun a b c d e

157+uncurry6 fun (a,b,c,d,e,f ) = fun a b c d e f

158+uncurry7 fun (a,b,c,d,e,f,g ) = fun a b c d e f g

159+uncurry8 fun (a,b,c,d,e,f,g,h) = fun a b c d e f g h

160+

161+swap :: (a,b) -> (b,a)

162+swap (a,b) = (b,a)

163+

164+-- | A version of "Data.List.find" that uses a converter to a Maybe instance.

165+-- The returned value is the first which the converter returns in a 'Just'

166+-- wrapper.

167+findBy :: (a -> Maybe b) -> [a] -> Maybe b

168+findBy _ [] = Nothing

169+findBy f ((f -> Just x):_ ) = Just x

170+findBy f ( _:xs) = findBy f xs

171+

src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hsnew file+1064

@@ -0,0 +1,1064 @@

1+{-# LANGUAGE Arrows #-}

2+{-# LANGUAGE TupleSections #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE PatternGuards #-}

5+{-# LANGUAGE RecordWildCards #-}

7+{-

10+This program is free software; you can redistribute it and/or modify

11+it under the terms of the GNU General Public License as published by

12+the Free Software Foundation; either version 2 of the License, or

13+(at your option) any later version.

14+

15+This program is distributed in the hope that it will be useful,

16+but WITHOUT ANY WARRANTY; without even the implied warranty of

17+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

18+GNU General Public License for more details.

19+

20+You should have received a copy of the GNU General Public License

21+along with this program; if not, write to the Free Software

22+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

23+-}

24+

25+{- |

26+ Module : Text.Pandoc.Readers.Odt.Generic.XMLConverter

28+ License : GNU GPL, version 2 or above

29+

30+ Maintainer : Martin Linnemann <theCodingMarlin@googlemail.com>

31+ Stability : alpha

32+ Portability : portable

33+

34+A generalized XML parser based on stateful arrows.

35+It might be sufficient to define this reader as a comonad, but there is

36+not a lot of use in trying.

37+-}

38+

39+module Text.Pandoc.Readers.Odt.Generic.XMLConverter

40+( ElementName

41+, XMLConverterState

42+, XMLConverter

43+, FallibleXMLConverter

44+, swapPosition

45+, runConverter

46+, runConverter''

47+, runConverter'

48+, runConverterF'

49+, runConverterF

50+, getCurrentElement

51+, getExtraState

52+, setExtraState

53+, modifyExtraState

54+, convertingExtraState

55+, producingExtraState

56+, lookupNSiri

57+, lookupNSprefix

58+, readNSattributes

59+, elemName

60+, elemNameIs

61+, strContent

62+, elContent

63+, currentElem

64+, currentElemIs

65+, expectElement

66+, elChildren

67+, findChildren

68+, filterChildren

69+, filterChildrenName

70+, findChild'

71+, findChild

72+, filterChild'

73+, filterChild

74+, filterChildName'

75+, filterChildName

76+, isSet

77+, isSet'

78+, isSetWithDefault

79+, hasAttrValueOf'

80+, failIfNotAttrValueOf

81+, isThatTheAttrValue

82+, searchAttrIn

83+, searchAttrWith

84+, searchAttr

85+, lookupAttr

86+, lookupAttr'

87+, lookupAttrWithDefault

88+, lookupDefaultingAttr

89+, findAttr'

90+, findAttr

91+, findAttrWithDefault

92+, readAttr

93+, readAttr'

94+, readAttrWithDefault

95+, getAttr

96+-- , (>/<)

97+-- , (?>/<)

98+, executeIn

99+, collectEvery

100+, withEveryL

101+, withEvery

102+, tryAll

103+, tryAll'

104+, IdXMLConverter

105+, MaybeEConverter

106+, ElementMatchConverter

107+, MaybeCConverter

108+, ContentMatchConverter

109+, makeMatcherE

110+, makeMatcherC

111+, prepareMatchersE

112+, prepareMatchersC

113+, matchChildren

114+, matchContent''

115+, matchContent'

116+, matchContent

117+) where

118+

119+import Control.Applicative hiding ( liftA, liftA2 )

120+import Control.Monad ( MonadPlus )

121+import Control.Arrow

122+

123+import qualified Data.Map as M

124+import qualified Data.Foldable as F

125+import Data.Default

126+import Data.Monoid ( Monoid )

127+import Data.Maybe

128+

129+import qualified Text.XML.Light as XML

130+

131+import Text.Pandoc.Readers.Odt.Arrows.State

132+import Text.Pandoc.Readers.Odt.Arrows.Utils

133+

134+import Text.Pandoc.Readers.Odt.Generic.Namespaces

135+import Text.Pandoc.Readers.Odt.Generic.Utils

136+import Text.Pandoc.Readers.Odt.Generic.Fallible

137+

138+--------------------------------------------------------------------------------

139+-- Basis types for readability

140+--------------------------------------------------------------------------------

141+

142+--

143+type ElementName = String

144+type AttributeName = String

145+type AttributeValue = String

146+

147+--

148+type NameSpacePrefix = String

149+

150+--

151+type NameSpacePrefixes nsID = M.Map nsID NameSpacePrefix

152+

153+--------------------------------------------------------------------------------

154+-- Main converter state

155+--------------------------------------------------------------------------------

156+

157+-- GADT so some of the NameSpaceID restrictions can be deduced

158+data XMLConverterState nsID extraState where

159+ XMLConverterState :: NameSpaceID nsID

160+ => { -- | A stack of parent elements. The top element is the current one.

161+ -- Arguably, a real Zipper would be better. But that is an

162+ -- optimization that can be made at a later time, e.g. when

163+ -- replacing Text.XML.Light.

164+ parentElements :: [XML.Element]

165+ -- | A map from internal namespace IDs to the namespace prefixes

166+ -- used in XML elements

167+ , namespacePrefixes :: NameSpacePrefixes nsID

168+ -- | A map from internal namespace IDs to namespace IRIs

169+ -- (Only necessary for matching namespace IDs and prefixes)

170+ , namespaceIRIs :: NameSpaceIRIs nsID

171+ -- | A place to put "something else". This feature is used heavily

172+ -- to keep the main code cleaner. More specifically, the main reader

173+ -- is divided into different stages. Each stage lifts something up

174+ -- here, which the next stage can then use. This could of course be

175+ -- generalized to a state-tree or used for the namespace IRIs. The

176+ -- border between states and values is an imaginary one, after all.

177+ -- But the separation as it is seems to be enough for now.

178+ , moreState :: extraState

179+ }

180+ -> XMLConverterState nsID extraState

181+

182+--

183+createStartState :: (NameSpaceID nsID)

184+ => XML.Element

185+ -> extraState

186+ -> XMLConverterState nsID extraState

187+createStartState element extraState =

188+ XMLConverterState

189+ { parentElements = [element]

190+ , namespacePrefixes = M.empty

191+ , namespaceIRIs = getInitialIRImap

192+ , moreState = extraState

193+ }

194+

195+-- | Functor over extra state

196+instance Functor (XMLConverterState nsID) where

197+ fmap f ( XMLConverterState parents prefixes iRIs extraState )

198+ = XMLConverterState parents prefixes iRIs (f extraState)

199+

200+--

201+replaceExtraState :: extraState

202+ -> XMLConverterState nsID _x

203+ -> XMLConverterState nsID extraState

204+replaceExtraState x s

205+ = fmap (const x) s

206+

207+--

208+currentElement :: XMLConverterState nsID extraState

209+ -> XML.Element

210+currentElement state = head (parentElements state)

211+

212+-- | Replace the current position by another, modifying the extra state

213+-- in the process

214+swapPosition :: (extraState -> extraState')

215+ -> [XML.Element]

216+ -> XMLConverterState nsID extraState

217+ -> XMLConverterState nsID extraState'

218+swapPosition f stack state

219+ = state { parentElements = stack

220+ , moreState = f (moreState state)

221+ }

222+

223+-- | Replace the current position by another, modifying the extra state

224+-- in the process

225+swapStack' :: XMLConverterState nsID extraState

226+ -> [XML.Element]

227+ -> ( XMLConverterState nsID extraState , [XML.Element] )

228+swapStack' state stack

229+ = ( state { parentElements = stack }

230+ , parentElements state

231+ )

232+

233+--

234+pushElement :: XML.Element

235+ -> XMLConverterState nsID extraState

236+ -> XMLConverterState nsID extraState

237+pushElement e state = state { parentElements = e:(parentElements state) }

238+

239+-- | Pop the top element from the call stack, unless it is the last one.

240+popElement :: XMLConverterState nsID extraState

241+ -> Maybe (XMLConverterState nsID extraState)

242+popElement state

243+ | _:es@(_:_) <- parentElements state = Just $ state { parentElements = es }

244+ | otherwise = Nothing

245+

246+--------------------------------------------------------------------------------

247+-- Main type

248+--------------------------------------------------------------------------------

249+

250+-- It might be a good idea to pack the converters in a GADT

251+-- Downside: data instead of type

252+-- Upside: 'Failure' could be made a parameter as well.

253+

254+--

255+type XMLConverter nsID extraState input output

256+ = ArrowState (XMLConverterState nsID extraState ) input output

257+

258+type FallibleXMLConverter nsID extraState input output

259+ = XMLConverter nsID extraState input (Fallible output)

260+

261+--

262+runConverter :: XMLConverter nsID extraState input output

263+ -> XMLConverterState nsID extraState

264+ -> input

265+ -> output

266+runConverter converter state input = snd $ runArrowState converter (state,input)

267+

268+--

269+runConverter'' :: (NameSpaceID nsID)

270+ => XMLConverter nsID extraState (Fallible ()) output

271+ -> extraState

272+ -> XML.Element

273+ -> output

274+runConverter'' converter extraState element = runConverter (readNSattributes >>> converter) (createStartState element extraState) ()

275+

276+runConverter' :: (NameSpaceID nsID)

277+ => FallibleXMLConverter nsID extraState () success

278+ -> extraState

279+ -> XML.Element

280+ -> Fallible success

281+runConverter' converter extraState element = runConverter (readNSattributes >>? converter) (createStartState element extraState) ()

282+

283+--

284+runConverterF' :: FallibleXMLConverter nsID extraState x y

285+ -> XMLConverterState nsID extraState

286+ -> Fallible x -> Fallible y

287+runConverterF' a s e = runConverter (returnV e >>? a) s e

288+

289+--

290+runConverterF :: (NameSpaceID nsID)

291+ => FallibleXMLConverter nsID extraState XML.Element x

292+ -> extraState

293+ -> Fallible XML.Element -> Fallible x

294+runConverterF a s = either failWith

295+ (\e -> runConverter a (createStartState e s) e)

296+

297+--

298+getCurrentElement :: XMLConverter nsID extraState x XML.Element

299+getCurrentElement = extractFromState currentElement

300+

301+--

302+getExtraState :: XMLConverter nsID extraState x extraState

303+getExtraState = extractFromState moreState

304+

305+--

306+setExtraState :: XMLConverter nsID extraState extraState extraState

307+setExtraState = withState $ \state extra

308+ -> (replaceExtraState extra state , extra)

309+

310+

311+-- | Lifts a function to the extra state.

312+modifyExtraState :: (extraState -> extraState)

313+ -> XMLConverter nsID extraState x x

314+modifyExtraState = modifyState.fmap

315+

316+

317+-- | First sets the extra state to the new value. Then modifies the original

318+-- extra state with a converter that uses the new state. Finally, the

319+-- intermediate state is dropped and the extra state is lifted into the

320+-- state as it was at the beginning of the function.

321+-- As a result, exactly the extra state and nothing else is changed.

322+-- The resulting converter even behaves like an identity converter on the

323+-- value level.

324+--

325+-- (The -ing form is meant to be mnemonic in a sequence of arrows as in

326+-- convertingExtraState () converter >>> doOtherStuff)

327+--

328+convertingExtraState :: extraState'

329+ -> FallibleXMLConverter nsID extraState' extraState extraState

330+ -> FallibleXMLConverter nsID extraState x x

331+convertingExtraState v a = withSubStateF setVAsExtraState modifyWithA

332+ where

333+ setVAsExtraState = liftAsSuccess $ extractFromState id >>^ replaceExtraState v

334+ modifyWithA = keepingTheValue (moreState ^>> a)

335+ >>^ spreadChoice >>?§ flip replaceExtraState

336+

337+-- | First sets the extra state to the new value. Then produces a new

338+-- extra state with a converter that uses the new state. Finally, the

339+-- intermediate state is dropped and the extra state is lifted into the

340+-- state as it was at the beginning of the function.

341+-- As a result, exactly the extra state and nothing else is changed.

342+-- The resulting converter even behaves like an identity converter on the

343+-- value level.

344+--

345+-- Aequivalent to

346+--

347+-- > \v x a -> convertingExtraState v (returnV x >>> a)

348+--

349+-- (The -ing form is meant to be mnemonic in a sequence of arrows as in

350+-- producingExtraState () () producer >>> doOtherStuff)

351+--

352+producingExtraState :: extraState'

353+ -> a

354+ -> FallibleXMLConverter nsID extraState' a extraState

355+ -> FallibleXMLConverter nsID extraState x x

356+producingExtraState v x a = convertingExtraState v (returnV x >>> a)

357+

358+

359+--------------------------------------------------------------------------------

360+-- Work in namespaces

361+--------------------------------------------------------------------------------

362+

363+-- | Arrow version of 'getIRI'

364+lookupNSiri :: (NameSpaceID nsID)

365+ => nsID

366+ -> XMLConverter nsID extraState x (Maybe NameSpaceIRI)

367+lookupNSiri nsID = extractFromState

368+ $ \state -> getIRI nsID $ namespaceIRIs state

369+

370+--

371+lookupNSprefix :: (NameSpaceID nsID)

372+ => nsID

373+ -> XMLConverter nsID extraState x (Maybe NameSpacePrefix)

374+lookupNSprefix nsID = extractFromState

375+ $ \state -> M.lookup nsID $ namespacePrefixes state

376+

377+-- | Extracts namespace attributes from the current element and tries to

378+-- update the current mapping accordingly

379+readNSattributes :: (NameSpaceID nsID)

380+ => FallibleXMLConverter nsID extraState x ()

381+readNSattributes = fromState $ \state -> maybe (state, failEmpty )

382+ ( , succeedWith ())

383+ (extractNSAttrs state )

384+ where

385+ extractNSAttrs :: (NameSpaceID nsID)

386+ => XMLConverterState nsID extraState

387+ -> Maybe (XMLConverterState nsID extraState)

388+ extractNSAttrs startState

389+ = foldl (\state d -> state >>= addNS d)

390+ (Just startState)

391+ nsAttribs

392+ where nsAttribs = mapMaybe readNSattr (XML.elAttribs element)

393+ element = currentElement startState

394+ readNSattr (XML.Attr (XML.QName name _ (Just "xmlns")) iri)

395+ = Just (name, iri)

396+ readNSattr _ = Nothing

397+ addNS (prefix, iri) state = fmap updateState

398+ $ getNamespaceID iri

399+ $ namespaceIRIs state

400+ where updateState (iris,nsID)

401+ = state { namespaceIRIs = iris

402+ , namespacePrefixes = M.insert nsID prefix

403+ $ namespacePrefixes state

404+ }

405+

406+--------------------------------------------------------------------------------

407+-- Common namespace accessors

408+--------------------------------------------------------------------------------

409+

410+-- | Given a namespace id and an element name, creates a 'XML.QName' for

411+-- internal use

412+elemName :: (NameSpaceID nsID)

413+ => nsID -> ElementName

414+ -> XMLConverter nsID extraState x XML.QName

415+elemName nsID name = lookupNSiri nsID

416+ &&& lookupNSprefix nsID

417+ >>§ XML.QName name

418+

419+-- | Checks if a given element matches both a specified namespace id

420+-- and a specified element name

421+elemNameIs :: (NameSpaceID nsID)

422+ => nsID -> ElementName

423+ -> XMLConverter nsID extraState XML.Element Bool

424+elemNameIs nsID name = keepingTheValue (lookupNSiri nsID) >>§ hasThatName

425+ where hasThatName e iri = let elName = XML.elName e

426+ in XML.qName elName == name

427+ && XML.qURI elName == iri

428+

429+--------------------------------------------------------------------------------

430+-- General content

431+--------------------------------------------------------------------------------

432+

433+--

434+strContent :: XMLConverter nsID extraState x String

435+strContent = getCurrentElement

436+ >>^ XML.strContent

437+

438+--

439+elContent :: XMLConverter nsID extraState x [XML.Content]

440+elContent = getCurrentElement

441+ >>^ XML.elContent

442+

443+--------------------------------------------------------------------------------

444+-- Current element

445+--------------------------------------------------------------------------------

446+

447+--

448+currentElem :: XMLConverter nsID extraState x (XML.QName)

449+currentElem = getCurrentElement

450+ >>^ XML.elName

451+

452+currentElemIs :: (NameSpaceID nsID)

453+ => nsID -> ElementName

454+ -> XMLConverter nsID extraState x Bool

455+currentElemIs nsID name = getCurrentElement

456+ >>> elemNameIs nsID name

457+

458+

459+

460+{-

461+currentElemIs'' nsID name = ( (getCurrentElement >>^ XML.elName >>>

462+ (XML.qName >>^ (&&).(== name) )

463+ ^&&&^

464+ (XML.qIRI >>^ (==) )

465+ ) >>§ (.)

466+ ) &&& lookupNSiri nsID >>§ ($)

467+-}

468+

469+--

470+expectElement :: (NameSpaceID nsID)

471+ => nsID -> ElementName

472+ -> FallibleXMLConverter nsID extraState x ()

473+expectElement nsID name = currentElemIs nsID name

474+ >>^ boolToChoice

475+

476+--------------------------------------------------------------------------------

477+-- Chilren

478+--------------------------------------------------------------------------------

479+

480+--

481+elChildren :: XMLConverter nsID extraState x [XML.Element]

482+elChildren = getCurrentElement

483+ >>^ XML.elChildren

484+

485+--

486+findChildren :: (NameSpaceID nsID)

487+ => nsID -> ElementName

488+ -> XMLConverter nsID extraState x [XML.Element]

489+findChildren nsID name = elemName nsID name

490+ &&& getCurrentElement

491+ >>§ XML.findChildren

492+

493+--

494+filterChildren :: (XML.Element -> Bool)

495+ -> XMLConverter nsID extraState x [XML.Element]

496+filterChildren p = getCurrentElement

497+ >>^ XML.filterChildren p

498+

499+--

500+filterChildrenName :: (XML.QName -> Bool)

501+ -> XMLConverter nsID extraState x [XML.Element]

502+filterChildrenName p = getCurrentElement

503+ >>^ XML.filterChildrenName p

504+

505+--

506+findChild' :: (NameSpaceID nsID)

507+ => nsID

508+ -> ElementName

509+ -> XMLConverter nsID extraState x (Maybe XML.Element)

510+findChild' nsID name = elemName nsID name

511+ &&& getCurrentElement

512+ >>§ XML.findChild

513+

514+--

515+findChild :: (NameSpaceID nsID)

516+ => nsID -> ElementName

517+ -> FallibleXMLConverter nsID extraState x XML.Element

518+findChild nsID name = findChild' nsID name

519+ >>> maybeToChoice

520+

521+--

522+filterChild' :: (XML.Element -> Bool)

523+ -> XMLConverter nsID extraState x (Maybe XML.Element)

524+filterChild' p = getCurrentElement

525+ >>^ XML.filterChild p

526+

527+--

528+filterChild :: (XML.Element -> Bool)

529+ -> FallibleXMLConverter nsID extraState x XML.Element

530+filterChild p = filterChild' p

531+ >>> maybeToChoice

532+

533+--

534+filterChildName' :: (XML.QName -> Bool)

535+ -> XMLConverter nsID extraState x (Maybe XML.Element)

536+filterChildName' p = getCurrentElement

537+ >>^ XML.filterChildName p

538+

539+--

540+filterChildName :: (XML.QName -> Bool)

541+ -> FallibleXMLConverter nsID extraState x XML.Element

542+filterChildName p = filterChildName' p

543+ >>> maybeToChoice

544+

545+

546+--------------------------------------------------------------------------------

547+-- Attributes

548+--------------------------------------------------------------------------------

549+

550+--

551+isSet :: (NameSpaceID nsID)

552+ => nsID -> AttributeName

553+ -> (Either Failure Bool)

554+ -> FallibleXMLConverter nsID extraState x Bool

555+isSet nsID attrName deflt

556+ = findAttr' nsID attrName

557+ >>^ maybe deflt stringToBool

558+

559+--

560+isSet' :: (NameSpaceID nsID)

561+ => nsID -> AttributeName

562+ -> XMLConverter nsID extraState x (Maybe Bool)

563+isSet' nsID attrName = findAttr' nsID attrName

564+ >>^ (>>= stringToBool')

565+

566+isSetWithDefault :: (NameSpaceID nsID)

567+ => nsID -> AttributeName

568+ -> Bool

569+ -> XMLConverter nsID extraState x Bool

570+isSetWithDefault nsID attrName def'

571+ = isSet' nsID attrName

572+ >>^ fromMaybe def'

573+

574+--

575+hasAttrValueOf' :: (NameSpaceID nsID)

576+ => nsID -> AttributeName

577+ -> AttributeValue

578+ -> XMLConverter nsID extraState x Bool

579+hasAttrValueOf' nsID attrName attrValue

580+ = findAttr nsID attrName

581+ >>> ( const False ^|||^ (==attrValue))

582+

583+--

584+failIfNotAttrValueOf :: (NameSpaceID nsID)

585+ => nsID -> AttributeName

586+ -> AttributeValue

587+ -> FallibleXMLConverter nsID extraState x ()

588+failIfNotAttrValueOf nsID attrName attrValue

589+ = hasAttrValueOf' nsID attrName attrValue

590+ >>^ boolToChoice

591+

592+-- | Is the value that is currently transported in the arrow the value of

593+-- the specified attribute?

594+isThatTheAttrValue :: (NameSpaceID nsID)

595+ => nsID -> AttributeName

596+ -> FallibleXMLConverter nsID extraState AttributeValue Bool

597+isThatTheAttrValue nsID attrName

598+ = keepingTheValue

599+ (findAttr nsID attrName)

600+ >>§ right.(==)

601+

602+-- | Lookup value in a dictionary, fail if no attribute found or value

603+-- not in dictionary

604+searchAttrIn :: (NameSpaceID nsID)

605+ => nsID -> AttributeName

606+ -> [(AttributeValue,a)]

607+ -> FallibleXMLConverter nsID extraState x a

608+searchAttrIn nsID attrName dict

609+ = findAttr nsID attrName

610+ >>?^? maybeToChoice.(`lookup` dict )

611+

612+

613+-- | Lookup value in a dictionary. Fail if no attribute found. If value not in

614+-- dictionary, return default value

615+searchAttrWith :: (NameSpaceID nsID)

616+ => nsID -> AttributeName

617+ -> a

618+ -> [(AttributeValue,a)]

619+ -> FallibleXMLConverter nsID extraState x a

620+searchAttrWith nsID attrName defV dict

621+ = findAttr nsID attrName

622+ >>?^ (fromMaybe defV).(`lookup` dict )

623+

624+-- | Lookup value in a dictionary. If attribute or value not found,

625+-- return default value

626+searchAttr :: (NameSpaceID nsID)

627+ => nsID -> AttributeName

628+ -> a

629+ -> [(AttributeValue,a)]

630+ -> XMLConverter nsID extraState x a

631+searchAttr nsID attrName defV dict

632+ = searchAttrIn nsID attrName dict

633+ >>> const defV ^|||^ id

634+

635+-- | Read a 'Lookupable' attribute. Fail if no match.

636+lookupAttr :: (NameSpaceID nsID, Lookupable a)

637+ => nsID -> AttributeName

638+ -> FallibleXMLConverter nsID extraState x a

639+lookupAttr nsID attrName = lookupAttr' nsID attrName

640+ >>^ maybeToChoice

641+

642+

643+-- | Read a 'Lookupable' attribute. Return the result as a 'Maybe'.

644+lookupAttr' :: (NameSpaceID nsID, Lookupable a)

645+ => nsID -> AttributeName

646+ -> XMLConverter nsID extraState x (Maybe a)

647+lookupAttr' nsID attrName

648+ = findAttr' nsID attrName

649+ >>^ (>>= readLookupable)

650+

651+-- | Read a 'Lookupable' attribute with explicit default

652+lookupAttrWithDefault :: (NameSpaceID nsID, Lookupable a)

653+ => nsID -> AttributeName

654+ -> a

655+ -> XMLConverter nsID extraState x a

656+lookupAttrWithDefault nsID attrName deflt

657+ = lookupAttr' nsID attrName

658+ >>^ fromMaybe deflt

659+

660+-- | Read a 'Lookupable' attribute with implicit default

661+lookupDefaultingAttr :: (NameSpaceID nsID, Lookupable a, Default a)

662+ => nsID -> AttributeName

663+ -> XMLConverter nsID extraState x a

664+lookupDefaultingAttr nsID attrName

665+ = lookupAttrWithDefault nsID attrName def

666+

667+-- | Return value as a (Maybe String)

668+findAttr' :: (NameSpaceID nsID)

669+ => nsID -> AttributeName

670+ -> XMLConverter nsID extraState x (Maybe AttributeValue)

671+findAttr' nsID attrName = elemName nsID attrName

672+ &&& getCurrentElement

673+ >>§ XML.findAttr

674+

675+-- | Return value as string or fail

676+findAttr :: (NameSpaceID nsID)

677+ => nsID -> AttributeName

678+ -> FallibleXMLConverter nsID extraState x AttributeValue

679+findAttr nsID attrName = findAttr' nsID attrName

680+ >>> maybeToChoice

681+

682+-- | Return value as string or return provided default value

683+findAttrWithDefault :: (NameSpaceID nsID)

684+ => nsID -> AttributeName

685+ -> AttributeValue

686+ -> XMLConverter nsID extraState x AttributeValue

687+findAttrWithDefault nsID attrName deflt

688+ = findAttr' nsID attrName

689+ >>^ fromMaybe deflt

690+

691+-- | Read and return value or fail

692+readAttr :: (NameSpaceID nsID, Read attrValue)

693+ => nsID -> AttributeName

694+ -> FallibleXMLConverter nsID extraState x attrValue

695+readAttr nsID attrName = readAttr' nsID attrName

696+ >>> maybeToChoice

697+

698+-- | Read and return value or return Nothing

699+readAttr' :: (NameSpaceID nsID, Read attrValue)

700+ => nsID -> AttributeName

701+ -> XMLConverter nsID extraState x (Maybe attrValue)

702+readAttr' nsID attrName = findAttr' nsID attrName

703+ >>^ (>>= tryToRead)

704+

705+-- | Read and return value or return provided default value

706+readAttrWithDefault :: (NameSpaceID nsID, Read attrValue)

707+ => nsID -> AttributeName

708+ -> attrValue

709+ -> XMLConverter nsID extraState x attrValue

710+readAttrWithDefault nsID attrName deflt

711+ = findAttr' nsID attrName

712+ >>^ (>>= tryToRead)

713+ >>^ fromMaybe deflt

714+

715+-- | Read and return value or return default value from 'Default' instance

716+getAttr :: (NameSpaceID nsID, Read attrValue, Default attrValue)

717+ => nsID -> AttributeName

718+ -> XMLConverter nsID extraState x attrValue

719+getAttr nsID attrName = readAttrWithDefault nsID attrName def

720+

721+--------------------------------------------------------------------------------

722+-- Movements

723+--------------------------------------------------------------------------------

724+

725+--

726+jumpThere :: XMLConverter nsID extraState XML.Element XML.Element

727+jumpThere = withState (\state element

728+ -> ( pushElement element state , element )

729+ )

730+

731+--

732+swapStack :: XMLConverter nsID extraState [XML.Element] [XML.Element]

733+swapStack = withState swapStack'

734+

735+--

736+jumpBack :: FallibleXMLConverter nsID extraState _x _x

737+jumpBack = tryModifyState (popElement >>> maybeToChoice)

738+

739+-- | Support function for "procedural" converters: jump to an element, execute

740+-- a converter, jump back.

741+-- This version is safer than 'executeThere', because it does not rely on the

742+-- internal stack. As a result, the converter can not move around in arbitrary

743+-- ways. The downside is of course that some of the environment is not

744+-- accessible to the converter.

745+switchingTheStack :: XMLConverter nsID moreState a b

746+ -> XMLConverter nsID moreState (a, XML.Element) b

747+switchingTheStack a = second ( (:[]) ^>> swapStack )

748+ >>> first a

749+ >>> second swapStack

750+ >>^ fst

751+

752+-- | Support function for "procedural" converters: jumps to an element, executes

753+-- a converter, jumps back.

754+-- Make sure that the converter is well-behaved; that is it should

755+-- return to the exact position it started from in /every possible path/ of

756+-- execution, even if it "fails". If it does not, you may encounter

757+-- strange bugs. If you are not sure about the behaviour or want to use

758+-- shortcuts, you can often use 'switchingTheStack' instead.

759+executeThere :: FallibleXMLConverter nsID moreState a b

760+ -> FallibleXMLConverter nsID moreState (a, XML.Element) b

761+executeThere a = second jumpThere

762+ >>> fst

763+ ^>> a

764+ >>> jumpBack -- >>? jumpBack would not ensure the jump.

765+ >>^ collapseEither

766+

767+-- | Do something in a sub-element, tnen come back

768+executeIn :: (NameSpaceID nsID)

769+ => nsID -> ElementName

770+ -> FallibleXMLConverter nsID extraState f s

771+ -> FallibleXMLConverter nsID extraState f s

772+executeIn nsID name a = keepingTheValue

773+ (findChild nsID name)

774+ >>> ignoringState liftFailure

775+ >>? switchingTheStack a

776+ where liftFailure (_, (Left f)) = Left f

777+ liftFailure (x, (Right e)) = Right (x, e)

778+

779+--------------------------------------------------------------------------------

780+-- Iterating over children

781+--------------------------------------------------------------------------------

782+

783+-- Helper converter to prepare different types of iterations.

784+-- It lifts the children (of a certain type) of the current element

785+-- into the value level and pairs each one with the current input value.

786+prepareIteration :: (NameSpaceID nsID)

787+ => nsID -> ElementName

788+ -> XMLConverter nsID extraState b [(b, XML.Element)]

789+prepareIteration nsID name = keepingTheValue

790+ (findChildren nsID name)

791+ >>§ distributeValue

792+

793+-- | Applies a converter to every child element of a specific type.

794+-- Collects results in a 'Monoid'.

795+-- Fails completely if any conversion fails.

796+collectEvery :: (NameSpaceID nsID, Monoid m)

797+ => nsID -> ElementName

798+ -> FallibleXMLConverter nsID extraState a m

799+ -> FallibleXMLConverter nsID extraState a m

800+collectEvery nsID name a = prepareIteration nsID name

801+ >>> foldS' (switchingTheStack a)

802+

803+--

804+withEveryL :: (NameSpaceID nsID)

805+ => nsID -> ElementName

806+ -> FallibleXMLConverter nsID extraState a b

807+ -> FallibleXMLConverter nsID extraState a [b]

808+withEveryL = withEvery

809+

810+-- | Applies a converter to every child element of a specific type.

811+-- Collects results in a 'MonadPlus'.

812+-- Fails completely if any conversion fails.

813+withEvery :: (NameSpaceID nsID, MonadPlus m)

814+ => nsID -> ElementName

815+ -> FallibleXMLConverter nsID extraState a b

816+ -> FallibleXMLConverter nsID extraState a (m b)

817+withEvery nsID name a = prepareIteration nsID name

818+ >>> iterateS' (switchingTheStack a)

819+

820+-- | Applies a converter to every child element of a specific type.

821+-- Collects all successful results in a list.

822+tryAll :: (NameSpaceID nsID)

823+ => nsID -> ElementName

824+ -> FallibleXMLConverter nsID extraState b a

825+ -> XMLConverter nsID extraState b [a]

826+tryAll nsID name a = prepareIteration nsID name

827+ >>> iterateS (switchingTheStack a)

828+ >>^ collectRights

829+

830+-- | Applies a converter to every child element of a specific type.

831+-- Collects all successful results.

832+tryAll' :: (NameSpaceID nsID, F.Foldable c, MonadPlus c)

833+ => nsID -> ElementName

834+ -> FallibleXMLConverter nsID extraState b a

835+ -> XMLConverter nsID extraState b (c a)

836+tryAll' nsID name a = prepareIteration nsID name

837+ >>> iterateS (switchingTheStack a)

838+ >>^ collectRightsF

839+

840+--------------------------------------------------------------------------------

841+-- Matching children

842+--------------------------------------------------------------------------------

843+

844+type IdXMLConverter nsID moreState x

845+ = XMLConverter nsID moreState x x

846+

847+type MaybeEConverter nsID moreState x

848+ = Maybe (IdXMLConverter nsID moreState (x, XML.Element))

849+

850+-- Chainable converter that helps deciding which converter to actually use.

851+type ElementMatchConverter nsID extraState x

852+ = IdXMLConverter nsID

853+ extraState

854+ (MaybeEConverter nsID extraState x, XML.Element)

855+

856+type MaybeCConverter nsID moreState x

857+ = Maybe (IdXMLConverter nsID moreState (x, XML.Content))

858+

859+-- Chainable converter that helps deciding which converter to actually use.

860+type ContentMatchConverter nsID extraState x

861+ = IdXMLConverter nsID

862+ extraState

863+ (MaybeCConverter nsID extraState x, XML.Content)

864+

865+-- Helper function: The @c@ is actually a converter that is to be selected by

866+-- matching XML elements to the first two parameters.

867+-- The fold used to match elements however is very simple, so to use it,

868+-- this function wraps the converter in another converter that unifies

869+-- the accumulator. Think of a lot of converters with the resulting type

870+-- chained together. The accumulator not only transports the element

871+-- unchanged to the next matcher, it also does the actual selecting by

872+-- combining the intermediate results with '(<|>)'.

873+makeMatcherE :: (NameSpaceID nsID)

874+ => nsID -> ElementName

875+ -> FallibleXMLConverter nsID extraState a a

876+ -> ElementMatchConverter nsID extraState a

877+makeMatcherE nsID name c = ( second (

878+ elemNameIs nsID name

879+ >>^ bool Nothing (Just tryC)

880+ )

881+ >>§ (<|>)

882+ ) &&&^ snd

883+ where tryC = (fst ^&&& executeThere c >>§ recover) &&&^ snd

884+

885+-- Helper function: The @c@ is actually a converter that is to be selected by

886+-- matching XML content to the first two parameters.

887+-- The fold used to match elements however is very simple, so to use it,

888+-- this function wraps the converter in another converter that unifies

889+-- the accumulator. Think of a lot of converters with the resulting type

890+-- chained together. The accumulator not only transports the element

891+-- unchanged to the next matcher, it also does the actual selecting by

892+-- combining the intermediate results with '(<|>)'.

893+makeMatcherC :: (NameSpaceID nsID)

894+ => nsID -> ElementName

895+ -> FallibleXMLConverter nsID extraState a a

896+ -> ContentMatchConverter nsID extraState a

897+makeMatcherC nsID name c = ( second ( contentToElem

898+ >>> returnV Nothing

899+ ||| ( elemNameIs nsID name

900+ >>^ bool Nothing (Just cWithJump)

901+ )

902+ )

903+ >>§ (<|>)

904+ ) &&&^ snd

905+ where cWithJump = ( fst

906+ ^&&& ( second contentToElem

907+ >>> spreadChoice

908+ ^>>? executeThere c

909+ )

910+ >>§ recover)

911+ &&&^ snd

912+ contentToElem :: FallibleXMLConverter nsID extraState XML.Content XML.Element

913+ contentToElem = arr $ \e -> case e of

914+ XML.Elem e' -> succeedWith e'

915+ _ -> failEmpty

916+

917+-- Creates and chains a bunch of matchers

918+prepareMatchersE :: (NameSpaceID nsID)

919+ => [(nsID, ElementName, FallibleXMLConverter nsID extraState x x)]

920+ -> ElementMatchConverter nsID extraState x

921+--prepareMatchersE = foldSs . (map $ uncurry3 makeMatcherE)

922+prepareMatchersE = reverseComposition . (map $ uncurry3 makeMatcherE)

923+

924+-- Creates and chains a bunch of matchers

925+prepareMatchersC :: (NameSpaceID nsID)

926+ => [(nsID, ElementName, FallibleXMLConverter nsID extraState x x)]

927+ -> ContentMatchConverter nsID extraState x

928+--prepareMatchersC = foldSs . (map $ uncurry3 makeMatcherC)

929+prepareMatchersC = reverseComposition . (map $ uncurry3 makeMatcherC)

930+

931+-- | Takes a list of element-data - converter groups and

932+-- * Finds all children of the current element

933+-- * Matches each group to each child in order (at most one group per child)

934+-- * Filters non-matched children

935+-- * Chains all found converters in child-order

936+-- * Applies the chain to the input element

937+matchChildren :: (NameSpaceID nsID)

938+ => [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)]

939+ -> XMLConverter nsID extraState a a

940+matchChildren lookups = let matcher = prepareMatchersE lookups

941+ in keepingTheValue (

942+ elChildren

943+ >>> map (Nothing,)

944+ ^>> iterateSL matcher

945+ >>^ catMaybes.map (\(m,e) -> fmap (swallowElem e) m)

946+ -- >>> foldSs

947+ >>> reverseComposition

948+ )

949+ >>> swap

950+ ^>> app

951+ where

952+ -- let the converter swallow the element and drop the element

953+ -- in the return value

954+ swallowElem element converter = (,element) ^>> converter >>^ fst

955+

956+--

957+matchContent'' :: (NameSpaceID nsID)

958+ => [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)]

959+ -> XMLConverter nsID extraState a a

960+matchContent'' lookups = let matcher = prepareMatchersC lookups

961+ in keepingTheValue (

962+ elContent

963+ >>> map (Nothing,)

964+ ^>> iterateSL matcher

965+ >>^ catMaybes.map (\(m,c) -> fmap (swallowContent c) m)

966+ -- >>> foldSs

967+ >>> reverseComposition

968+ )

969+ >>> swap

970+ ^>> app

971+ where

972+ -- let the converter swallow the content and drop the content

973+ -- in the return value

974+ swallowContent content converter = (,content) ^>> converter >>^ fst

975+

976+

977+-- | Takes a list of element-data - converter groups and

978+-- * Finds all content of the current element

979+-- * Matches each group to each piece of content in order

980+-- (at most one group per piece of content)

981+-- * Filters non-matched content

982+-- * Chains all found converters in content-order

983+-- * Applies the chain to the input element

984+matchContent' :: (NameSpaceID nsID)

985+ => [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)]

986+ -> XMLConverter nsID extraState a a

987+matchContent' lookups = matchContent lookups (arr fst)

988+

989+-- | Takes a list of element-data - converter groups and

990+-- * Finds all content of the current element

991+-- * Matches each group to each piece of content in order

992+-- (at most one group per piece of content)

993+-- * Adds a default converter for all non-matched content

994+-- * Chains all found converters in content-order

995+-- * Applies the chain to the input element

996+matchContent :: (NameSpaceID nsID)

997+ => [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)]

998+ -> XMLConverter nsID extraState (a,XML.Content) a

999+ -> XMLConverter nsID extraState a a

1000+matchContent lookups fallback

1001+ = let matcher = prepareMatchersC lookups

1002+ in keepingTheValue (

1003+ elContent

1004+ >>> map (Nothing,)

1005+ ^>> iterateSL matcher

1006+ >>^ map swallowOrFallback

1007+ -- >>> foldSs

1008+ >>> reverseComposition

1009+ )

1010+ >>> swap

1011+ ^>> app

1012+ where

1013+ -- let the converter swallow the content and drop the content

1014+ -- in the return value

1015+ swallowOrFallback (Just converter,content) = (,content) ^>> converter >>^ fst

1016+ swallowOrFallback (Nothing ,content) = (,content) ^>> fallback

1017+

1018+--------------------------------------------------------------------------------

1019+-- Internals

1020+--------------------------------------------------------------------------------

1021+

1022+stringToBool :: (Monoid failure) => String -> Either failure Bool

1023+stringToBool val -- stringToBool' val >>> maybeToChoice

1024+ | val `elem` trueValues = succeedWith True

1025+ | val `elem` falseValues = succeedWith False

1026+ | otherwise = failEmpty

1027+ where trueValues = ["true" ,"on" ,"1"]

1028+ falseValues = ["false","off","0"]

1029+

1030+stringToBool' :: String -> Maybe Bool

1031+stringToBool' val | val `elem` trueValues = Just True

1032+ | val `elem` falseValues = Just False

1033+ | otherwise = Nothing

1034+ where trueValues = ["true" ,"on" ,"1"]

1035+ falseValues = ["false","off","0"]

1036+

1037+

1038+distributeValue :: a -> [b] -> [(a,b)]

1039+distributeValue = map.(,)

1040+

1041+--------------------------------------------------------------------------------

1042+

1043+{-

1044+NOTES

1045+It might be a good idea to refactor the namespace stuff.

1046+E.g.: if a namespace constructor took a string as a parameter, things like

1047+> a ?>/< (NsText,"body")

1048+would be nicer.

1049+Together with a rename and some trickery, something like

1050+> |< NsText "body" >< NsText "p" ?> a </> </>|

1051+might even be possible.

1052+

1053+Some day, XML.Light should be replaced by something better.

1054+While doing that, it might be useful to replace String as the type of element

1055+names with something else, too. (Of course with OverloadedStrings).

1056+While doing that, maybe the types can be created in a way that something like

1057+> NsText:"body"

1058+could be used. Overloading (:) does not sounds like the best idea, but if the

1059+element name type was a list, this might be possible.

1060+Of course that would be a bit hackish, so the "right" way would probably be

1061+something like

1062+> InNS NsText "body"

1063+but isn't that a bit boring? ;)

1064+-}

src/Text/Pandoc/Readers/Odt/Namespaces.hsnew file+110

@@ -0,0 +1,110 @@

1+{-

4+This program is free software; you can redistribute it and/or modify

5+it under the terms of the GNU General Public License as published by

6+the Free Software Foundation; either version 2 of the License, or

7+(at your option) any later version.

9+This program is distributed in the hope that it will be useful,

10+but WITHOUT ANY WARRANTY; without even the implied warranty of

11+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

12+GNU General Public License for more details.

13+

14+You should have received a copy of the GNU General Public License

15+along with this program; if not, write to the Free Software

16+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

17+-}

18+

19+{- |

20+ Module : Text.Pandoc.Reader.Odt.Namespaces

22+ License : GNU GPL, version 2 or above

23+

24+ Maintainer : Martin Linnemann <theCodingMarlin@googlemail.com>

25+ Stability : alpha

26+ Portability : portable

27+

28+Namespaces used in odt files.

29+-}

30+

31+module Text.Pandoc.Readers.Odt.Namespaces ( Namespace (..)

32+ ) where

33+

34+import Data.List ( isPrefixOf )

35+import Data.Maybe ( fromMaybe, listToMaybe )

36+import qualified Data.Map as M ( empty, insert )

37+

38+import Text.Pandoc.Readers.Odt.Generic.Namespaces

39+

40+

41+instance NameSpaceID Namespace where

42+

43+ getInitialIRImap = nsIDmap

44+

45+ getNamespaceID "" m = Just(m, NsXML)

46+ getNamespaceID iri m = asPair $ fromMaybe (NsOther iri) (findID iri)

47+ where asPair nsID = Just (M.insert nsID iri m, nsID)

48+

49+

50+findID :: NameSpaceIRI -> Maybe Namespace

51+findID iri = listToMaybe [nsID | (iri',~nsID) <- nsIDs, iri' `isPrefixOf` iri]

52+

53+nsIDmap :: NameSpaceIRIs Namespace

54+nsIDmap = foldr (uncurry $ flip M.insert) M.empty nsIDs

55+

56+data Namespace = -- Open Document core

57+ NsOffice | NsStyle | NsText | NsTable | NsForm

60+ | NsPresentation

61+ -- Metadata

62+ | NsODF

63+ -- Compatible elements

64+ | NsXSL_FO | NsSVG | NsSmil

65+ -- External standards

67+ | NsDublinCore

68+ -- Metadata manifest

69+ | NsPKG

70+ -- Others

71+ | NsOpenFormula

72+ -- Core XML (basically only for the 'id'-attribute)

73+ | NsXML

74+ -- Fallback

75+ | NsOther String

76+ deriving ( Eq, Ord, Show )

77+

78+-- | Not the actual iri's, but large prefixes of them - this way there are

79+-- less versioning problems and the like.

80+nsIDs :: [(String,Namespace)]

81+nsIDs = [

82+ ("urn:oasis:names:tc:opendocument:xmlns:animation" , NsAnim ),

83+ ("urn:oasis:names:tc:opendocument:xmlns:chart" , NsChart ),

84+ ("urn:oasis:names:tc:opendocument:xmlns:config" , NsConfig ),

85+ ("urn:oasis:names:tc:opendocument:xmlns:database" , NsDB ),

86+ ("urn:oasis:names:tc:opendocument:xmlns:dr3d" , Ns3D ),

87+ ("urn:oasis:names:tc:opendocument:xmlns:drawing" , NsDraw ),

88+ ("urn:oasis:names:tc:opendocument:xmlns:form" , NsForm ),

89+ ("urn:oasis:names:tc:opendocument:xmlns:manifest" , NsManifest ),

90+ ("urn:oasis:names:tc:opendocument:xmlns:meta" , NsMeta ),

91+ ("urn:oasis:names:tc:opendocument:xmlns:datastyle" , NsNumber ),

92+ ("urn:oasis:names:tc:opendocument:xmlns:of" , NsOpenFormula ),

93+ ("urn:oasis:names:tc:opendocument:xmlns:office:1.0" , NsOffice ),

94+ ("urn:oasis:names:tc:opendocument:xmlns:presentation" , NsPresentation ),

95+ ("urn:oasis:names:tc:opendocument:xmlns:script" , NsScript ),

96+ ("urn:oasis:names:tc:opendocument:xmlns:style" , NsStyle ),

97+ ("urn:oasis:names:tc:opendocument:xmlns:table" , NsTable ),

98+ ("urn:oasis:names:tc:opendocument:xmlns:text" , NsText ),

99+ ("urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible", NsXSL_FO ),

100+ ("urn:oasis:names:tc:opendocument:xmlns:smil-compatible" , NsSmil ),

101+ ("urn:oasis:names:tc:opendocument:xmlns:svg-compatible" , NsSVG ),

102+ ("http://docs.oasis-open.org/ns/office/1.2/meta/odf" , NsODF ),

103+ ("http://docs.oasis-open.org/ns/office/1.2/meta/pkg" , NsPKG ),

104+ ("http://purl.org/dc/elements" , NsDublinCore ),

105+ ("http://www.w3.org/2003/g/data-view" , NsGRDDL ),

106+ ("http://www.w3.org/1998/Math/MathML" , NsMathML ),

107+ ("http://www.w3.org/1999/xhtml" , NsXHtml ),

108+ ("http://www.w3.org/2002/xforms" , NsXForms ),

109+ ("http://www.w3.org/1999/xlink" , NsXLink )

110+ ]

src/Text/Pandoc/Readers/Odt/StyleReader.hsnew file+737

@@ -0,0 +1,737 @@

1+{-# LANGUAGE TupleSections #-}

2+{-# LANGUAGE PatternGuards #-}

3+{-# LANGUAGE ViewPatterns #-}

4+{-# LANGUAGE RecordWildCards #-}

5+{-# LANGUAGE Arrows #-}

7+{-

10+This program is free software; you can redistribute it and/or modify

11+it under the terms of the GNU General Public License as published by

12+the Free Software Foundation; either version 2 of the License, or

13+(at your option) any later version.

14+

15+This program is distributed in the hope that it will be useful,

16+but WITHOUT ANY WARRANTY; without even the implied warranty of

17+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

18+GNU General Public License for more details.

19+

20+You should have received a copy of the GNU General Public License

21+along with this program; if not, write to the Free Software

22+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

23+-}

24+

25+{- |

26+ Module : Text.Pandoc.Readers.Odt.StyleReader

28+ License : GNU GPL, version 2 or above

29+

30+ Maintainer : Martin Linnemann <theCodingMarlin@googlemail.com>

31+ Stability : alpha

32+ Portability : portable

33+

34+Reader for the style information in an odt document.

35+-}

36+

37+module Text.Pandoc.Readers.Odt.StyleReader

38+( Style (..)

39+, StyleName

40+, StyleFamily (..)

41+, Styles (..)

42+, StyleProperties (..)

43+, TextProperties (..)

44+, ParaProperties (..)

45+, VerticalTextPosition (..)

46+, ListItemNumberFormat (..)

47+, ListLevel

48+, ListStyle (..)

49+, ListLevelStyle (..)

50+, ListLevelType (..)

51+, LengthOrPercent (..)

52+, lookupStyle

53+, getTextProperty

54+, getTextProperty'

55+, getParaProperty

56+, getListStyle

57+, getListLevelStyle

58+, getStyleFamily

59+, lookupDefaultStyle

60+, lookupDefaultStyle'

61+, lookupListStyleByName

62+, getPropertyChain

63+, textPropertyChain

64+, stylePropertyChain

65+, stylePropertyChain'

66+, getStylePropertyChain

67+, extendedStylePropertyChain

68+, extendedStylePropertyChain'

69+, liftStyles

70+, readStylesAt

71+) where

72+

73+import Control.Arrow

74+import Control.Applicative hiding ( liftA, liftA2, liftA3 )

75+

76+import qualified Data.Foldable as F

77+import qualified Data.Map as M

78+import qualified Data.Set as S

79+import Data.List ( unfoldr )

80+import Data.Default

81+import Data.Monoid

82+import Data.Maybe

83+

84+import qualified Text.XML.Light as XML

85+

86+import Text.Pandoc.Readers.Odt.Arrows.State

87+import Text.Pandoc.Readers.Odt.Arrows.Utils

88+

89+import Text.Pandoc.Readers.Odt.Generic.Utils

90+import qualified Text.Pandoc.Readers.Odt.Generic.SetMap as SM

91+import Text.Pandoc.Readers.Odt.Generic.Fallible

92+import Text.Pandoc.Readers.Odt.Generic.XMLConverter

93+

94+import Text.Pandoc.Readers.Odt.Namespaces

95+import Text.Pandoc.Readers.Odt.Base

96+

97+

98+readStylesAt :: XML.Element -> Fallible Styles

99+readStylesAt e = runConverter' readAllStyles mempty e

100+

101+--------------------------------------------------------------------------------

102+-- Reader for font declarations and font pitches

103+--------------------------------------------------------------------------------

104+

105+-- Pandoc has no support for different font pitches. Yet knowing them can be

106+-- very helpful in cases where Pandoc has more semantics than OpenDocument.

107+-- In these cases, the pitch can help deciding as what to define a block of

108+-- text. So let's start with a type for font pitches:

109+

110+data FontPitch = PitchVariable | PitchFixed

111+ deriving ( Eq, Show )

112+

113+instance Lookupable FontPitch where

114+ lookupTable = [ ("variable" , PitchVariable)

115+ , ("fixed" , PitchFixed )

116+ ]

117+

118+instance Default FontPitch where

119+ def = PitchVariable

120+

121+-- The font pitch can be specifed in a style directly. Normally, however,

122+-- it is defined in the font. That is also the specs' recommendation.

123+--

124+-- Thus, we want

125+

126+type FontFaceName = String

127+

128+type FontPitches = M.Map FontFaceName FontPitch

129+

130+-- To get there, the fonts have to be read and the pitches extracted.

131+-- But the resulting map are only needed at one later place, so it should not be

132+-- transported on the value level, especially as we already use a state arrow.

133+-- So instead, the resulting map is lifted into the state of the reader.

134+-- (An alternative might be ImplicitParams, but again, we already have a state.)

135+--

136+-- So the main style readers will have the types

137+type StyleReader a b = XMLReader FontPitches a b

138+-- and

139+type StyleReaderSafe a b = XMLReaderSafe FontPitches a b

140+-- respectively.

141+--

142+-- But before we can work with these, we need to define the reader that reads

143+-- the fonts:

144+

145+-- | A reader for font pitches

146+fontPitchReader :: XMLReader _s _x FontPitches

147+fontPitchReader = executeIn NsOffice "font-face-decls" (

148+ ( withEveryL NsStyle "font-face" $ liftAsSuccess (

149+ findAttr' NsStyle "name"

150+ &&&

151+ lookupDefaultingAttr NsStyle "font-pitch"

152+ )

153+ )

154+ >>?^ ( M.fromList . (foldl accumLegalPitches []) )

155+ )

156+ where accumLegalPitches ls (Nothing,_) = ls

157+ accumLegalPitches ls (Just n,p) = (n,p):ls

158+

159+

160+-- | A wrapper around the font pitch reader that lifts the result into the

161+-- state.

162+readFontPitches :: StyleReader x x

163+readFontPitches = producingExtraState () () fontPitchReader

164+

165+

166+-- | Looking up a pitch in the state of the arrow.

167+--

168+-- The function does the following:

169+-- * Look for the font pitch in an attribute.

170+-- * If that fails, look for the font name, look up the font in the state

171+-- and use the pitch from there.

172+-- * Return the result in a Maybe

173+--

174+findPitch :: XMLReaderSafe FontPitches _x (Maybe FontPitch)

175+findPitch = ( lookupAttr NsStyle "font-pitch"

176+ `ifFailedDo` findAttr NsStyle "font-name"

177+ >>? ( keepingTheValue getExtraState

178+ >>§ M.lookup

179+ >>^ maybeToChoice

180+ )

181+ )

182+ >>> choiceToMaybe

183+

184+--------------------------------------------------------------------------------

185+-- Definitions of main data

186+--------------------------------------------------------------------------------

187+

188+type StyleName = String

189+

190+-- | There are two types of styles: named styles with a style family and an

191+-- optional style parent, and default styles for each style family,

192+-- defining default style properties

193+data Styles = Styles

194+ { stylesByName :: M.Map StyleName Style

195+ , listStylesByName :: M.Map StyleName ListStyle

196+ , defaultStyleMap :: M.Map StyleFamily StyleProperties

197+ }

198+ deriving ( Show )

199+

200+-- Styles from a monoid under union

201+instance Monoid Styles where

202+ mempty = Styles M.empty M.empty M.empty

203+ mappend (Styles sBn1 dSm1 lsBn1)

204+ (Styles sBn2 dSm2 lsBn2)

205+ = Styles (M.union sBn1 sBn2)

206+ (M.union dSm1 dSm2)

207+ (M.union lsBn1 lsBn2)

208+

209+-- Not all families from the specifications are implemented, only those we need.

210+-- But there are none that are not mentioned here.

211+data StyleFamily = FaText | FaParagraph

212+-- | FaTable | FaTableCell | FaTableColumn | FaTableRow

213+-- | FaGraphic | FaDrawing | FaChart

214+-- | FaPresentation

215+-- | FaRuby

216+ deriving ( Eq, Ord, Show )

217+

218+instance Lookupable StyleFamily where

219+ lookupTable = [ ( "text" , FaText )

220+ , ( "paragraph" , FaParagraph )

221+-- , ( "table" , FaTable )

222+-- , ( "table-cell" , FaTableCell )

223+-- , ( "table-column" , FaTableColumn )

224+-- , ( "table-row" , FaTableRow )

225+-- , ( "graphic" , FaGraphic )

226+-- , ( "drawing-page" , FaDrawing )

227+-- , ( "chart" , FaChart )

228+-- , ( "presentation" , FaPresentation )

229+-- , ( "ruby" , FaRuby )

230+ ]

231+

232+-- | A named style

233+data Style = Style { styleFamily :: Maybe StyleFamily

234+ , styleParentName :: Maybe StyleName

235+ , listStyle :: Maybe StyleName

236+ , styleProperties :: StyleProperties

237+ }

238+ deriving ( Eq, Show )

239+

240+data StyleProperties = SProps { textProperties :: Maybe TextProperties

241+ , paraProperties :: Maybe ParaProperties

242+-- , tableColProperties :: Maybe TColProperties

243+-- , tableRowProperties :: Maybe TRowProperties

244+-- , tableCellProperties :: Maybe TCellProperties

245+-- , tableProperties :: Maybe TableProperties

246+-- , graphicProperties :: Maybe GraphProperties

247+ }

248+ deriving ( Eq, Show )

249+

250+instance Default StyleProperties where

251+ def = SProps { textProperties = Just def

252+ , paraProperties = Just def

253+ }

254+

255+data TextProperties = PropT { isEmphasised :: Bool

256+ , isStrong :: Bool

257+ , pitch :: Maybe FontPitch

258+ , verticalPosition :: VerticalTextPosition

259+ , underline :: Maybe UnderlineMode

260+ , strikethrough :: Maybe UnderlineMode

261+ }

262+ deriving ( Eq, Show )

263+

264+instance Default TextProperties where

265+ def = PropT { isEmphasised = False

266+ , isStrong = False

267+ , pitch = Just def

268+ , verticalPosition = def

269+ , underline = Nothing

270+ , strikethrough = Nothing

271+ }

272+

273+data ParaProperties = PropP { paraNumbering :: ParaNumbering

274+ , indentation :: LengthOrPercent

275+ , margin_left :: LengthOrPercent

276+ }

277+ deriving ( Eq, Show )

278+

279+instance Default ParaProperties where

280+ def = PropP { paraNumbering = NumberingNone

281+ , indentation = def

282+ , margin_left = def

283+ }

284+

285+----

286+-- All the little data types that make up the properties

287+----

288+

289+data VerticalTextPosition = VPosNormal | VPosSuper | VPosSub

290+ deriving ( Eq, Show )

291+

292+instance Default VerticalTextPosition where

293+ def = VPosNormal

294+

295+instance Read VerticalTextPosition where

296+ readsPrec _ s = [ (VPosSub , s') | ("sub" , s') <- lexS ]

297+ ++ [ (VPosSuper , s') | ("super" , s') <- lexS ]

298+ ++ [ (signumToVPos n , s') | ( n , s') <- readPercent s ]

299+ where

300+ lexS = lex s

301+ signumToVPos n | n < 0 = VPosSub

302+ | n > 0 = VPosSuper

303+ | otherwise = VPosNormal

304+

305+data UnderlineMode = UnderlineModeNormal | UnderlineModeSkipWhitespace

306+ deriving ( Eq, Show )

307+

308+instance Lookupable UnderlineMode where

309+ lookupTable = [ ( "continuous" , UnderlineModeNormal )

310+ , ( "skip-white-space" , UnderlineModeSkipWhitespace )

311+ ]

312+

313+

314+data ParaNumbering = NumberingNone | NumberingKeep | NumberingRestart Int

315+ deriving ( Eq, Show )

316+

317+data LengthOrPercent = LengthValueMM Int | PercentValue Int

318+ deriving ( Eq, Show )

319+

320+instance Default LengthOrPercent where

321+ def = LengthValueMM 0

322+

323+instance Read LengthOrPercent where

324+ readsPrec _ s =

325+ [ (PercentValue percent , s' ) | (percent , s' ) <- readPercent s]

326+ ++ [ (LengthValueMM lengthMM , s'') | (length' , s' ) <- reads s

327+ , (unit , s'') <- reads s'

328+ , let lengthMM = estimateInMillimeter

329+ length' unit

330+ ]

331+

332+data XslUnit = XslUnitMM | XslUnitCM

333+ | XslUnitInch

334+ | XslUnitPoints | XslUnitPica

335+ | XslUnitPixel

336+ | XslUnitEM

337+

338+instance Show XslUnit where

339+ show XslUnitMM = "mm"

340+ show XslUnitCM = "cm"

341+ show XslUnitInch = "in"

342+ show XslUnitPoints = "pt"

343+ show XslUnitPica = "pc"

344+ show XslUnitPixel = "px"

345+ show XslUnitEM = "em"

346+

347+instance Read XslUnit where

348+ readsPrec _ "mm" = [(XslUnitMM , "")]

349+ readsPrec _ "cm" = [(XslUnitCM , "")]

350+ readsPrec _ "in" = [(XslUnitInch , "")]

351+ readsPrec _ "pt" = [(XslUnitPoints , "")]

352+ readsPrec _ "pc" = [(XslUnitPica , "")]

353+ readsPrec _ "px" = [(XslUnitPixel , "")]

354+ readsPrec _ "em" = [(XslUnitEM , "")]

355+ readsPrec _ _ = []

356+

357+-- | Rough conversion of measures into millimeters.

358+-- Pixels and em's are actually implemetation dependant/relative measures,

359+-- so I could not really easily calculate anything exact here even if I wanted.

360+-- But I do not care about exactness right now, as I only use measures

361+-- to determine if a paragraph is "indented" or not.

362+estimateInMillimeter :: Int -> XslUnit -> Int

363+estimateInMillimeter n XslUnitMM = n

364+estimateInMillimeter n XslUnitCM = n * 10

365+estimateInMillimeter n XslUnitInch = n * 25 -- * 25.4

366+estimateInMillimeter n XslUnitPoints = n `div` 3 -- * 1/72 * 25.4

367+estimateInMillimeter n XslUnitPica = n * 4 -- * 12 * 1/72 * 25.4

368+estimateInMillimeter n XslUnitPixel = n `div`3 -- * 1/72 * 25.4

369+estimateInMillimeter n XslUnitEM = n * 7 -- * 16 * 1/72 * 25.4

370+

371+

372+----

373+-- List styles

374+----

375+

376+type ListLevel = Int

377+

378+newtype ListStyle = ListStyle { levelStyles :: M.Map ListLevel ListLevelStyle

379+ }

380+ deriving ( Eq, Show )

381+

382+--

383+getListLevelStyle :: ListLevel -> ListStyle -> Maybe ListLevelStyle

384+getListLevelStyle level ListStyle{..} =

385+ let (lower , exactHit , _) = M.splitLookup level levelStyles

386+ in exactHit <|> fmap fst (M.maxView lower)

387+ -- findBy (`M.lookup` levelStyles) [level, (level-1) .. 1]

388+ -- ^ simpler, but in general less efficient

389+

390+data ListLevelStyle = ListLevelStyle { listLevelType :: ListLevelType

391+ , listItemPrefix :: Maybe String

392+ , listItemSuffix :: Maybe String

393+ , listItemFormat :: ListItemNumberFormat

394+ }

395+ deriving ( Eq, Ord )

396+

397+instance Show ListLevelStyle where

398+ show ListLevelStyle{..} = "<LLS|"

399+ ++ (show listLevelType)

400+ ++ "|"

401+ ++ (maybeToString listItemPrefix)

402+ ++ (show listItemFormat)

403+ ++ (maybeToString listItemSuffix)

404+ ++ ">"

405+ where maybeToString = fromMaybe ""

406+

407+data ListLevelType = LltBullet | LltImage | LltNumbered

408+ deriving ( Eq, Ord, Show )

409+

410+data ListItemNumberFormat = LinfNone

411+ | LinfNumber

412+ | LinfRomanLC | LinfRomanUC

413+ | LinfAlphaLC | LinfAlphaUC

414+ | LinfString String

415+ deriving ( Eq, Ord )

416+

417+instance Show ListItemNumberFormat where

418+ show LinfNone = ""

419+ show LinfNumber = "1"

420+ show LinfRomanLC = "i"

421+ show LinfRomanUC = "I"

422+ show LinfAlphaLC = "a"

423+ show LinfAlphaUC = "A"

424+ show (LinfString s) = s

425+

426+instance Default ListItemNumberFormat where

427+ def = LinfNone

428+

429+instance Read ListItemNumberFormat where

430+ readsPrec _ "" = [(LinfNone , "")]

431+ readsPrec _ "1" = [(LinfNumber , "")]

432+ readsPrec _ "i" = [(LinfRomanLC , "")]

433+ readsPrec _ "I" = [(LinfRomanUC , "")]

434+ readsPrec _ "a" = [(LinfAlphaLC , "")]

435+ readsPrec _ "A" = [(LinfAlphaUC , "")]

436+ readsPrec _ s = [(LinfString s , "")]

437+

438+--------------------------------------------------------------------------------

439+-- Readers

440+--

441+-- ...it seems like a whole lot of this should be automatically deriveable

442+-- or at least moveable into a class. Most of this is data concealed in

443+-- code.

444+--------------------------------------------------------------------------------

445+

446+--

447+readAllStyles :: StyleReader _x Styles

448+readAllStyles = ( readFontPitches

449+ >>?! ( readAutomaticStyles

450+ &&& readStyles ))

451+ >>?§? chooseMax

452+ -- all top elements are always on the same hierarchy level

453+

454+--

455+readStyles :: StyleReader _x Styles

456+readStyles = executeIn NsOffice "styles" $ liftAsSuccess

457+ $ liftA3 Styles

458+ ( tryAll NsStyle "style" readStyle >>^ M.fromList )

459+ ( tryAll NsText "list-style" readListStyle >>^ M.fromList )

460+ ( tryAll NsStyle "default-style" readDefaultStyle >>^ M.fromList )

461+

462+--

463+readAutomaticStyles :: StyleReader _x Styles

464+readAutomaticStyles = executeIn NsOffice "automatic-styles" $ liftAsSuccess

465+ $ liftA3 Styles

466+ ( tryAll NsStyle "style" readStyle >>^ M.fromList )

467+ ( tryAll NsText "list-style" readListStyle >>^ M.fromList )

468+ ( returnV M.empty )

469+

470+--

471+readDefaultStyle :: StyleReader _x (StyleFamily, StyleProperties)

472+readDefaultStyle = lookupAttr NsStyle "family"

473+ >>?! keepingTheValue readStyleProperties

474+

475+--

476+readStyle :: StyleReader _x (StyleName,Style)

477+readStyle = findAttr NsStyle "name"

478+ >>?! keepingTheValue

479+ ( liftA4 Style

480+ ( lookupAttr' NsStyle "family" )

481+ ( findAttr' NsStyle "parent-style-name" )

482+ ( findAttr' NsStyle "list-style-name" )

483+ readStyleProperties

484+ )

485+

486+--

487+readStyleProperties :: StyleReaderSafe _x StyleProperties

488+readStyleProperties = liftA2 SProps

489+ ( readTextProperties >>> choiceToMaybe )

490+ ( readParaProperties >>> choiceToMaybe )

491+

492+--

493+readTextProperties :: StyleReader _x TextProperties

494+readTextProperties =

495+ executeIn NsStyle "text-properties" $ liftAsSuccess

496+ ( liftA6 PropT

497+ ( searchAttr NsXSL_FO "font-style" False isFontEmphasised )

498+ ( searchAttr NsXSL_FO "font-weight" False isFontBold )

499+ ( findPitch )

500+ ( getAttr NsStyle "text-position" )

501+ ( readUnderlineMode )

502+ ( readStrikeThroughMode )

503+ )

504+ where isFontEmphasised = [("normal",False),("italic",True),("oblique",True)]

505+ isFontBold = ("normal",False):("bold",True)

506+ :(map ((,True).show) ([100,200..900]::[Int]))

507+

508+readUnderlineMode :: StyleReaderSafe _x (Maybe UnderlineMode)

509+readUnderlineMode = readLineMode "text-underline-mode"

510+ "text-underline-style"

511+

512+readStrikeThroughMode :: StyleReaderSafe _x (Maybe UnderlineMode)

513+readStrikeThroughMode = readLineMode "text-line-through-mode"

514+ "text-line-through-style"

515+

516+readLineMode :: String -> String -> StyleReaderSafe _x (Maybe UnderlineMode)

517+readLineMode modeAttr styleAttr = proc x -> do

518+ isUL <- searchAttr NsStyle styleAttr False isLinePresent -< x

519+ mode <- lookupAttr' NsStyle modeAttr -< x

520+ if isUL

521+ then case mode of

522+ Just m -> returnA -< Just m

523+ Nothing -> returnA -< Just UnderlineModeNormal

524+ else returnA -< Nothing

525+ where

526+ isLinePresent = [("none",False)] ++ map (,True)

527+ [ "dash" , "dot-dash" , "dot-dot-dash" , "dotted"

528+ , "long-dash" , "solid" , "wave"

529+ ]

530+

531+--

532+readParaProperties :: StyleReader _x ParaProperties

533+readParaProperties =

534+ executeIn NsStyle "paragraph-properties" $ liftAsSuccess

535+ ( liftA3 PropP

536+ ( liftA2 readNumbering

537+ ( isSet' NsText "number-lines" )

538+ ( readAttr' NsText "line-number" )

539+ )

540+ ( liftA2 readIndentation

541+ ( isSetWithDefault NsStyle "auto-text-indent" False )

542+ ( getAttr NsXSL_FO "text-indent" )

543+ )

544+ ( getAttr NsXSL_FO "margin-left" )

545+ )

546+ where readNumbering (Just True) (Just n) = NumberingRestart n

547+ readNumbering (Just True) _ = NumberingKeep

548+ readNumbering _ _ = NumberingNone

549+

550+ readIndentation False indent = indent

551+ readIndentation True _ = def

552+

553+----

554+-- List styles

555+----

556+

557+--

558+readListStyle :: StyleReader _x (StyleName, ListStyle)

559+readListStyle =

560+ findAttr NsStyle "name"

561+ >>?! keepingTheValue

562+ ( liftA ListStyle

563+ $ ( liftA3 SM.union3

564+ ( readListLevelStyles NsText "list-level-style-number" LltNumbered )

565+ ( readListLevelStyles NsText "list-level-style-bullet" LltBullet )

566+ ( readListLevelStyles NsText "list-level-style-image" LltImage )

567+ ) >>^ M.mapMaybe chooseMostSpecificListLevelStyle

568+ )

569+--

570+readListLevelStyles :: Namespace -> ElementName

571+ -> ListLevelType

572+ -> StyleReaderSafe _x (SM.SetMap Int ListLevelStyle)

573+readListLevelStyles namespace elementName levelType =

574+ ( tryAll namespace elementName (readListLevelStyle levelType)

575+ >>^ SM.fromList

576+ )

577+

578+--

579+readListLevelStyle :: ListLevelType -> StyleReader _x (Int, ListLevelStyle)

580+readListLevelStyle levelType = readAttr NsText "level"

581+ >>?! keepingTheValue

582+ ( liftA4 toListLevelStyle

583+ ( returnV levelType )

584+ ( findAttr' NsStyle "num-prefix" )

585+ ( findAttr' NsStyle "num-suffix" )

586+ ( getAttr NsStyle "num-format" )

587+ )

588+ where

589+ toListLevelStyle _ p s LinfNone = ListLevelStyle LltBullet p s LinfNone

590+ toListLevelStyle _ p s f@(LinfString _) = ListLevelStyle LltBullet p s f

591+ toListLevelStyle t p s f = ListLevelStyle t p s f

592+

593+--

594+chooseMostSpecificListLevelStyle :: S.Set ListLevelStyle -> Maybe ListLevelStyle

595+chooseMostSpecificListLevelStyle ls | ls == mempty = Nothing

596+ | otherwise = Just ( F.foldr1 select ls )

597+ where

598+ select ( ListLevelStyle t1 p1 s1 f1 )

599+ ( ListLevelStyle t2 p2 s2 f2 )

600+ = ListLevelStyle (select' t1 t2) (p1 <|> p2) (s1 <|> s2) (selectLinf f1 f2)

601+ select' LltNumbered _ = LltNumbered

602+ select' _ LltNumbered = LltNumbered

603+ select' _ _ = LltBullet

604+ selectLinf LinfNone f2 = f2

605+ selectLinf f1 LinfNone = f1

606+ selectLinf (LinfString _) f2 = f2

607+ selectLinf f1 (LinfString _) = f1

608+ selectLinf f1 _ = f1

609+

610+

611+--------------------------------------------------------------------------------

612+-- Tools to access style data

613+--------------------------------------------------------------------------------

614+

615+--

616+lookupStyle :: StyleName -> Styles -> Maybe Style

617+lookupStyle name Styles{..} = M.lookup name stylesByName

618+

619+--

620+lookupDefaultStyle :: StyleFamily -> Styles -> StyleProperties

621+lookupDefaultStyle family Styles{..} = fromMaybe def

622+ (M.lookup family defaultStyleMap)

623+

624+--

625+lookupDefaultStyle' :: Styles -> StyleFamily -> StyleProperties

626+lookupDefaultStyle' Styles{..} family = fromMaybe def

627+ (M.lookup family defaultStyleMap)

628+

629+--

630+getListStyle :: Style -> Styles -> Maybe ListStyle

631+getListStyle Style{..} styles = listStyle >>= (`lookupListStyleByName` styles)

632+

633+--

634+lookupListStyleByName :: StyleName -> Styles -> Maybe ListStyle

635+lookupListStyleByName name Styles{..} = M.lookup name listStylesByName

636+

637+

638+-- | Returns a chain of parent of the current style. The direct parent will

639+-- be the first element of the list, followed by its parent and so on.

640+-- The current style is not in the list.

641+parents :: Style -> Styles -> [Style]

642+parents style styles = unfoldr findNextParent style -- Ha!

643+ where findNextParent Style{..}

644+ = fmap duplicate $ (`lookupStyle` styles) =<< styleParentName

645+

646+-- | Looks up the style family of the current style. Normally, every style

647+-- should have one. But if not, all parents are searched.

648+getStyleFamily :: Style -> Styles -> Maybe StyleFamily

649+getStyleFamily style@Style{..} styles

650+ = styleFamily

651+ <|> (F.asum $ map (`getStyleFamily` styles) $ parents style styles)

652+

653+-- | Each 'Style' has certain 'StyleProperties'. But sometimes not all property

654+-- values are specified. Instead, a value might be inherited from a

655+-- parent style. This function makes this chain of inheritance

656+-- concrete and easily accessible by encapsulating the necessary lookups.

657+-- The resulting list contains the direct properties of the style as the first

658+-- element, the ones of the direct parent element as the next one, and so on.

659+--

660+-- Note: There should also be default properties for each style family. These

661+-- are @not@ contained in this list because properties inherited from

662+-- parent elements take precedence over default styles.

663+--

664+-- This function is primarily meant to be used through convenience wrappers.

665+--

666+stylePropertyChain :: Style -> Styles -> [StyleProperties]

667+stylePropertyChain style styles

668+ = map styleProperties (style : parents style styles)

669+

670+--

671+extendedStylePropertyChain :: [Style] -> Styles -> [StyleProperties]

672+extendedStylePropertyChain [] _ = []

673+extendedStylePropertyChain [style] styles = (stylePropertyChain style styles)

674+ ++ (maybeToList (fmap (lookupDefaultStyle' styles) (getStyleFamily style styles)))

675+extendedStylePropertyChain (style:trace) styles = (stylePropertyChain style styles)

676+ ++ (extendedStylePropertyChain trace styles)

677+-- Optimizable with Data.Sequence

678+

679+--

680+extendedStylePropertyChain' :: [Style] -> Styles -> Maybe [StyleProperties]

681+extendedStylePropertyChain' [] _ = Nothing

682+extendedStylePropertyChain' [style] styles = Just (

683+ (stylePropertyChain style styles)

684+ ++ (maybeToList (fmap (lookupDefaultStyle' styles) (getStyleFamily style styles)))

685+ )

686+extendedStylePropertyChain' (style:trace) styles = fmap ((stylePropertyChain style styles) ++)

687+ (extendedStylePropertyChain' trace styles)

688+

689+--

690+stylePropertyChain' :: Styles -> Style -> [StyleProperties]

691+stylePropertyChain' = flip stylePropertyChain

692+

693+--

694+getStylePropertyChain :: StyleName -> Styles -> [StyleProperties]

695+getStylePropertyChain name styles = maybe []

696+ (`stylePropertyChain` styles)

697+ (lookupStyle name styles)

698+

699+--

700+getPropertyChain :: (StyleProperties -> Maybe a) -> Style -> Styles -> [a]

701+getPropertyChain extract style styles = catMaybes

702+ $ map extract

703+ $ stylePropertyChain style styles

704+

705+--

706+textPropertyChain :: Style -> Styles -> [TextProperties]

707+textPropertyChain = getPropertyChain textProperties

708+

709+--

710+paraPropertyChain :: Style -> Styles -> [ParaProperties]

711+paraPropertyChain = getPropertyChain paraProperties

712+

713+--

714+getTextProperty :: (TextProperties -> a) -> Style -> Styles -> Maybe a

715+getTextProperty extract style styles = fmap extract

716+ $ listToMaybe

717+ $ textPropertyChain style styles

718+

719+--

720+getTextProperty' :: (TextProperties -> Maybe a) -> Style -> Styles -> Maybe a

721+getTextProperty' extract style styles = F.asum

722+ $ map extract

723+ $ textPropertyChain style styles

724+

725+--

726+getParaProperty :: (ParaProperties -> a) -> Style -> Styles -> Maybe a

727+getParaProperty extract style styles = fmap extract

728+ $ listToMaybe

729+ $ paraPropertyChain style styles

730+

731+-- | Lifts the reader into another readers' state.

732+liftStyles :: (OdtConverterState s -> OdtConverterState Styles)

733+ -> (OdtConverterState Styles -> OdtConverterState s )

734+ -> XMLReader s x x

735+liftStyles extract inject = switchState extract inject

736+ $ convertingExtraState M.empty readAllStyles

737+

src/Text/Pandoc/Shared.hs+6−6

@@ -683,16 +683,16 @@ headerLtEq _ _ = False

683683-- | Generate a unique identifier from a list of inlines.

684684-- Second argument is a list of already used identifiers.

685685uniqueIdent :: [Inline] -> [String] -> String

686−uniqueIdent title' usedIdents =

687− let baseIdent = case inlineListToIdentifier title' of

686+uniqueIdent title' usedIdents

687+ = let baseIdent = case inlineListToIdentifier title' of

688688 "" -> "section"

689689 x -> x

690− numIdent n = baseIdent ++ "-" ++ show n

691− in if baseIdent `elem` usedIdents

692− then case find (\x -> numIdent x `notElem` usedIdents) ([1..60000] :: [Int]) of

690+ numIdent n = baseIdent ++ "-" ++ show n

691+ in if baseIdent `elem` usedIdents

692+ then case find (\x -> numIdent x `notElem` usedIdents) ([1..60000] :: [Int]) of

693693 Just x -> numIdent x

694694 Nothing -> baseIdent -- if we have more than 60,000, allow repeats

695− else baseIdent

695+ else baseIdent

696696

697697-- | True if block is a Header block.

698698isHeaderBlock :: Block -> Bool

tests/Tests/Readers/Odt.hsnew file+165

@@ -0,0 +1,165 @@

1+module Tests.Readers.Odt (tests) where

3+import Control.Monad ( liftM )

4+import Text.Pandoc.Options

5+import Text.Pandoc.Readers.Native

6+import Text.Pandoc.Readers.Markdown

7+import Text.Pandoc.Definition

8+import Text.Pandoc.Error

9+import Tests.Helpers

10+import Test.Framework

11+--import Test.HUnit (assertBool)

12+--import Test.Framework.Providers.HUnit

13+import qualified Data.ByteString.Lazy as B

14+import Text.Pandoc.Readers.Odt

15+import Text.Pandoc.Writers.Native (writeNative)

16+import qualified Data.Map as M

17+--import Text.Pandoc.MediaBag (MediaBag, lookupMedia, mediaDirectory)

18+--import Codec.Archive.Zip

19+

20+

21+tests :: [Test]

22+tests = testsComparingToMarkdown ++ testsComparingToNative

23+

24+testsComparingToMarkdown :: [Test]

25+testsComparingToMarkdown = map nameToTest namesOfTestsComparingToMarkdown

26+ where nameToTest name = createTest

27+ compareOdtToMarkdown

28+ name

29+ (toOdtPath name)

30+ (toMarkdownPath name)

31+ toOdtPath name = "odt/odt/" ++ name ++ ".odt"

32+ toMarkdownPath name = "odt/markdown/" ++ name ++ ".md"

33+

34+testsComparingToNative :: [Test]

35+testsComparingToNative = map nameToTest namesOfTestsComparingToNative

36+ where nameToTest name = createTest

37+ compareOdtToNative

38+ name

39+ (toOdtPath name)

40+ (toNativePath name)

41+ toOdtPath name = "odt/odt/" ++ name ++ ".odt"

42+ toNativePath name = "odt/native/" ++ name ++ ".native"

43+

44+

45+newtype NoNormPandoc = NoNormPandoc {unNoNorm :: Pandoc}

46+ deriving ( Show )

47+

48+instance ToString NoNormPandoc where

49+ toString d = writeNative def{ writerStandalone = s } $ toPandoc d

50+ where s = case d of

51+ NoNormPandoc (Pandoc (Meta m) _)

52+ | M.null m -> False

53+ | otherwise -> True

54+

55+instance ToPandoc NoNormPandoc where

56+ toPandoc = unNoNorm

57+

58+getNoNormVia :: (a -> Pandoc) -> String -> Either PandocError a -> NoNormPandoc

59+getNoNormVia _ readerName (Left _) = error (readerName ++ " reader failed")

60+getNoNormVia f _ (Right a) = NoNormPandoc (f a)

61+

62+type TestCreator = ReaderOptions

63+ -> FilePath -> FilePath

64+ -> IO (NoNormPandoc, NoNormPandoc)

65+

66+compareOdtToNative :: TestCreator

67+compareOdtToNative opts odtPath nativePath = do

68+ nativeFile <- Prelude.readFile nativePath

69+ odtFile <- B.readFile odtPath

70+ let native = getNoNormVia id "native" $ readNative nativeFile

71+ let odt = getNoNormVia fst "odt" $ readOdt opts odtFile

72+ return (odt,native)

73+

74+compareOdtToMarkdown :: TestCreator

75+compareOdtToMarkdown opts odtPath markdownPath = do

76+ markdownFile <- Prelude.readFile markdownPath

77+ odtFile <- B.readFile odtPath

78+ let markdown = getNoNormVia id "markdown" $ readMarkdown opts markdownFile

79+ let odt = getNoNormVia fst "odt" $ readOdt opts odtFile

80+ return (odt,markdown)

81+

82+

83+createTest :: TestCreator

84+ -> TestName

85+ -> FilePath -> FilePath

86+ -> Test

87+createTest creator name path1 path2 =

88+ buildTest $ liftM (test id name) (creator def path1 path2)

89+

90+{-

91+--

92+

93+getMedia :: FilePath -> FilePath -> IO (Maybe B.ByteString)

94+getMedia archivePath mediaPath = do

95+ zf <- B.readFile archivePath >>= return . toArchive

96+ return $ findEntryByPath ("Pictures/" ++ mediaPath) zf >>= (Just . fromEntry)

97+

98+compareMediaPathIO :: FilePath -> MediaBag -> FilePath -> IO Bool

99+compareMediaPathIO mediaPath mediaBag odtPath = do

100+ odtMedia <- getMedia odtPath mediaPath

101+ let mbBS = case lookupMedia mediaPath mediaBag of

102+ Just (_, bs) -> bs

103+ Nothing -> error ("couldn't find " ++

104+ mediaPath ++

105+ " in media bag")

106+ odtBS = case odtMedia of

107+ Just bs -> bs

108+ Nothing -> error ("couldn't find " ++

109+ mediaPath ++

110+ " in media bag")

111+ return $ mbBS == odtBS

112+

113+compareMediaBagIO :: FilePath -> IO Bool

114+compareMediaBagIO odtFile = do

115+ df <- B.readFile odtFile

116+ let (_, mb) = readOdt def df

117+ bools <- mapM

118+ (\(fp, _, _) -> compareMediaPathIO fp mb odtFile)

119+ (mediaDirectory mb)

120+ return $ and bools

121+

122+testMediaBagIO :: String -> FilePath -> IO Test

123+testMediaBagIO name odtFile = do

124+ outcome <- compareMediaBagIO odtFile

125+ return $ testCase name (assertBool

126+ ("Media didn't match media bag in file " ++ odtFile)

127+ outcome)

128+

129+testMediaBag :: String -> FilePath -> Test

130+testMediaBag name odtFile = buildTest $ testMediaBagIO name odtFile

131+-}

132+--

133+

134+

135+

136+namesOfTestsComparingToMarkdown :: [ String ]

137+namesOfTestsComparingToMarkdown = [ "bold"

138+-- , "citation"

139+ , "endnote"

140+ , "externalLink"

141+ , "footnote"

142+ , "headers"

143+-- , "horizontalRule"

144+-- , "image"

145+ , "italic"

146+-- , "listBlocks"

147+ , "paragraph"

148+ , "strikeout"

149+-- , "trackedChanges"

150+ , "underlined"

151+ ]

152+

153+namesOfTestsComparingToNative :: [ String ]

154+namesOfTestsComparingToNative = [ "blockquote"

155+ , "orderedListMixed"

156+ , "orderedListRoman"

157+ , "orderedListSimple"

158+ , "referenceToChapter"

159+ , "referenceToListItem"

160+ , "referenceToText"

161+ , "simpleTable"

162+-- , "table"

163+ , "unicode"

164+ , "unorderedList"

165+ ]

tests/odt/markdown/bold.mdnew file+1

@@ -0,0 +1 @@

1+Here comes **bold** text

tests/odt/markdown/citation.mdnew file+1

@@ -0,0 +1 @@

1+Some text[@Ex] with a citation.

tests/odt/markdown/endnote.mdnew file+3

@@ -0,0 +1,3 @@

1+Some text[^1] with an endnote.

3+[^1]: Endnote text

tests/odt/markdown/externalLink.mdnew file+1

@@ -0,0 +1 @@

1+Here comes an [external link](http://example.com/) to example.com.

tests/odt/markdown/footnote.mdnew file+3

@@ -0,0 +1,3 @@

1+Some text[^1] with a footnote.

3+[^1]: Footnote text

tests/odt/markdown/headers.mdnew file+9

@@ -0,0 +1,9 @@

1+# A header (Lv 1)

3+A paragraph

5+## Another header (Lv 2)

7+Another paragraph

9+# Back to Level 1

tests/odt/markdown/horizontalRule.mdnew file+1

@@ -0,0 +1 @@

1+---

tests/odt/markdown/image.mdnew file+1

@@ -0,0 +1 @@

1+![](10000000000000FA000000FAD6A15225.jpg)

tests/odt/markdown/imageIndex.mdnew file+6

@@ -0,0 +1,6 @@

1+# Abbildungsverzeichnis

3+Abbildung 1: Image caption

5+![Abbildung 1: Image caption](10000000000000FA000000FAD6A15225.jpg)

tests/odt/markdown/imageWithCaption.mdnew file+1

@@ -0,0 +1 @@

1+![Abbildung 1: Image caption](10000000000000FA000000FAD6A15225.jpg)

tests/odt/markdown/italic.mdnew file+1

@@ -0,0 +1 @@

1+Here comes *italic* text

tests/odt/markdown/listBlocks.mdnew file+6

@@ -0,0 +1,6 @@

1+<text:list xml:id="list2666723676250588421" text:style-name="L6">

2+<text:list-header>

3+<text:p text:style-name="P1">Indented text in a list.</text:p>

4+</text:list-header>

5+<text:list-item>

6+<text:p text:style-name="P1">This is a numbered block.<text:line-break/>It contains several paragraphs of text.<text:line-break/>Like this.</text:p></text:list-item><text:list-item><text:p text:style-name="P1">Next item.</text:p></text:list-item></text:list></office:text></office:body></office:document-content>

tests/odt/markdown/paragraph.mdnew file+5

@@ -0,0 +1,5 @@

1+This is a paragraph.

3+This is another paragraph.

5+This is a third one.

tests/odt/markdown/strikeout.mdnew file+1

@@ -0,0 +1 @@

1+Here comes text that was ~~striken out~~.

tests/odt/markdown/trackedChanges.mdnew file+1

@@ -0,0 +1 @@

1+Some text with and inserted text.

tests/odt/markdown/underlined.mdnew file+1

@@ -0,0 +1 @@

1+Here comes *underlined* text

tests/odt/native/blockquote.nativenew file+1

@@ -0,0 +1 @@

1+[Para [Str "Normal"],BlockQuote [Para [Str "Indented",Space,Str "(1cm)"]]]

tests/odt/native/orderedListMixed.nativenew file+1

@@ -0,0 +1 @@

1+Pandoc (Meta {unMeta = fromList []}) [OrderedList (1,Decimal,Period) [[Plain [Str "A",Space,Str "list",Space,Str "item"]],[Plain [Str "A",Space,Str "second"]],[Para [Str "A",Space,Str "third"],OrderedList (1,Decimal,Period) [[Para [Str "New",Space,Str "level!"],OrderedList (1,LowerAlpha,OneParen) [[Plain [Str "And",Space,Str "another!"]],[Plain [Str "It's",Space,Str "great",Space,Str "up",Space,Str "here!"]]]],[Plain [Str "Oh",Space,Str "noes"]],[Plain [Str "We",Space,Str "fell!"]]]],[Plain [Str "Maybe",Space,Str "someone"]],[Plain [Str "Pushed",Space,Str "us?"]]]]

tests/odt/native/orderedListRoman.nativenew file+1

@@ -0,0 +1 @@

1+Pandoc (Meta {unMeta = fromList []}) [OrderedList (1,UpperRoman,Period) [[Plain[Str "A",Space,Str "list",Space,Str "item"]],[Plain [Str "A",Space,Str "second"]],[Para [Str "A",Space,Str "third"],OrderedList (1,UpperRoman,Period) [[Para [Str "New",Space,Str "level!"],OrderedList (1,UpperRoman,Period) [[Plain [Str "And",Space,Str "another!"]],[Plain [Str "It's",Space,Str "great",Space,Str "up",Space,Str "here!"]]]],[Plain [Str "Oh",Space,Str "noes"]],[Plain [Str "We",Space,Str "fell!"]]]],[Plain [Str "Maybe",Space,Str "someone"]],[Plain [Str "Pushed",Space,Str "us?"]]]]

tests/odt/native/orderedListSimple.nativenew file+1

@@ -0,0 +1 @@

1+Pandoc (Meta {unMeta = fromList []}) [OrderedList (1,Decimal,Period) [[Plain [Str "A",Space,Str "list",Space,Str "item"]],[Plain [Str "A",Space,Str "second"]],[Para [Str "A",Space,Str "third"],OrderedList (1,Decimal,Period) [[Para [Str "New",Space,Str "level!"],OrderedList (1,Decimal,Period) [[Plain [Str "And",Space,Str "another!"]],[Plain [Str "It's",Space,Str "great",Space,Str "up",Space,Str "here!"]]]],[Plain [Str "Oh",Space,Str "noes"]],[Plain [Str "We",Space,Str "fell!"]]]],[Plain [Str "Maybe",Space,Str "someone"]],[Plain [Str "Pushed",Space,Str "us?"]]]]

tests/odt/native/referenceToChapter.nativenew file+1

@@ -0,0 +1 @@

1+[Header 1 ("a-chapter",[],[]) [Span ("anchor",[],[]) [],Str "A",Space,Str "chapter"],Para [Str "Some",Space,Str "text."],Header 1 ("another-chapter",[],[]) [Str "Another",Space,Str "chapter"],Para [Str "A",Space,Str "reference",Space,Str "to",Space,Str "."],Para [Str "A",Space,Str "reference",Space,Str "to",Space,Link [Str "A",Space,Str "chapter"] ("#anchor",""),Str "."]]

tests/odt/native/referenceToListItem.nativenew file+1

@@ -0,0 +1 @@

1+[OrderedList (1,Decimal,Period) [[Plain [Span ("anchor",[],[]) [],Str "A",Space,Str "list",Space,Str "item"]],[Plain [Str "Another",Space,Str "list",Space,Str "item"]]],Para [Str "A",Space,Str "reference",Space,Str "to",Space,Str "list",Space,Str "item",Space,Link [Str "1."] ("#anchor",""),Str "."],Para [],Para []]

tests/odt/native/referenceToText.nativenew file+1

@@ -0,0 +1 @@

1+[Para [Span ("an anchor",[],[]) [],Str "Some",Space,Str "text."],Para [Str "A",Space,Str "reference",Space,Str "to",Space,Link [Str "Some",Space,Str "text"] ("#an anchor",""),Str "."]]

tests/odt/native/simpleTable.nativenew file+1

@@ -0,0 +1 @@

1+[Table [] [] [] [] [[[Plain [Str "Content"]],[Plain [Str "More",Space,Str "content"]]]],Para []]

tests/odt/native/unicode.nativenew file+1

@@ -0,0 +1 @@

1+[Para [Str "\8220\8221\8217\231\1256\169\188\1074\1073\1060\1064\246\201\181"]]

tests/odt/native/unorderedList.nativenew file+1

@@ -0,0 +1 @@

1+[BulletList [[Plain [Str "A",Space,Str "list",Space,Str "item"]],[Plain [Str "A",Space,Str "second"]],[Para [Str "A",Space,Str "third"],BulletList [[Para [Str "New",Space,Str "level!"],BulletList [[Plain [Str "And",Space,Str "another!"]],[Plain [Str "It's",Space,Str "great",Space,Str "up",Space,Str "here!"]]]],[Plain [Str "Oh",Space,Str "noes"]],[Plain [Str "We",Space,Str "fell!"]]]],[Plain [Str "Maybe",Space,Str "someone"]],[Plain [Str "Pushed",Space,Str "us?"]]]]

tests/odt/odt/blockquote.odtnew file

Binary file not shown.

tests/odt/odt/bold.odtnew file

Binary file not shown.

tests/odt/odt/citation.odtnew file

Binary file not shown.

tests/odt/odt/endnote.odtnew file

Binary file not shown.

tests/odt/odt/expression.odtnew file

Binary file not shown.

tests/odt/odt/expressionUnevaluated.odtnew file

Binary file not shown.

tests/odt/odt/externalLink.odtnew file

Binary file not shown.

tests/odt/odt/footnote.odtnew file

Binary file not shown.

tests/odt/odt/formula.odtnew file

Binary file not shown.

tests/odt/odt/headers.odtnew file

Binary file not shown.

tests/odt/odt/hiddenTextByStyle.odtnew file

Binary file not shown.

tests/odt/odt/hiddenTextByVariable.odtnew file

Binary file not shown.

tests/odt/odt/horizontalRule.odtnew file

Binary file not shown.

tests/odt/odt/image.odtnew file

Binary file not shown.

tests/odt/odt/imageIndex.odtnew file

Binary file not shown.

tests/odt/odt/imageWithCaption.odtnew file

Binary file not shown.

tests/odt/odt/italic.odtnew file

Binary file not shown.

tests/odt/odt/listBlocks.odtnew file

Binary file not shown.

tests/odt/odt/orderedListMixed.odtnew file

Binary file not shown.

tests/odt/odt/orderedListRoman.odtnew file

Binary file not shown.

tests/odt/odt/orderedListSimple.odtnew file

Binary file not shown.

tests/odt/odt/paragraph.odtnew file

Binary file not shown.

tests/odt/odt/referenceAllInOne.odtnew file

Binary file not shown.

tests/odt/odt/referenceToChapter.odtnew file

Binary file not shown.

tests/odt/odt/referenceToListItem.odtnew file

Binary file not shown.

tests/odt/odt/referenceToText.odtnew file

Binary file not shown.

tests/odt/odt/simpleTable.odtnew file

Binary file not shown.

tests/odt/odt/strikeout.odtnew file

Binary file not shown.

tests/odt/odt/table.odtnew file

Binary file not shown.

tests/odt/odt/tableWithCaption.odtnew file

Binary file not shown.

tests/odt/odt/trackedChanges.odtnew file

Binary file not shown.

tests/odt/odt/underlined.odtnew file

Binary file not shown.

tests/odt/odt/unicode.odtnew file

Binary file not shown.

tests/odt/odt/unorderedList.odtnew file

Binary file not shown.

tests/odt/odt/variable.odtnew file

Binary file not shown.

tests/test-pandoc.hs+2

@@ -11,6 +11,7 @@ import qualified Tests.Readers.Org

1111import qualified Tests.Readers.HTML

1212import qualified Tests.Readers.RST

1313import qualified Tests.Readers.Docx

14+import qualified Tests.Readers.Odt

1415import qualified Tests.Readers.Txt2Tags

1516import qualified Tests.Readers.EPUB

1617import qualified Tests.Writers.ConTeXt

@@ -51,6 +52,7 @@ tests = [ testGroup "Old" Tests.Old.tests

5152 , testGroup "Org" Tests.Readers.Org.tests

5253 , testGroup "RST" Tests.Readers.RST.tests

5354 , testGroup "Docx" Tests.Readers.Docx.tests

55+ , testGroup "Odt" Tests.Readers.Odt.tests

5456 , testGroup "Txt2Tags" Tests.Readers.Txt2Tags.tests

5557 , testGroup "EPUB" Tests.Readers.EPUB.tests

5658 ]