a61dce8 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Merge pull request #3714 from tarleb/odt-reader-cleanup

a61dce8John MacFarlane9 years ago

src/Text/Pandoc/Readers/Odt/Arrows/State.hs−90

compare with master

unifiedsplit

@@ -58,10 +58,6 @@ newtype ArrowState state a b = ArrowState

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

59withState = ArrowState . uncurry

61−-- | Constructor

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

63−withState' = ArrowState

64−

65-- | Constructor

61-- | Constructor

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

62modifyState :: (state -> state ) -> ArrowState state a a

67modifyState = ArrowState . first

63modifyState = ArrowState . first

@@ -78,10 +74,6 @@ fromState = ArrowState . (.fst)

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

74extractFromState :: (state -> b ) -> ArrowState state x b

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

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

81−-- | Constructor

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

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

84−

85-- | Constructor

77-- | Constructor

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

78tryModifyState :: (state -> Either f state)

87 -> ArrowState state a (Either f a)

79 -> ArrowState state a (Either f a)

@@ -107,43 +99,9 @@ instance ArrowChoice (ArrowState state) where

107 Left l -> (s, Left l)

99 Left l -> (s, Left l)

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

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

109

101

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−

115instance ArrowApply (ArrowState state) where

102instance ArrowApply (ArrowState state) where

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

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

117

104

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.

105-- | Switches the type of the state temporarily.

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

106-- Drops the intermediate result state, behaving like a fallible

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

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

@@ -175,42 +133,6 @@ foldS :: (Foldable f, Monoid m) => ArrowState s x m -> ArrowState s (f x) m

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

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

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

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

177

135

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

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

215-- 'MonadPlus'.

137-- 'MonadPlus'.

216iterateS :: (Foldable f, MonadPlus m)

138iterateS :: (Foldable f, MonadPlus m)

@@ -239,15 +161,3 @@ iterateS' a = ArrowState $ \(s,f) -> foldr (a' s) (s,Right mzero) f

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

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

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

162 (_ ,Left e ) -> (s ,Left e )

241 a' _ _ e = e

163 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.hs+4−268

@@ -40,10 +40,7 @@ with an equivalent return value.

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

42import Control.Arrow

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

43+import Control.Monad ( join )

44−

45−import qualified Data.Foldable as F

46−import Data.Monoid

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

45import Text.Pandoc.Readers.Odt.Generic.Fallible

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

46import Text.Pandoc.Readers.Odt.Generic.Utils

@@ -63,12 +60,6 @@ and5 :: (Arrow a)

63and6 :: (Arrow a)

60and6 :: (Arrow a)

64 => a b c0->a b c1->a b c2->a b c3->a b c4->a b c5

61 => a b c0->a b c1->a b c2->a b c3->a b c4->a b c5

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

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

66−and7 :: (Arrow a)

67− => a b c0->a b c1->a b c2->a b c3->a b c4->a b c5->a b c6

68− -> a b (c0,c1,c2,c3,c4,c5,c6 )

69−and8 :: (Arrow a)

70− => a b c0->a b c1->a b c2->a b c3->a b c4->a b c5->a b c6->a b c7

71− -> a b (c0,c1,c2,c3,c4,c5,c6,c7)

73and3 a b c = (and2 a b ) &&& c

64and3 a b c = (and2 a b ) &&& c

74 >>^ \((z,y ) , x) -> (z,y,x )

65 >>^ \((z,y ) , x) -> (z,y,x )

@@ -78,10 +69,6 @@ and5 a b c d e = (and4 a b c d ) &&& e

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

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

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

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

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

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

81−and7 a b c d e f g = (and6 a b c d e f ) &&& g

82− >>^ \((z,y,x,w,v,u ) , t) -> (z,y,x,w,v,u,t )

83−and8 a b c d e f g h = (and7 a b c d e f g) &&& h

84− >>^ \((z,y,x,w,v,u,t) , s) -> (z,y,x,w,v,u,t,s)

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

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

87liftA2 f a b = a &&& b >>^ uncurry f

74liftA2 f a b = a &&& b >>^ uncurry f

@@ -98,19 +85,11 @@ liftA5 :: (Arrow a) => (z->y->x->w->v -> r)

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

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

99 -> a b z->a b y->a b x->a b w->a b v->a b u

86 -> a b z->a b y->a b x->a b w->a b v->a b u

100 -> a b r

87 -> a b r

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

102− -> a b z->a b y->a b x->a b w->a b v->a b u->a b t

103− -> a b r

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

105− -> a b z->a b y->a b x->a b w->a b v->a b u->a b t->a b s

106− -> a b r

107

108liftA3 fun a b c = and3 a b c >>^ uncurry3 fun

89liftA3 fun a b c = and3 a b c >>^ uncurry3 fun

109liftA4 fun a b c d = and4 a b c d >>^ uncurry4 fun

90liftA4 fun a b c d = and4 a b c d >>^ uncurry4 fun

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

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

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

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

112−liftA7 fun a b c d e f g = and7 a b c d e f g >>^ uncurry7 fun

113−liftA8 fun a b c d e f g h = and8 a b c d e f g h >>^ uncurry8 fun

114

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

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

116liftA fun a = a >>^ fun

95liftA fun a = a >>^ fun

@@ -124,28 +103,12 @@ liftA fun a = a >>^ fun

124duplicate :: (Arrow a) => a b (b,b)

103duplicate :: (Arrow a) => a b (b,b)

125duplicate = arr $ join (,)

104duplicate = arr $ join (,)

126

105

127−-- | Lifts the combination of two values into an arrow.

128−joinOn :: (Arrow a) => (x -> y -> z) -> a (x,y) z

129−joinOn = arr.uncurry

130−

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

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

132-- (The %-symbol was chosen to evoke an association with pairs.)

107-- (The %-symbol was chosen to evoke an association with pairs.)

133(>>%) :: (Arrow a) => a x (b,c) -> (b -> c -> d) -> a x d

108(>>%) :: (Arrow a) => a x (b,c) -> (b -> c -> d) -> a x d

134a >>% f = a >>^ uncurry f

109a >>% f = a >>^ uncurry f

135

110

136−-- | '(>>%)' with its arguments flipped

137−(%<<) :: (Arrow a) => (b -> c -> d) -> a x (b,c) -> a x d

138−(%<<) = flip (>>%)

139−

140−-- | Precomposition with an uncurried function

141−(%>>) :: (Arrow a) => (b -> c -> d) -> a d r -> a (b,c) r

142−f %>> a = uncurry f ^>> a

143−

144−-- | Precomposition with an uncurried function (right to left variant)

145−(<<%) :: (Arrow a) => a d r -> (b -> c -> d) -> a (b,c) r

146−(<<%) = flip (%>>)

147−

148−infixr 2 >>%, %<<, %>>, <<%

111+infixr 2 >>%

149

112

150

113

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

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

@@ -156,56 +119,6 @@ infixr 2 >>%, %<<, %>>, <<%

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

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

157keepingTheValue a = returnA &&& a

120keepingTheValue a = returnA &&& a

158

121

159−-- | Duplicate a value and apply an arrow to the first instance.

160−-- Aequivalent to

161−-- > \a -> duplicate >>> first a

162−-- or

163−-- > \a -> a &&& returnA

164−keepingTheValue' :: (Arrow a) => a b c -> a b (c,b)

165−keepingTheValue' a = a &&& returnA

166−

167−-- | 'bind' from the "Maybe"-Monad lifted into an 'ArrowChoice'.

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

169−-- combine as nicely in arrow form.

170−-- The current implementation is not the most efficient one, because it can

171−-- not return directly if a 'Nothing' is encountered. That in turn follows

172−-- from the type system, as 'Nothing' has an "invisible" type parameter that

173−-- can not be dropped early.

174−--

175−-- Also, there probably is a way to generalize this to other monads

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

177−-- I have a feeling there is a new Arrow-typeclass to be found that is less

178−-- restrictive than 'ArrowApply'. If it is already out there,

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

180−(>>>=) :: (ArrowChoice a) => a x (Maybe b) -> a b (Maybe c) -> a x (Maybe c)

181−a1 >>>= a2 = a1 >>> maybeToChoice >>> right a2 >>> choiceToMaybe >>^ join

182−

183−infixr 2 >>>=

184−

185−-- | 'mplus' Lifted into an arrow. No 'ArrowPlus' required.

186−-- (But still different from a true bind)

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

188−(>++<) = liftA2 mplus

189−

190−-- | Left-compose with a pure function

191−leftLift :: (ArrowChoice a) => (l -> l') -> a (Either l r) (Either l' r)

192−leftLift = left.arr

193−

194−-- | Right-compose with a pure function

195−rightLift :: (ArrowChoice a) => (r -> r') -> a (Either l r) (Either l r')

196−rightLift = right.arr

197−

198−

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

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

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

202−

203−l ^+++ r = leftLift l >>> right r

204−l +++^ r = left l >>> rightLift r

205−l ^+++^ r = leftLift l >>> rightLift r

206−

207−infixr 2 ^+++, +++^, ^+++^

208−

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

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

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

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

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

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

@@ -218,33 +131,12 @@ infixr 2 ^||| , |||^, ^|||^

218

131

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

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

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

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

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

222

134

223l ^&&& r = arr l &&& r

135l ^&&& r = arr l &&& r

224l &&&^ r = l &&& arr r

136l &&&^ r = l &&& arr r

225−l ^&&&^ r = arr l &&& arr r

226−

227−infixr 3 ^&&&, &&&^, ^&&&^

228

137

229−( ^*** ) :: (Arrow a) => (b -> c) -> a b' c' -> a (b,b') (c,c')

138+infixr 3 ^&&&, &&&^

230−( ***^ ) :: (Arrow a) => a b c -> (b' -> c') -> a (b,b') (c,c')

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

232

139

233−l ^*** r = arr l *** r

234−l ***^ r = l *** arr r

235−l ^***^ r = arr l *** arr r

236−

237−infixr 3 ^***, ***^, ^***^

238−

239−-- | A version of

240−--

241−-- >>> \p -> arr (\x -> if p x the Right x else Left x)

242−--

243−-- but with p being an arrow

244−choose :: (ArrowChoice a) => a b Bool -> a b (Either b b)

245−choose checkValue = keepingTheValue checkValue >>^ select

246− where select (x,True ) = Right x

247− select (x,False ) = Left x

248

140

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

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

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

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

@@ -258,130 +150,15 @@ maybeToChoice = arr maybeToEither

258returnV :: (Arrow a) => c -> a x c

150returnV :: (Arrow a) => c -> a x c

259returnV = arr.const

151returnV = arr.const

260

152

261−-- | 'returnA' dropping everything

262−returnA_ :: (Arrow a) => a _b ()

263−returnA_ = returnV ()

264−

265−-- | Wrapper for an arrow that can be evaluated im parallel. All

266−-- Arrows can be evaluated in parallel, as long as they return a

267−-- monoid.

268−newtype ParallelArrow a b c = CoEval { evalParallelArrow :: a b c }

269− deriving (Eq, Ord, Show)

270−

271−instance (Arrow a, Monoid m) => Monoid (ParallelArrow a b m) where

272− mempty = CoEval $ returnV mempty

273− (CoEval a) `mappend` (CoEval ~b) = CoEval $ a &&& b >>% mappend

274−

275−-- | Evaluates a collection of arrows in a parallel fashion.

276−--

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

278−-- so the actual execution order and parallelity depends on the

279−-- implementation of '(&&&)' in the arrow in question.

280−-- The default implementation of '(&&&)' for example keeps the

281−-- order as given in the collection.

282−--

283−-- This function can be seen as a generalization of

284−-- 'Control.Applicative.sequenceA' to arrows or as an alternative to

285−-- a fold with 'Control.Applicative.WrappedArrow', which

286−-- substitutes the monoid with function application.

287−--

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

289−coEval = evalParallelArrow . (F.foldMap CoEval)

290−

291-- | Defines Left as failure, Right as success

153-- | Defines Left as failure, Right as success

292type FallibleArrow a input failure success = a input (Either failure success)

154type FallibleArrow a input failure success = a input (Either failure success)

293

155

294−type ReFallibleArrow a failure success success'

295− = FallibleArrow a (Either failure success) failure success'

296−

297−-- | Wrapper for fallible arrows. Fallible arrows are all arrows that return

298−-- an Either value where left is a faliure and right is a success value.

299−newtype AlternativeArrow a input failure success

300− = TryArrow { evalAlternativeArrow :: FallibleArrow a input failure success }

301−

302−

303−instance (ArrowChoice a, Monoid failure)

304− => Monoid (AlternativeArrow a input failure success) where

305− mempty = TryArrow $ returnV $ Left mempty

306− (TryArrow a) `mappend` (TryArrow b)

307− = TryArrow $ a &&& b

308− >>^ \(a',~b')

309− -> ( (\a'' -> left (mappend a'') b') ||| Right )

310− a'

311−

312−-- | Evaluates a collection of fallible arrows, trying each one in succession.

313−-- Left values are interpreted as failures, right values as successes.

314−--

315−-- The evaluation is stopped once an arrow succeeds.

316−-- Up to that point, all failures are collected in the failure-monoid.

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

318−-- you are uninterested in the exact failures.

319−--

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

321−-- little bit of repackaging, so the actual execution order depends on the

322−-- implementation of '(&&&)' in the arrow in question.

323−-- The default implementation of '(&&&)' for example keeps the

324−-- order as given in the collection.

325−--

326−tryArrows :: (ArrowChoice a, F.Foldable f, Monoid failure)

327− => f (FallibleArrow a b failure success)

328− -> FallibleArrow a b failure success

329−tryArrows = evalAlternativeArrow . (F.foldMap TryArrow)

330−

331−--

332−liftSuccess :: (ArrowChoice a)

333− => (success -> success')

334− -> ReFallibleArrow a failure success success'

335−liftSuccess = rightLift

336−

337--

156--

338liftAsSuccess :: (ArrowChoice a)

157liftAsSuccess :: (ArrowChoice a)

339 => a x success

158 => a x success

340 -> FallibleArrow a x failure success

159 -> FallibleArrow a x failure success

341liftAsSuccess a = a >>^ Right

160liftAsSuccess a = a >>^ Right

342

161

343−--

344−asFallibleArrow :: (ArrowChoice a)

345− => a x success

346− -> FallibleArrow a x failure success

347−asFallibleArrow a = a >>^ Right

348−

349−-- | Raises an error into a 'ReFallibleArrow' if the arrow is already in

350−-- "error mode"

351−liftError :: (ArrowChoice a, Monoid failure)

352− => failure

353− -> ReFallibleArrow a failure success success

354−liftError e = leftLift (e <>)

355−

356−-- | Raises an error into a 'FallibleArrow', droping both the arrow input

357−-- and any previously stored error value.

358−_raiseA :: (ArrowChoice a)

359− => failure

360− -> FallibleArrow a x failure success

361−_raiseA e = returnV (Left e)

362−

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

364−-- and any previously stored error value.

365−_raiseAEmpty :: (ArrowChoice a, Monoid failure)

366− => FallibleArrow a x failure success

367−_raiseAEmpty = _raiseA mempty

368−

369−-- | Raises an error into a 'ReFallibleArrow', possibly appending the new error

370−-- to an existing one

371−raiseA :: (ArrowChoice a, Monoid failure)

372− => failure

373− -> ReFallibleArrow a failure success success

374−raiseA e = arr $ Left.(either (<> e) (const e))

375−

376−-- | Raises an empty error into a 'ReFallibleArrow'. If there already is an

377−-- error, nothing changes.

378−-- (Note that this function is only aequivalent to @raiseA mempty@ iff the

379−-- failure monoid follows the monoid laws.)

380−raiseAEmpty :: (ArrowChoice a, Monoid failure)

381− => ReFallibleArrow a failure success success

382−raiseAEmpty = arr (fromRight (const mempty) >>> Left)

383−

384−

385-- | Execute the second arrow if the first succeeds

162-- | Execute the second arrow if the first succeeds

386(>>?) :: (ArrowChoice a)

163(>>?) :: (ArrowChoice a)

387 => FallibleArrow a x failure success

164 => FallibleArrow a x failure success

@@ -410,20 +187,6 @@ a >>?^? b = a >>> Left ^|||^ b

410 -> FallibleArrow a x failure success'

187 -> FallibleArrow a x failure success'

411a ^>>? b = a ^>> Left ^||| b

188a ^>>? b = a ^>> Left ^||| b

412

189

413−-- | Execute the lifted second arrow if the lifted first arrow succeeds

414−(^>>?^) :: (ArrowChoice a)

415− => (x -> Either failure success)

416− -> (success -> success')

417− -> FallibleArrow a x failure success'

418−a ^>>?^ f = arr $ a >>> right f

419−

420−-- | Execute the lifted second arrow if the lifted first arrow succeeds

421−(^>>?^?) :: (ArrowChoice a)

422− => (x -> Either failure success)

423− -> (success -> Either failure success')

424− -> FallibleArrow a x failure success'

425−a ^>>?^? f = a ^>> Left ^|||^ f

426−

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

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

428(>>?!) :: (ArrowChoice a)

191(>>?!) :: (ArrowChoice a)

429 => FallibleArrow a x failure success

192 => FallibleArrow a x failure success

@@ -453,33 +216,9 @@ a ^>>?% f = arr a >>?^ (uncurry f)

453a >>?%? f = a >>?^? (uncurry f)

216a >>?%? f = a >>?^? (uncurry f)

454

217

455infixr 1 >>?, >>?^, >>?^?

218infixr 1 >>?, >>?^, >>?^?

456−infixr 1 ^>>?, ^>>?^, ^>>?^?, >>?!

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

457infixr 1 >>?%, ^>>?%, >>?%?

220infixr 1 >>?%, ^>>?%, >>?%?

458

221

459−-- | Keep values that are Right, replace Left values by a constant.

460−ifFailedUse :: (ArrowChoice a) => v -> a (Either f v) v

461−ifFailedUse v = arr $ either (const v) id

462−

463−-- | '(&&)' lifted into an arrow

464−(<&&>) :: (Arrow a) => a x Bool -> a x Bool -> a x Bool

465−(<&&>) = liftA2 (&&)

466−

467−-- | '(||)' lifted into an arrow

468−(<||>) :: (Arrow a) => a x Bool -> a x Bool -> a x Bool

469−(<||>) = liftA2 (||)

470−

471−-- | An equivalent of '(&&)' in a fallible arrow

472−(>&&<) :: (ArrowChoice a, Monoid f) => FallibleArrow a x f s

473− -> FallibleArrow a x f s'

474− -> FallibleArrow a x f (s,s')

475−(>&&<) = liftA2 chooseMin

476−

477−-- | An equivalent of '(||)' in some forms of fallible arrows

478−(>||<) :: (ArrowChoice a, Monoid f, Monoid s) => FallibleArrow a x f s

479− -> FallibleArrow a x f s

480− -> FallibleArrow a x f s

481−(>||<) = liftA2 chooseMax

482−

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

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

484ifFailedDo :: (ArrowChoice a)

223ifFailedDo :: (ArrowChoice a)

485 => FallibleArrow a x f y

224 => FallibleArrow a x f y

@@ -489,7 +228,4 @@ ifFailedDo a b = keepingTheValue a >>> repackage ^>> (b |||^ Right)

489 where repackage (x , Left _) = Left x

228 where repackage (x , Left _) = Left x

490 repackage (_ , Right y) = Right y

229 repackage (_ , Right y) = Right y

491

230

492−infixr 4 <&&>, <||>, >&&<, >||<

493infixr 1 `ifFailedDo`

231infixr 1 `ifFailedDo`

494−

495−

src/Text/Pandoc/Readers/Odt/ContentReader.hs−5

@@ -94,8 +94,6 @@ data ReaderState

94 , envMedia :: Media

95 -- | Hold binary resources used in the document

96 , odtMediaBag :: MediaBag

97−-- , sequences

98−-- , trackedChangeIDs

99 }

97 }

100 deriving ( Show )

98 deriving ( Show )

101

@@ -899,9 +897,6 @@ read_reference_ref = matchingElement NsText "reference-ref"

899-- Entry point

897-- Entry point

900----------------------

898----------------------

901

899

902−--read_plain_content :: OdtReaderSafe _x Inlines

903−--read_plain_content = strContent >>^ text

904−

905read_text :: OdtReaderSafe _x Pandoc

900read_text :: OdtReaderSafe _x Pandoc

906read_text = matchChildContent' [ read_header

901read_text = matchChildContent' [ read_header

907 , read_paragraph

902 , read_paragraph

src/Text/Pandoc/Readers/Odt/Generic/Fallible.hs−129

@@ -39,10 +39,6 @@ compatible instances of "ArrowChoice".

39-- We export everything

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

42−import Control.Applicative

43−import Control.Monad

44−

45−import qualified Data.Foldable as F

46import Data.Monoid ((<>))

42import Data.Monoid ((<>))

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

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

@@ -51,16 +47,6 @@ type Failure = ()

51type Fallible a = Either Failure a

47type Fallible a = Either Failure a

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--

50--

65maybeToEither :: Maybe a -> Fallible a

51maybeToEither :: Maybe a -> Fallible a

66maybeToEither (Just a) = Right a

52maybeToEither (Just a) = Right a

@@ -71,21 +57,11 @@ eitherToMaybe :: Either _l a -> Maybe a

71eitherToMaybe (Left _) = Nothing

57eitherToMaybe (Left _) = Nothing

72eitherToMaybe (Right a) = Just a

58eitherToMaybe (Right a) = Just a

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

60-- | > fromLeft f === either f id

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

61fromLeft :: (a -> b) -> Either a b -> b

81fromLeft f (Left a) = f a

62fromLeft f (Left a) = f a

82fromLeft _ (Right b) = b

63fromLeft _ (Right b) = b

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

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

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

66recover :: a -> Either _f a -> a

91recover a (Left _) = a

67recover a (Left _) = a

@@ -110,24 +86,6 @@ collapseEither (Left f ) = Left f

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

86collapseEither (Right (Left f)) = Left f

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

87collapseEither (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

89-- | 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

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

133-- is returned.

91-- is returned.

@@ -152,87 +110,11 @@ chooseMaxWith _ _ (Right b) = Right b

152class ChoiceVector v where

110class ChoiceVector v where

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

111 spreadChoice :: v (Either f a) -> Either f (v a)

154

112

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−

167instance ChoiceVector ((,) a) where

113instance ChoiceVector ((,) a) where

168 spreadChoice (_, Left f) = Left f

114 spreadChoice (_, Left f) = Left f

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

115 spreadChoice (x, Right y) = Right (x,y)

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

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

171

117

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'

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

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

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

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

120newtype SuccessList a = SuccessList { collectNonFailing :: [a] }

@@ -247,14 +129,3 @@ instance ChoiceVector SuccessList where

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

129collectRights :: [Either _l r] -> [r]

248collectRights = collectNonFailing . untag . spreadChoice . SuccessList

130collectRights = collectNonFailing . untag . spreadChoice . SuccessList

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

131 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/Utils.hs−7

@@ -38,8 +38,6 @@ module Text.Pandoc.Readers.Odt.Generic.Utils

38, uncurry4

39, uncurry5

40, uncurry6

41−, uncurry7

42−, uncurry8

43, swap

41, swap

44, reverseComposition

42, reverseComposition

45, bool

43, bool

@@ -148,15 +146,11 @@ uncurry3 :: (a->b->c -> z) -> (a,b,c ) -> z

148uncurry4 :: (a->b->c->d -> z) -> (a,b,c,d ) -> z

146uncurry4 :: (a->b->c->d -> z) -> (a,b,c,d ) -> z

149uncurry5 :: (a->b->c->d->e -> z) -> (a,b,c,d,e ) -> z

147uncurry5 :: (a->b->c->d->e -> z) -> (a,b,c,d,e ) -> z

150uncurry6 :: (a->b->c->d->e->f -> z) -> (a,b,c,d,e,f ) -> z

148uncurry6 :: (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

149

154uncurry3 fun (a,b,c ) = fun a b c

150uncurry3 fun (a,b,c ) = fun a b c

155uncurry4 fun (a,b,c,d ) = fun a b c d

151uncurry4 fun (a,b,c,d ) = fun a b c d

156uncurry5 fun (a,b,c,d,e ) = fun a b c d e

152uncurry5 fun (a,b,c,d,e ) = fun a b c d e

157uncurry6 fun (a,b,c,d,e,f ) = fun a b c d e f

153uncurry6 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

154

161swap :: (a,b) -> (b,a)

155swap :: (a,b) -> (b,a)

162swap (a,b) = (b,a)

156swap (a,b) = (b,a)

@@ -168,4 +162,3 @@ findBy :: (a -> Maybe b) -> [a] -> Maybe b

168findBy _ [] = Nothing

162findBy _ [] = Nothing

169findBy f ((f -> Just x):_ ) = Just x

163findBy f ((f -> Just x):_ ) = Just x

170findBy f ( _:xs) = findBy f xs

164findBy f ( _:xs) = findBy f xs

171−

src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs−320

@@ -41,50 +41,17 @@ module Text.Pandoc.Readers.Odt.Generic.XMLConverter

41, XMLConverterState

42, XMLConverter

43, FallibleXMLConverter

44−, swapPosition

45−, runConverter

46−, runConverter''

47, runConverter'

44, runConverter'

48−, runConverterF'

49−, runConverterF

50−, getCurrentElement

51, getExtraState

45, getExtraState

52, setExtraState

46, setExtraState

53, modifyExtraState

47, modifyExtraState

54−, convertingExtraState

55, producingExtraState

48, 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'

49, findChild'

71−, findChild

72−, filterChild'

73−, filterChild

74−, filterChildName'

75−, filterChildName

76−, isSet

77, isSet'

50, isSet'

78, isSetWithDefault

51, isSetWithDefault

79−, hasAttrValueOf'

80−, failIfNotAttrValueOf

81−, isThatTheAttrValue

82−, searchAttrIn

83−, searchAttrWith

84, searchAttr

52, searchAttr

85, lookupAttr

53, lookupAttr

86, lookupAttr'

54, lookupAttr'

87−, lookupAttrWithDefault

88, lookupDefaultingAttr

55, lookupDefaultingAttr

89, findAttr'

56, findAttr'

90, findAttr

57, findAttr

@@ -93,25 +60,9 @@ module Text.Pandoc.Readers.Odt.Generic.XMLConverter

93, readAttr'

60, readAttr'

94, readAttrWithDefault

61, readAttrWithDefault

95, getAttr

62, getAttr

96−-- , (>/<)

97−-- , (?>/<)

98, executeIn

63, executeIn

99−, collectEvery

100, withEveryL

64, withEveryL

101−, withEvery

102, tryAll

65, 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'

66, matchContent'

116, matchContent

67, matchContent

117) where

68) where

@@ -121,7 +72,6 @@ import Control.Monad ( MonadPlus )

121import Control.Arrow

72import Control.Arrow

122

123import qualified Data.Map as M

74import qualified Data.Map as M

124−import qualified Data.Foldable as F

125import Data.Default

75import Data.Default

126import Data.Maybe

76import Data.Maybe

127

@@ -208,17 +158,6 @@ currentElement :: XMLConverterState nsID extraState

208 -> XML.Element

158 -> XML.Element

209currentElement state = head (parentElements state)

159currentElement state = head (parentElements state)

210

160

211−-- | Replace the current position by another, modifying the extra state

212−-- in the process

213−swapPosition :: (extraState -> extraState')

214− -> [XML.Element]

215− -> XMLConverterState nsID extraState

216− -> XMLConverterState nsID extraState'

217−swapPosition f stack state

218− = state { parentElements = stack

219− , moreState = f (moreState state)

220− }

221−

222-- | Replace the current position by another, modifying the extra state

161-- | Replace the current position by another, modifying the extra state

223-- in the process

162-- in the process

224swapStack' :: XMLConverterState nsID extraState

163swapStack' :: XMLConverterState nsID extraState

@@ -264,14 +203,6 @@ runConverter :: XMLConverter nsID extraState input output

264 -> output

203 -> output

265runConverter converter state input = snd $ runArrowState converter (state,input)

204runConverter converter state input = snd $ runArrowState converter (state,input)

266

205

267−--

268−runConverter'' :: (NameSpaceID nsID)

269− => XMLConverter nsID extraState (Fallible ()) output

270− -> extraState

271− -> XML.Element

272− -> output

273−runConverter'' converter extraState element = runConverter (readNSattributes >>> converter) (createStartState element extraState) ()

274−

275runConverter' :: (NameSpaceID nsID)

206runConverter' :: (NameSpaceID nsID)

276 => FallibleXMLConverter nsID extraState () success

207 => FallibleXMLConverter nsID extraState () success

277 -> extraState

208 -> extraState

@@ -279,20 +210,6 @@ runConverter' :: (NameSpaceID nsID)

279 -> Fallible success

210 -> Fallible success

280runConverter' converter extraState element = runConverter (readNSattributes >>? converter) (createStartState element extraState) ()

211runConverter' converter extraState element = runConverter (readNSattributes >>? converter) (createStartState element extraState) ()

281

212

282−--

283−runConverterF' :: FallibleXMLConverter nsID extraState x y

284− -> XMLConverterState nsID extraState

285− -> Fallible x -> Fallible y

286−runConverterF' a s e = runConverter (returnV e >>? a) s e

287−

288−--

289−runConverterF :: (NameSpaceID nsID)

290− => FallibleXMLConverter nsID extraState XML.Element x

291− -> extraState

292− -> Fallible XML.Element -> Fallible x

293−runConverterF a s = either failWith

294− (\e -> runConverter a (createStartState e s) e)

295−

296--

213--

297getCurrentElement :: XMLConverter nsID extraState x XML.Element

214getCurrentElement :: XMLConverter nsID extraState x XML.Element

298getCurrentElement = extractFromState currentElement

215getCurrentElement = extractFromState currentElement

@@ -429,58 +346,16 @@ elemNameIs nsID name = keepingTheValue (lookupNSiri nsID) >>% hasThatName

429-- General content

346-- General content

430--------------------------------------------------------------------------------

347--------------------------------------------------------------------------------

431

348

432−--

433−strContent :: XMLConverter nsID extraState x String

434−strContent = getCurrentElement

435− >>^ XML.strContent

436−

437--

349--

438elContent :: XMLConverter nsID extraState x [XML.Content]

350elContent :: XMLConverter nsID extraState x [XML.Content]

439elContent = getCurrentElement

351elContent = getCurrentElement

440 >>^ XML.elContent

352 >>^ XML.elContent

441

353

442−--------------------------------------------------------------------------------

443−-- Current element

444−--------------------------------------------------------------------------------

445−

446−--

447−currentElem :: XMLConverter nsID extraState x (XML.QName)

448−currentElem = getCurrentElement

449− >>^ XML.elName

450−

451−currentElemIs :: (NameSpaceID nsID)

452− => nsID -> ElementName

453− -> XMLConverter nsID extraState x Bool

454−currentElemIs nsID name = getCurrentElement

455− >>> elemNameIs nsID name

456−

457−

458−

459−{-

460−currentElemIs'' nsID name = ( (getCurrentElement >>^ XML.elName >>>

461− (XML.qName >>^ (&&).(== name) )

462− ^&&&^

463− (XML.qIRI >>^ (==) )

464− ) >>% (.)

465− ) &&& lookupNSiri nsID >>% ($)

466−-}

467−

468−--

469−expectElement :: (NameSpaceID nsID)

470− => nsID -> ElementName

471− -> FallibleXMLConverter nsID extraState x ()

472−expectElement nsID name = currentElemIs nsID name

473− >>^ boolToChoice

474−

475--------------------------------------------------------------------------------

354--------------------------------------------------------------------------------

476-- Chilren

355-- Chilren

477--------------------------------------------------------------------------------

356--------------------------------------------------------------------------------

478

357

479--

358--

480−elChildren :: XMLConverter nsID extraState x [XML.Element]

481−elChildren = getCurrentElement

482− >>^ XML.elChildren

483−

484--

359--

485findChildren :: (NameSpaceID nsID)

360findChildren :: (NameSpaceID nsID)

486 => nsID -> ElementName

361 => nsID -> ElementName

@@ -489,18 +364,6 @@ findChildren nsID name = elemName nsID name

489 &&& getCurrentElement

364 &&& getCurrentElement

490 >>% XML.findChildren

365 >>% XML.findChildren

491

366

492−--

493−filterChildren :: (XML.Element -> Bool)

494− -> XMLConverter nsID extraState x [XML.Element]

495−filterChildren p = getCurrentElement

496− >>^ XML.filterChildren p

497−

498−--

499−filterChildrenName :: (XML.QName -> Bool)

500− -> XMLConverter nsID extraState x [XML.Element]

501−filterChildrenName p = getCurrentElement

502− >>^ XML.filterChildrenName p

503−

504--

367--

505findChild' :: (NameSpaceID nsID)

368findChild' :: (NameSpaceID nsID)

506 => nsID

369 => nsID

@@ -517,44 +380,11 @@ findChild :: (NameSpaceID nsID)

517findChild nsID name = findChild' nsID name

380findChild nsID name = findChild' nsID name

518 >>> maybeToChoice

381 >>> maybeToChoice

519

382

520−--

521−filterChild' :: (XML.Element -> Bool)

522− -> XMLConverter nsID extraState x (Maybe XML.Element)

523−filterChild' p = getCurrentElement

524− >>^ XML.filterChild p

525−

526−--

527−filterChild :: (XML.Element -> Bool)

528− -> FallibleXMLConverter nsID extraState x XML.Element

529−filterChild p = filterChild' p

530− >>> maybeToChoice

531−

532−--

533−filterChildName' :: (XML.QName -> Bool)

534− -> XMLConverter nsID extraState x (Maybe XML.Element)

535−filterChildName' p = getCurrentElement

536− >>^ XML.filterChildName p

537−

538−--

539−filterChildName :: (XML.QName -> Bool)

540− -> FallibleXMLConverter nsID extraState x XML.Element

541−filterChildName p = filterChildName' p

542− >>> maybeToChoice

543−

544

383

545--------------------------------------------------------------------------------

384--------------------------------------------------------------------------------

546-- Attributes

385-- Attributes

547--------------------------------------------------------------------------------

386--------------------------------------------------------------------------------

548

387

549−--

550−isSet :: (NameSpaceID nsID)

551− => nsID -> AttributeName

552− -> (Either Failure Bool)

553− -> FallibleXMLConverter nsID extraState x Bool

554−isSet nsID attrName deflt

555− = findAttr' nsID attrName

556− >>^ maybe deflt stringToBool

557−

558--

388--

559isSet' :: (NameSpaceID nsID)

389isSet' :: (NameSpaceID nsID)

560 => nsID -> AttributeName

390 => nsID -> AttributeName

@@ -570,34 +400,6 @@ isSetWithDefault nsID attrName def'

570 = isSet' nsID attrName

400 = isSet' nsID attrName

571 >>^ fromMaybe def'

401 >>^ fromMaybe def'

572

402

573−--

574−hasAttrValueOf' :: (NameSpaceID nsID)

575− => nsID -> AttributeName

576− -> AttributeValue

577− -> XMLConverter nsID extraState x Bool

578−hasAttrValueOf' nsID attrName attrValue

579− = findAttr nsID attrName

580− >>> ( const False ^|||^ (==attrValue))

581−

582−--

583−failIfNotAttrValueOf :: (NameSpaceID nsID)

584− => nsID -> AttributeName

585− -> AttributeValue

586− -> FallibleXMLConverter nsID extraState x ()

587−failIfNotAttrValueOf nsID attrName attrValue

588− = hasAttrValueOf' nsID attrName attrValue

589− >>^ boolToChoice

590−

591−-- | Is the value that is currently transported in the arrow the value of

592−-- the specified attribute?

593−isThatTheAttrValue :: (NameSpaceID nsID)

594− => nsID -> AttributeName

595− -> FallibleXMLConverter nsID extraState AttributeValue Bool

596−isThatTheAttrValue nsID attrName

597− = keepingTheValue

598− (findAttr nsID attrName)

599− >>% right.(==)

600−

601-- | Lookup value in a dictionary, fail if no attribute found or value

403-- | Lookup value in a dictionary, fail if no attribute found or value

602-- not in dictionary

404-- not in dictionary

603searchAttrIn :: (NameSpaceID nsID)

405searchAttrIn :: (NameSpaceID nsID)

@@ -608,18 +410,6 @@ searchAttrIn nsID attrName dict

608 = findAttr nsID attrName

410 = findAttr nsID attrName

609 >>?^? maybeToChoice.(`lookup` dict )

411 >>?^? maybeToChoice.(`lookup` dict )

610

412

611−

612−-- | Lookup value in a dictionary. Fail if no attribute found. If value not in

613−-- dictionary, return default value

614−searchAttrWith :: (NameSpaceID nsID)

615− => nsID -> AttributeName

616− -> a

617− -> [(AttributeValue,a)]

618− -> FallibleXMLConverter nsID extraState x a

619−searchAttrWith nsID attrName defV dict

620− = findAttr nsID attrName

621− >>?^ (fromMaybe defV).(`lookup` dict )

622−

623-- | Lookup value in a dictionary. If attribute or value not found,

413-- | Lookup value in a dictionary. If attribute or value not found,

624-- return default value

414-- return default value

625searchAttr :: (NameSpaceID nsID)

415searchAttr :: (NameSpaceID nsID)

@@ -789,16 +579,6 @@ prepareIteration nsID name = keepingTheValue

789 (findChildren nsID name)

579 (findChildren nsID name)

790 >>% distributeValue

580 >>% distributeValue

791

581

792−-- | Applies a converter to every child element of a specific type.

793−-- Collects results in a 'Monoid'.

794−-- Fails completely if any conversion fails.

795−collectEvery :: (NameSpaceID nsID, Monoid m)

796− => nsID -> ElementName

797− -> FallibleXMLConverter nsID extraState a m

798− -> FallibleXMLConverter nsID extraState a m

799−collectEvery nsID name a = prepareIteration nsID name

800− >>> foldS' (switchingTheStack a)

801−

802--

582--

803withEveryL :: (NameSpaceID nsID)

583withEveryL :: (NameSpaceID nsID)

804 => nsID -> ElementName

584 => nsID -> ElementName

@@ -826,16 +606,6 @@ tryAll nsID name a = prepareIteration nsID name

826 >>> iterateS (switchingTheStack a)

606 >>> iterateS (switchingTheStack a)

827 >>^ collectRights

607 >>^ collectRights

828

608

829−-- | Applies a converter to every child element of a specific type.

830−-- Collects all successful results.

831−tryAll' :: (NameSpaceID nsID, F.Foldable c, MonadPlus c)

832− => nsID -> ElementName

833− -> FallibleXMLConverter nsID extraState b a

834− -> XMLConverter nsID extraState b (c a)

835−tryAll' nsID name a = prepareIteration nsID name

836− >>> iterateS (switchingTheStack a)

837− >>^ collectRightsF

838−

839--------------------------------------------------------------------------------

609--------------------------------------------------------------------------------

840-- Matching children

610-- Matching children

841--------------------------------------------------------------------------------

611--------------------------------------------------------------------------------

@@ -843,15 +613,6 @@ tryAll' nsID name a = prepareIteration nsID name

843type IdXMLConverter nsID moreState x

613type IdXMLConverter nsID moreState x

844 = XMLConverter nsID moreState x x

614 = XMLConverter nsID moreState x x

845

615

846−type MaybeEConverter nsID moreState x

847− = Maybe (IdXMLConverter nsID moreState (x, XML.Element))

848−

849−-- Chainable converter that helps deciding which converter to actually use.

850−type ElementMatchConverter nsID extraState x

851− = IdXMLConverter nsID

852− extraState

853− (MaybeEConverter nsID extraState x, XML.Element)

854−

855type MaybeCConverter nsID moreState x

616type MaybeCConverter nsID moreState x

856 = Maybe (IdXMLConverter nsID moreState (x, XML.Content))

617 = Maybe (IdXMLConverter nsID moreState (x, XML.Content))

857

618

@@ -861,26 +622,6 @@ type ContentMatchConverter nsID extraState x

861 extraState

622 extraState

862 (MaybeCConverter nsID extraState x, XML.Content)

623 (MaybeCConverter nsID extraState x, XML.Content)

863

624

864−-- Helper function: The @c@ is actually a converter that is to be selected by

865−-- matching XML elements to the first two parameters.

866−-- The fold used to match elements however is very simple, so to use it,

867−-- this function wraps the converter in another converter that unifies

868−-- the accumulator. Think of a lot of converters with the resulting type

869−-- chained together. The accumulator not only transports the element

870−-- unchanged to the next matcher, it also does the actual selecting by

871−-- combining the intermediate results with '(<|>)'.

872−makeMatcherE :: (NameSpaceID nsID)

873− => nsID -> ElementName

874− -> FallibleXMLConverter nsID extraState a a

875− -> ElementMatchConverter nsID extraState a

876−makeMatcherE nsID name c = ( second (

877− elemNameIs nsID name

878− >>^ bool Nothing (Just tryC)

879− )

880− >>% (<|>)

881− ) &&&^ snd

882− where tryC = (fst ^&&& executeThere c >>% recover) &&&^ snd

883−

884-- Helper function: The @c@ is actually a converter that is to be selected by

625-- Helper function: The @c@ is actually a converter that is to be selected by

885-- matching XML content to the first two parameters.

626-- matching XML content to the first two parameters.

886-- The fold used to match elements however is very simple, so to use it,

627-- The fold used to match elements however is very simple, so to use it,

@@ -913,13 +654,6 @@ makeMatcherC nsID name c = ( second ( contentToElem

913 XML.Elem e' -> succeedWith e'

654 XML.Elem e' -> succeedWith e'

914 _ -> failEmpty

655 _ -> failEmpty

915

656

916−-- Creates and chains a bunch of matchers

917−prepareMatchersE :: (NameSpaceID nsID)

918− => [(nsID, ElementName, FallibleXMLConverter nsID extraState x x)]

919− -> ElementMatchConverter nsID extraState x

920−--prepareMatchersE = foldSs . (map $ uncurry3 makeMatcherE)

921−prepareMatchersE = reverseComposition . (map $ uncurry3 makeMatcherE)

922−

923-- Creates and chains a bunch of matchers

657-- Creates and chains a bunch of matchers

924prepareMatchersC :: (NameSpaceID nsID)

658prepareMatchersC :: (NameSpaceID nsID)

925 => [(nsID, ElementName, FallibleXMLConverter nsID extraState x x)]

659 => [(nsID, ElementName, FallibleXMLConverter nsID extraState x x)]

@@ -927,52 +661,6 @@ prepareMatchersC :: (NameSpaceID nsID)

927--prepareMatchersC = foldSs . (map $ uncurry3 makeMatcherC)

661--prepareMatchersC = foldSs . (map $ uncurry3 makeMatcherC)

928prepareMatchersC = reverseComposition . (map $ uncurry3 makeMatcherC)

662prepareMatchersC = reverseComposition . (map $ uncurry3 makeMatcherC)

929

663

930−-- | Takes a list of element-data - converter groups and

931−-- * Finds all children of the current element

932−-- * Matches each group to each child in order (at most one group per child)

933−-- * Filters non-matched children

934−-- * Chains all found converters in child-order

935−-- * Applies the chain to the input element

936−matchChildren :: (NameSpaceID nsID)

937− => [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)]

938− -> XMLConverter nsID extraState a a

939−matchChildren lookups = let matcher = prepareMatchersE lookups

940− in keepingTheValue (

941− elChildren

942− >>> map (Nothing,)

943− ^>> iterateSL matcher

944− >>^ catMaybes.map (\(m,e) -> fmap (swallowElem e) m)

945− -- >>> foldSs

946− >>> reverseComposition

947− )

948− >>> swap

949− ^>> app

950− where

951− -- let the converter swallow the element and drop the element

952− -- in the return value

953− swallowElem element converter = (,element) ^>> converter >>^ fst

954−

955−--

956−matchContent'' :: (NameSpaceID nsID)

957− => [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)]

958− -> XMLConverter nsID extraState a a

959−matchContent'' lookups = let matcher = prepareMatchersC lookups

960− in keepingTheValue (

961− elContent

962− >>> map (Nothing,)

963− ^>> iterateSL matcher

964− >>^ catMaybes.map (\(m,c) -> fmap (swallowContent c) m)

965− -- >>> foldSs

966− >>> reverseComposition

967− )

968− >>> swap

969− ^>> app

970− where

971− -- let the converter swallow the content and drop the content

972− -- in the return value

973− swallowContent content converter = (,content) ^>> converter >>^ fst

974−

975−

976-- | Takes a list of element-data - converter groups and

664-- | Takes a list of element-data - converter groups and

977-- * Finds all content of the current element

665-- * Finds all content of the current element

978-- * Matches each group to each piece of content in order

666-- * Matches each group to each piece of content in order

@@ -1018,14 +706,6 @@ matchContent lookups fallback

1018-- Internals

706-- Internals

1019--------------------------------------------------------------------------------

707--------------------------------------------------------------------------------

1020

708

1021−stringToBool :: (Monoid failure) => String -> Either failure Bool

1022−stringToBool val -- stringToBool' val >>> maybeToChoice

1023− | val `elem` trueValues = succeedWith True

1024− | val `elem` falseValues = succeedWith False

1025− | otherwise = failEmpty

1026− where trueValues = ["true" ,"on" ,"1"]

1027− falseValues = ["false","off","0"]

1028−

1029stringToBool' :: String -> Maybe Bool

709stringToBool' :: String -> Maybe Bool

1030stringToBool' val | val `elem` trueValues = Just True

710stringToBool' val | val `elem` trueValues = Just True

1031 | val `elem` falseValues = Just False

711 | val `elem` falseValues = Just False

src/Text/Pandoc/Readers/Odt/StyleReader.hs−83

@@ -50,23 +50,11 @@ module Text.Pandoc.Readers.Odt.StyleReader

50, ListLevelType (..)

51, LengthOrPercent (..)

52, lookupStyle

53−, getTextProperty

54−, getTextProperty'

55−, getParaProperty

56−, getListStyle

57, getListLevelStyle

53, getListLevelStyle

58, getStyleFamily

54, getStyleFamily

59−, lookupDefaultStyle

60, lookupDefaultStyle'

55, lookupDefaultStyle'

61, lookupListStyleByName

56, lookupListStyleByName

62−, getPropertyChain

63−, textPropertyChain

64−, stylePropertyChain

65−, stylePropertyChain'

66−, getStylePropertyChain

67, extendedStylePropertyChain

57, extendedStylePropertyChain

68−, extendedStylePropertyChain'

69−, liftStyles

70, readStylesAt

58, readStylesAt

71) where

59) where

@@ -83,7 +71,6 @@ import Data.Maybe

84import qualified Text.XML.Light as XML

72import qualified Text.XML.Light as XML

86−import Text.Pandoc.Readers.Odt.Arrows.State

87import Text.Pandoc.Readers.Odt.Arrows.Utils

74import Text.Pandoc.Readers.Odt.Arrows.Utils

89import Text.Pandoc.Readers.Odt.Generic.Utils

76import Text.Pandoc.Readers.Odt.Generic.Utils

@@ -623,20 +610,11 @@ chooseMostSpecificListLevelStyle ls | ls == mempty = Nothing

623lookupStyle :: StyleName -> Styles -> Maybe Style

610lookupStyle :: StyleName -> Styles -> Maybe Style

624lookupStyle name Styles{..} = M.lookup name stylesByName

611lookupStyle name Styles{..} = M.lookup name stylesByName

625

612

626−--

627−lookupDefaultStyle :: StyleFamily -> Styles -> StyleProperties

628−lookupDefaultStyle family Styles{..} = fromMaybe def

629− (M.lookup family defaultStyleMap)

630−

631--

613--

632lookupDefaultStyle' :: Styles -> StyleFamily -> StyleProperties

614lookupDefaultStyle' :: Styles -> StyleFamily -> StyleProperties

633lookupDefaultStyle' Styles{..} family = fromMaybe def

615lookupDefaultStyle' Styles{..} family = fromMaybe def

634 (M.lookup family defaultStyleMap)

616 (M.lookup family defaultStyleMap)

635

617

636−--

637−getListStyle :: Style -> Styles -> Maybe ListStyle

638−getListStyle Style{..} styles = listStyle >>= (`lookupListStyleByName` styles)

639−

640--

618--

641lookupListStyleByName :: StyleName -> Styles -> Maybe ListStyle

619lookupListStyleByName :: StyleName -> Styles -> Maybe ListStyle

642lookupListStyleByName name Styles{..} = M.lookup name listStylesByName

620lookupListStyleByName name Styles{..} = M.lookup name listStylesByName

@@ -681,64 +659,3 @@ extendedStylePropertyChain [style] styles = (stylePropertyChain style s

681 ++ (maybeToList (fmap (lookupDefaultStyle' styles) (getStyleFamily style styles)))

659 ++ (maybeToList (fmap (lookupDefaultStyle' styles) (getStyleFamily style styles)))

682extendedStylePropertyChain (style:trace) styles = (stylePropertyChain style styles)

660extendedStylePropertyChain (style:trace) styles = (stylePropertyChain style styles)

683 ++ (extendedStylePropertyChain trace styles)

661 ++ (extendedStylePropertyChain trace styles)

684−-- Optimizable with Data.Sequence

685−

686−--

687−extendedStylePropertyChain' :: [Style] -> Styles -> Maybe [StyleProperties]

688−extendedStylePropertyChain' [] _ = Nothing

689−extendedStylePropertyChain' [style] styles = Just (

690− (stylePropertyChain style styles)

691− ++ (maybeToList (fmap (lookupDefaultStyle' styles) (getStyleFamily style styles)))

692− )

693−extendedStylePropertyChain' (style:trace) styles = fmap ((stylePropertyChain style styles) ++)

694− (extendedStylePropertyChain' trace styles)

695−

696−--

697−stylePropertyChain' :: Styles -> Style -> [StyleProperties]

698−stylePropertyChain' = flip stylePropertyChain

699−

700−--

701−getStylePropertyChain :: StyleName -> Styles -> [StyleProperties]

702−getStylePropertyChain name styles = maybe []

703− (`stylePropertyChain` styles)

704− (lookupStyle name styles)

705−

706−--

707−getPropertyChain :: (StyleProperties -> Maybe a) -> Style -> Styles -> [a]

708−getPropertyChain extract style styles = catMaybes

709− $ map extract

710− $ stylePropertyChain style styles

711−

712−--

713−textPropertyChain :: Style -> Styles -> [TextProperties]

714−textPropertyChain = getPropertyChain textProperties

715−

716−--

717−paraPropertyChain :: Style -> Styles -> [ParaProperties]

718−paraPropertyChain = getPropertyChain paraProperties

719−

720−--

721−getTextProperty :: (TextProperties -> a) -> Style -> Styles -> Maybe a

722−getTextProperty extract style styles = fmap extract

723− $ listToMaybe

724− $ textPropertyChain style styles

725−

726−--

727−getTextProperty' :: (TextProperties -> Maybe a) -> Style -> Styles -> Maybe a

728−getTextProperty' extract style styles = F.asum

729− $ map extract

730− $ textPropertyChain style styles

731−

732−--

733−getParaProperty :: (ParaProperties -> a) -> Style -> Styles -> Maybe a

734−getParaProperty extract style styles = fmap extract

735− $ listToMaybe

736− $ paraPropertyChain style styles

737−

738−-- | Lifts the reader into another readers' state.

739−liftStyles :: (OdtConverterState s -> OdtConverterState Styles)

740− -> (OdtConverterState Styles -> OdtConverterState s )

741− -> XMLReader s x x

742−liftStyles extract inject = switchState extract inject

743− $ convertingExtraState M.empty readAllStyles

744−