Tissevert/pandoc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions 1

Odt reader: remove dead code

Browse source 
The ODT reader contained a lot of general code useful for working with
arrows. However, many of these utils weren't used and are hence removed.
This commit is contained in:
Albert Krewinkel 2017-05-31 19:59:34 +02:00
parent 774075c3e2
commit f955af58e6
No known key found for this signature in database
GPG key ID: 388DC0B21F631124
7 changed files with 4 additions and 902 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

90
src/Text/Pandoc/Readers/Odt/Arrows/State.hs
View file

@ -58,10 +58,6 @@ newtype ArrowState state a b = ArrowState
withState :: (state -> a -> (state, b)) -> ArrowState state a b
withState = ArrowState . uncurry
-- | Constructor
withState' :: ((state, a) -> (state, b)) -> ArrowState state a b
withState' = ArrowState
-- | Constructor
modifyState :: (state -> state ) -> ArrowState state a a
modifyState = ArrowState . first
@ -78,10 +74,6 @@ fromState = ArrowState . (.fst)
extractFromState :: (state -> b ) -> ArrowState state x b
extractFromState f = ArrowState $ \(state,_) -> (state, f state)
-- | Constructor
withUnchangedState :: (state -> a -> b ) -> ArrowState state a b
withUnchangedState f = ArrowState $ \(state,a) -> (state, f state a)
-- | Constructor
tryModifyState :: (state -> Either f state)
-> ArrowState state a (Either f a)
@ -107,43 +99,9 @@ instance ArrowChoice (ArrowState state) where
Left l -> (s, Left l)
Right r -> second Right $ runArrowState a (s,r)
instance ArrowLoop (ArrowState state) where
loop a = ArrowState $ \(s, x)
-> let (s', (x', _d)) = runArrowState a (s, (x, _d))
in (s', x')
instance ArrowApply (ArrowState state) where
app = ArrowState $ \(s, (f,b)) -> runArrowState f (s,b)
-- | Embedding of a state arrow in a state arrow with a different state type.
switchState :: (s -> s') -> (s' -> s) -> ArrowState s' x y -> ArrowState s x y
switchState there back a = ArrowState $ first there
>>> runArrowState a
>>> first back
-- | Lift a state arrow to modify the state of an arrow
-- with a different state type.
liftToState :: (s -> s') -> ArrowState s' s s -> ArrowState s x x
liftToState unlift a = modifyState $ unlift &&& id
>>> runArrowState a
>>> snd
-- | Switches the type of the state temporarily.
-- Drops the intermediate result state, behaving like the identity arrow,
-- save for side effects in the state.
withSubState :: ArrowState s x s2 -> ArrowState s2 s s -> ArrowState s x x
withSubState unlift a = keepingTheValue (withSubState unlift a) >>^ fst
-- | Switches the type of the state temporarily.
-- Returns the resulting sub-state.
withSubState' :: ArrowState s x s' -> ArrowState s' s s -> ArrowState s x s'
withSubState' unlift a = ArrowState $ runArrowState unlift
>>> switch
>>> runArrowState a
>>> switch
where switch (x,y) = (y,x)
-- | Switches the type of the state temporarily.
-- Drops the intermediate result state, behaving like a fallible
-- 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
foldS a = ArrowState $ \(s,f) -> foldr a' (s,mempty) f
where a' x (s',m) = second (m <>) $ runArrowState a (s',x)
-- | Fold a state arrow through something 'Foldable'. Collect the results
-- in a 'Monoid'.
-- Intermediate form of a fold between one with "only" a 'Monoid'
-- and one with any function.
foldSL :: (Foldable f, Monoid m) => ArrowState s x m -> ArrowState s (f x) m
foldSL a = ArrowState $ \(s,f) -> foldl a' (s,mempty) f
where a' (s',m) x = second (m <>) $ runArrowState a (s',x)
-- | Fold a fallible state arrow through something 'Foldable'. Collect the
-- results in a 'Monoid'.
-- Intermediate form of a fold between one with "only" a 'Monoid'
-- and one with any function.
-- If the iteration fails, the state will be reset to the initial one.
foldS' :: (Foldable f, Monoid m)
=> ArrowState s x (Either e m)
-> ArrowState s (f x) (Either e m)
foldS' a = ArrowState $ \(s,f) -> foldr (a' s) (s,Right mempty) f
where a' s x (s',Right m) = case runArrowState a (s',x) of
(s'',Right m') -> (s'', Right (m <> m'))
(_ ,Left e ) -> (s , Left e)
a' _ _ e = e
-- | Fold a fallible state arrow through something 'Foldable'. Collect the
-- results in a 'Monoid'.
-- Intermediate form of a fold between one with "only" a 'Monoid'
-- and one with any function.
-- If the iteration fails, the state will be reset to the initial one.
foldSL' :: (Foldable f, Monoid m)
=> ArrowState s x (Either e m)
-> ArrowState s (f x) (Either e m)
foldSL' a = ArrowState $ \(s,f) -> foldl (a' s) (s,Right mempty) f
where a' s (s',Right m) x = case runArrowState a (s',x) of
(s'',Right m') -> (s'', Right (m <> m'))
(_ ,Left e ) -> (s , Left e)
a' _ e _ = e
-- | Fold a state arrow through something 'Foldable'. Collect the results in a
-- 'MonadPlus'.
iterateS :: (Foldable f, MonadPlus m)
@ -239,15 +161,3 @@ iterateS' a = ArrowState $ \(s,f) -> foldr (a' s) (s,Right mzero) f
(s'',Right m') -> (s'',Right $ mplus m $ return m')
(_ ,Left e ) -> (s ,Left e )
a' _ _ e = e
-- | Fold a fallible state arrow through something 'Foldable'.
-- Collect the results in a 'MonadPlus'.
-- If the iteration fails, the state will be reset to the initial one.
iterateSL' :: (Foldable f, MonadPlus m)
=> ArrowState s x (Either e y )
-> ArrowState s (f x) (Either e (m y))
iterateSL' a = ArrowState $ \(s,f) -> foldl (a' s) (s,Right mzero) f
where a' s (s',Right m) x = case runArrowState a (s',x) of
(s'',Right m') -> (s'',Right $ mplus m $ return m')
(_ ,Left e ) -> (s ,Left e )
a' _ e _ = e

272
src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs
View file

@ -40,10 +40,7 @@ with an equivalent return value.
module Text.Pandoc.Readers.Odt.Arrows.Utils where
import Control.Arrow
import Control.Monad ( join, MonadPlus(..) )
import qualified Data.Foldable as F
import Data.Monoid
import Control.Monad ( join )
import Text.Pandoc.Readers.Odt.Generic.Fallible
import Text.Pandoc.Readers.Odt.Generic.Utils
@ -63,12 +60,6 @@ and5 :: (Arrow a)
and6 :: (Arrow a)
=> a b c0->a b c1->a b c2->a b c3->a b c4->a b c5
-> a b (c0,c1,c2,c3,c4,c5 )
and7 :: (Arrow a)
=> a b c0->a b c1->a b c2->a b c3->a b c4->a b c5->a b c6
-> a b (c0,c1,c2,c3,c4,c5,c6 )
and8 :: (Arrow a)
=> a b c0->a b c1->a b c2->a b c3->a b c4->a b c5->a b c6->a b c7
-> a b (c0,c1,c2,c3,c4,c5,c6,c7)
and3 a b c = (and2 a b ) &&& c
>>^ \((z,y ) , x) -> (z,y,x )
@ -78,10 +69,6 @@ and5 a b c d e = (and4 a b c d ) &&& e
>>^ \((z,y,x,w ) , v) -> (z,y,x,w,v )
and6 a b c d e f = (and5 a b c d e ) &&& f
>>^ \((z,y,x,w,v ) , u) -> (z,y,x,w,v,u )
and7 a b c d e f g = (and6 a b c d e f ) &&& g
>>^ \((z,y,x,w,v,u ) , t) -> (z,y,x,w,v,u,t )
and8 a b c d e f g h = (and7 a b c d e f g) &&& h
>>^ \((z,y,x,w,v,u,t) , s) -> (z,y,x,w,v,u,t,s)
liftA2 :: (Arrow a) => (x -> y -> z) -> a b x -> a b y -> a b z
liftA2 f a b = a &&& b >>^ uncurry f
@ -98,19 +85,11 @@ liftA5 :: (Arrow a) => (z->y->x->w->v -> r)
liftA6 :: (Arrow a) => (z->y->x->w->v->u -> r)
-> a b z->a b y->a b x->a b w->a b v->a b u
-> a b r
liftA7 :: (Arrow a) => (z->y->x->w->v->u->t -> r)
-> a b z->a b y->a b x->a b w->a b v->a b u->a b t
-> a b r
liftA8 :: (Arrow a) => (z->y->x->w->v->u->t->s -> r)
-> a b z->a b y->a b x->a b w->a b v->a b u->a b t->a b s
-> a b r
liftA3 fun a b c = and3 a b c >>^ uncurry3 fun
liftA4 fun a b c d = and4 a b c d >>^ uncurry4 fun
liftA5 fun a b c d e = and5 a b c d e >>^ uncurry5 fun
liftA6 fun a b c d e f = and6 a b c d e f >>^ uncurry6 fun
liftA7 fun a b c d e f g = and7 a b c d e f g >>^ uncurry7 fun
liftA8 fun a b c d e f g h = and8 a b c d e f g h >>^ uncurry8 fun
liftA :: (Arrow a) => (y -> z) -> a b y -> a b z
liftA fun a = a >>^ fun
@ -124,28 +103,12 @@ liftA fun a = a >>^ fun
duplicate :: (Arrow a) => a b (b,b)
duplicate = arr $ join (,)
-- | Lifts the combination of two values into an arrow.
joinOn :: (Arrow a) => (x -> y -> z) -> a (x,y) z
joinOn = arr.uncurry
-- | Applies a function to the uncurried result-pair of an arrow-application.
-- (The %-symbol was chosen to evoke an association with pairs.)
(>>%) :: (Arrow a) => a x (b,c) -> (b -> c -> d) -> a x d
a >>% f = a >>^ uncurry f
-- | '(>>%)' with its arguments flipped
(%<<) :: (Arrow a) => (b -> c -> d) -> a x (b,c) -> a x d
(%<<) = flip (>>%)
-- | Precomposition with an uncurried function
(%>>) :: (Arrow a) => (b -> c -> d) -> a d r -> a (b,c) r
f %>> a = uncurry f ^>> a
-- | Precomposition with an uncurried function (right to left variant)
(<<%) :: (Arrow a) => a d r -> (b -> c -> d) -> a (b,c) r
(<<%) = flip (%>>)
infixr 2 >>%, %<<, %>>, <<%
infixr 2 >>%
-- | Duplicate a value and apply an arrow to the second instance.
@ -156,56 +119,6 @@ infixr 2 >>%, %<<, %>>, <<%
keepingTheValue :: (Arrow a) => a b c -> a b (b,c)
keepingTheValue a = returnA &&& a
-- | Duplicate a value and apply an arrow to the first instance.
-- Aequivalent to
-- > \a -> duplicate >>> first a
-- or
-- > \a -> a &&& returnA
keepingTheValue' :: (Arrow a) => a b c -> a b (c,b)
keepingTheValue' a = a &&& returnA
-- | 'bind' from the "Maybe"-Monad lifted into an 'ArrowChoice'.
-- Actually, it's the more complex '(>=>)', because 'bind' alone does not
-- combine as nicely in arrow form.
-- The current implementation is not the most efficient one, because it can
-- not return directly if a 'Nothing' is encountered. That in turn follows
-- from the type system, as 'Nothing' has an "invisible" type parameter that
-- can not be dropped early.
--
-- Also, there probably is a way to generalize this to other monads
-- or applicatives, but I'm leaving that as an exercise to the reader.
-- I have a feeling there is a new Arrow-typeclass to be found that is less
-- restrictive than 'ArrowApply'. If it is already out there,
-- I have not seen it yet. ('ArrowPlus' for example is not general enough.)
(>>>=) :: (ArrowChoice a) => a x (Maybe b) -> a b (Maybe c) -> a x (Maybe c)
a1 >>>= a2 = a1 >>> maybeToChoice >>> right a2 >>> choiceToMaybe >>^ join
infixr 2 >>>=
-- | 'mplus' Lifted into an arrow. No 'ArrowPlus' required.
-- (But still different from a true bind)
(>++<) :: (Arrow a, MonadPlus m) => a x (m b) -> a x (m b) -> a x (m b)
(>++<) = liftA2 mplus
-- | Left-compose with a pure function
leftLift :: (ArrowChoice a) => (l -> l') -> a (Either l r) (Either l' r)
leftLift = left.arr
-- | Right-compose with a pure function
rightLift :: (ArrowChoice a) => (r -> r') -> a (Either l r) (Either l r')
rightLift = right.arr
( ^+++ ) :: (ArrowChoice a) => (b -> c) -> a b' c' -> a (Either b b') (Either c c')
( +++^ ) :: (ArrowChoice a) => a b c -> (b' -> c') -> a (Either b b') (Either c c')
( ^+++^ ) :: (ArrowChoice a) => (b -> c) -> (b' -> c') -> a (Either b b') (Either c c')
l ^+++ r = leftLift l >>> right r
l +++^ r = left l >>> rightLift r
l ^+++^ r = leftLift l >>> rightLift r
infixr 2 ^+++, +++^, ^+++^
( ^||| ) :: (ArrowChoice a) => (b -> d) -> a c d -> a (Either b c) d
( |||^ ) :: (ArrowChoice a) => a b d -> (c -> d) -> a (Either b c) d
( ^|||^ ) :: (ArrowChoice a) => (b -> d) -> (c -> d) -> a (Either b c) d
@ -218,33 +131,12 @@ infixr 2 ^||| , |||^, ^|||^
( ^&&& ) :: (Arrow a) => (b -> c) -> a b c' -> a b (c,c')
( &&&^ ) :: (Arrow a) => a b c -> (b -> c') -> a b (c,c')
( ^&&&^ ) :: (Arrow a) => (b -> c) -> (b -> c') -> a b (c,c')
l ^&&& r = arr l &&& r
l &&&^ r = l &&& arr r
l ^&&&^ r = arr l &&& arr r
infixr 3 ^&&&, &&&^, ^&&&^
infixr 3 ^&&&, &&&^
( ^*** ) :: (Arrow a) => (b -> c) -> a b' c' -> a (b,b') (c,c')
( ***^ ) :: (Arrow a) => a b c -> (b' -> c') -> a (b,b') (c,c')
( ^***^ ) :: (Arrow a) => (b -> c) -> (b' -> c') -> a (b,b') (c,c')
l ^*** r = arr l *** r
l ***^ r = l *** arr r
l ^***^ r = arr l *** arr r
infixr 3 ^***, ***^, ^***^
-- | A version of
--
-- >>> \p -> arr (\x -> if p x the Right x else Left x)
--
-- but with p being an arrow
choose :: (ArrowChoice a) => a b Bool -> a b (Either b b)
choose checkValue = keepingTheValue checkValue >>^ select
where select (x,True ) = Right x
select (x,False ) = Left x
-- | Converts @Right a@ into @Just a@ and @Left _@ into @Nothing@.
choiceToMaybe :: (ArrowChoice a) => a (Either l r) (Maybe r)
@ -258,130 +150,15 @@ maybeToChoice = arr maybeToEither
returnV :: (Arrow a) => c -> a x c
returnV = arr.const
-- | 'returnA' dropping everything
returnA_ :: (Arrow a) => a _b ()
returnA_ = returnV ()
-- | Wrapper for an arrow that can be evaluated im parallel. All
-- Arrows can be evaluated in parallel, as long as they return a
-- monoid.
newtype ParallelArrow a b c = CoEval { evalParallelArrow :: a b c }
deriving (Eq, Ord, Show)
instance (Arrow a, Monoid m) => Monoid (ParallelArrow a b m) where
mempty = CoEval $ returnV mempty
(CoEval a) `mappend` (CoEval ~b) = CoEval $ a &&& b >>% mappend
-- | Evaluates a collection of arrows in a parallel fashion.
--
-- This is in essence a fold of '(&&&)' over the collection,
-- so the actual execution order and parallelity depends on the
-- implementation of '(&&&)' in the arrow in question.
-- The default implementation of '(&&&)' for example keeps the
-- order as given in the collection.
--
-- This function can be seen as a generalization of
-- 'Control.Applicative.sequenceA' to arrows or as an alternative to
-- a fold with 'Control.Applicative.WrappedArrow', which
-- substitutes the monoid with function application.
--
coEval :: (Arrow a, F.Foldable f, Monoid m) => f (a b m) -> a b m
coEval = evalParallelArrow . (F.foldMap CoEval)
-- | Defines Left as failure, Right as success
type FallibleArrow a input failure success = a input (Either failure success)
type ReFallibleArrow a failure success success'
= FallibleArrow a (Either failure success) failure success'
-- | Wrapper for fallible arrows. Fallible arrows are all arrows that return
-- an Either value where left is a faliure and right is a success value.
newtype AlternativeArrow a input failure success
= TryArrow { evalAlternativeArrow :: FallibleArrow a input failure success }
instance (ArrowChoice a, Monoid failure)
=> Monoid (AlternativeArrow a input failure success) where
mempty = TryArrow $ returnV $ Left mempty
(TryArrow a) `mappend` (TryArrow b)
= TryArrow $ a &&& b
>>^ \(a',~b')
-> ( (\a'' -> left (mappend a'') b') ||| Right )
a'
-- | Evaluates a collection of fallible arrows, trying each one in succession.
-- Left values are interpreted as failures, right values as successes.
--
-- The evaluation is stopped once an arrow succeeds.
-- Up to that point, all failures are collected in the failure-monoid.
-- Note that '()' is a monoid, and thus can serve as a failure-collector if
-- you are uninterested in the exact failures.
--
-- This is in essence a fold of '(&&&)' over the collection, enhanced with a
-- little bit of repackaging, so the actual execution order depends on the
-- implementation of '(&&&)' in the arrow in question.
-- The default implementation of '(&&&)' for example keeps the
-- order as given in the collection.
--
tryArrows :: (ArrowChoice a, F.Foldable f, Monoid failure)
=> f (FallibleArrow a b failure success)
-> FallibleArrow a b failure success
tryArrows = evalAlternativeArrow . (F.foldMap TryArrow)
--
liftSuccess :: (ArrowChoice a)
=> (success -> success')
-> ReFallibleArrow a failure success success'
liftSuccess = rightLift
--
liftAsSuccess :: (ArrowChoice a)
=> a x success
-> FallibleArrow a x failure success
liftAsSuccess a = a >>^ Right
--
asFallibleArrow :: (ArrowChoice a)
=> a x success
-> FallibleArrow a x failure success
asFallibleArrow a = a >>^ Right
-- | Raises an error into a 'ReFallibleArrow' if the arrow is already in
-- "error mode"
liftError :: (ArrowChoice a, Monoid failure)
=> failure
-> ReFallibleArrow a failure success success
liftError e = leftLift (e <>)
-- | Raises an error into a 'FallibleArrow', droping both the arrow input
-- and any previously stored error value.
_raiseA :: (ArrowChoice a)
=> failure
-> FallibleArrow a x failure success
_raiseA e = returnV (Left e)
-- | Raises an empty error into a 'FallibleArrow', droping both the arrow input
-- and any previously stored error value.
_raiseAEmpty :: (ArrowChoice a, Monoid failure)
=> FallibleArrow a x failure success
_raiseAEmpty = _raiseA mempty
-- | Raises an error into a 'ReFallibleArrow', possibly appending the new error
-- to an existing one
raiseA :: (ArrowChoice a, Monoid failure)
=> failure
-> ReFallibleArrow a failure success success
raiseA e = arr $ Left.(either (<> e) (const e))
-- | Raises an empty error into a 'ReFallibleArrow'. If there already is an
-- error, nothing changes.
-- (Note that this function is only aequivalent to @raiseA mempty@ iff the
-- failure monoid follows the monoid laws.)
raiseAEmpty :: (ArrowChoice a, Monoid failure)
=> ReFallibleArrow a failure success success
raiseAEmpty = arr (fromRight (const mempty) >>> Left)
-- | Execute the second arrow if the first succeeds
(>>?) :: (ArrowChoice a)
=> FallibleArrow a x failure success
@ -410,20 +187,6 @@ a >>?^? b = a >>> Left ^|||^ b
-> FallibleArrow a x failure success'
a ^>>? b = a ^>> Left ^||| b
-- | Execute the lifted second arrow if the lifted first arrow succeeds
(^>>?^) :: (ArrowChoice a)
=> (x -> Either failure success)
-> (success -> success')
-> FallibleArrow a x failure success'
a ^>>?^ f = arr $ a >>> right f
-- | Execute the lifted second arrow if the lifted first arrow succeeds
(^>>?^?) :: (ArrowChoice a)
=> (x -> Either failure success)
-> (success -> Either failure success')
-> FallibleArrow a x failure success'
a ^>>?^? f = a ^>> Left ^|||^ f
-- | Execute the second, non-fallible arrow if the first arrow succeeds
(>>?!) :: (ArrowChoice a)
=> FallibleArrow a x failure success
@ -453,33 +216,9 @@ a ^>>?% f = arr a >>?^ (uncurry f)
a >>?%? f = a >>?^? (uncurry f)
infixr 1 >>?, >>?^, >>?^?
infixr 1 ^>>?, ^>>?^, ^>>?^?, >>?!
infixr 1 ^>>?, >>?!
infixr 1 >>?%, ^>>?%, >>?%?
-- | Keep values that are Right, replace Left values by a constant.
ifFailedUse :: (ArrowChoice a) => v -> a (Either f v) v
ifFailedUse v = arr $ either (const v) id
-- | '(&&)' lifted into an arrow
(<&&>) :: (Arrow a) => a x Bool -> a x Bool -> a x Bool
(<&&>) = liftA2 (&&)
-- | '(||)' lifted into an arrow
(<||>) :: (Arrow a) => a x Bool -> a x Bool -> a x Bool
(<||>) = liftA2 (||)
-- | An equivalent of '(&&)' in a fallible arrow
(>&&<) :: (ArrowChoice a, Monoid f) => FallibleArrow a x f s
-> FallibleArrow a x f s'
-> FallibleArrow a x f (s,s')
(>&&<) = liftA2 chooseMin
-- | An equivalent of '(||)' in some forms of fallible arrows
(>||<) :: (ArrowChoice a, Monoid f, Monoid s) => FallibleArrow a x f s
-> FallibleArrow a x f s
-> FallibleArrow a x f s
(>||<) = liftA2 chooseMax
-- | An arrow version of a short-circuit (<|>)
ifFailedDo :: (ArrowChoice a)
=> FallibleArrow a x f y
@ -489,7 +228,4 @@ ifFailedDo a b = keepingTheValue a >>> repackage ^>> (b |||^ Right)
where repackage (x , Left _) = Left x
repackage (_ , Right y) = Right y
infixr 4 <&&>, <||>, >&&<, >||<
infixr 1 `ifFailedDo`

5
src/Text/Pandoc/Readers/Odt/ContentReader.hs
View file

@ -94,8 +94,6 @@ data ReaderState
, envMedia :: Media
-- | Hold binary resources used in the document
, odtMediaBag :: MediaBag
-- , sequences
-- , trackedChangeIDs
}
deriving ( Show )
@ -899,9 +897,6 @@ read_reference_ref = matchingElement NsText "reference-ref"
-- Entry point
----------------------
--read_plain_content :: OdtReaderSafe _x Inlines
--read_plain_content = strContent >>^ text
read_text :: OdtReaderSafe _x Pandoc
read_text = matchChildContent' [ read_header
, read_paragraph

129
src/Text/Pandoc/Readers/Odt/Generic/Fallible.hs
View file

@ -39,10 +39,6 @@ compatible instances of "ArrowChoice".
-- We export everything
module Text.Pandoc.Readers.Odt.Generic.Fallible where
import Control.Applicative
import Control.Monad
import qualified Data.Foldable as F
import Data.Monoid ((<>))
-- | Default for now. Will probably become a class at some point.
@ -51,16 +47,6 @@ type Failure = ()
type Fallible a = Either Failure a
-- | False -> Left (), True -> Right ()
boolToEither :: Bool -> Fallible ()
boolToEither False = Left ()
boolToEither True = Right ()
-- | False -> Left (), True -> Right ()
boolToChoice :: Bool -> Fallible ()
boolToChoice False = Left ()
boolToChoice True = Right ()
--
maybeToEither :: Maybe a -> Fallible a
maybeToEither (Just a) = Right a
@ -71,21 +57,11 @@ eitherToMaybe :: Either _l a -> Maybe a
eitherToMaybe (Left _) = Nothing
eitherToMaybe (Right a) = Just a
-- | > untagEither === either id id
untagEither :: Either a a -> a
untagEither (Left a) = a
untagEither (Right a) = a
-- | > fromLeft f === either f id
fromLeft :: (a -> b) -> Either a b -> b
fromLeft f (Left a) = f a
fromLeft _ (Right b) = b
-- | > fromRight f === either id f
fromRight :: (a -> b) -> Either b a -> b
fromRight _ (Left b) = b
fromRight f (Right a) = f a
-- | > recover a === fromLeft (const a) === either (const a) id
recover :: a -> Either _f a -> a
recover a (Left _) = a
@ -110,24 +86,6 @@ collapseEither (Left f ) = Left f
collapseEither (Right (Left f)) = Left f
collapseEither (Right (Right x)) = Right x
-- | If either of the values represents an error, the result is a
-- (possibly combined) error. If both values represent a success,
-- both are returned.
chooseMin :: (Monoid a) => Either a b -> Either a b' -> Either a (b,b')
chooseMin = chooseMinWith (,)
-- | If either of the values represents an error, the result is a
-- (possibly combined) error. If both values represent a success,
-- a combination is returned.
chooseMinWith :: (Monoid a) => (b -> b' -> c)
-> Either a b
-> Either a b'
-> Either a c
chooseMinWith (><) (Right a) (Right b) = Right $ a >< b
chooseMinWith _ (Left a) (Left b) = Left $ a <> b
chooseMinWith _ (Left a) _ = Left a
chooseMinWith _ _ (Left b) = Left b
-- | If either of the values represents a non-error, the result is a
-- (possibly combined) non-error. If both values represent an error, an error
-- is returned.
@ -152,87 +110,11 @@ chooseMaxWith _ _ (Right b) = Right b
class ChoiceVector v where
spreadChoice :: v (Either f a) -> Either f (v a)
-- Let's do a few examples first
instance ChoiceVector Maybe where
spreadChoice (Just (Left f)) = Left f
spreadChoice (Just (Right x)) = Right (Just x)
spreadChoice Nothing = Right Nothing
instance ChoiceVector (Either l) where
spreadChoice (Right (Left f)) = Left f
spreadChoice (Right (Right x)) = Right (Right x)
spreadChoice (Left x ) = Right (Left x)
instance ChoiceVector ((,) a) where
spreadChoice (_, Left f) = Left f
spreadChoice (x, Right y) = Right (x,y)
-- Wasn't there a newtype somewhere with the elements flipped?
--
-- More instances later, first some discussion.
--
-- I'll have to freshen up on type system details to see how (or if) to do
-- something like
--
-- > instance (ChoiceVector a, ChoiceVector b) => ChoiceVector (a b) where
-- > :
--
-- But maybe it would be even better to use something like
--
-- > class ChoiceVector v v' f | v -> v' f where
-- > spreadChoice :: v -> Either f v'
--
-- That way, more places in @v@ could spread the cheer, e.g.:
--
-- As before:
-- -- ( a , Either f b) (a , b) f
-- > instance ChoiceVector ((,) a (Either f b)) ((,) a b) f where
-- > spreadChoice (_, Left f) = Left f
-- > spreadChoice (a, Right b) = Right (a,b)
--
-- But also:
-- -- ( Either f a , b) (a , b) f
-- > instance ChoiceVector ((,) (Either f a) b) ((,) a b) f where
-- > spreadChoice (Right a,b) = Right (a,b)
-- > spreadChoice (Left f,_) = Left f
--
-- And maybe even:
-- -- ( Either f a , Either f b) (a , b) f
-- > instance ChoiceVector ((,) (Either f a) (Either f b)) ((,) a b) f where
-- > spreadChoice (Right a , Right b) = Right (a,b)
-- > spreadChoice (Left f , _ ) = Left f
-- > spreadChoice ( _ , Left f) = Left f
--
-- Of course that would lead to a lot of overlapping instances...
-- But I can't think of a different way. A selector function might help,
-- but not even a "Data.Traversable" is powerful enough for that.
-- But maybe someone has already solved all this with a lens library.
--
-- Well, it's an interesting academic question. But for practical purposes,
-- I have more than enough right now.
instance ChoiceVector ((,,) a b) where
spreadChoice (_,_, Left f) = Left f
spreadChoice (a,b, Right x) = Right (a,b,x)
instance ChoiceVector ((,,,) a b c) where
spreadChoice (_,_,_, Left f) = Left f
spreadChoice (a,b,c, Right x) = Right (a,b,c,x)
instance ChoiceVector ((,,,,) a b c d) where
spreadChoice (_,_,_,_, Left f) = Left f
spreadChoice (a,b,c,d, Right x) = Right (a,b,c,d,x)
instance ChoiceVector (Const a) where
spreadChoice (Const c) = Right (Const c) -- need to repackage because of implicit types
-- | Fails on the first error
instance ChoiceVector [] where
spreadChoice = sequence -- using the monad instance of Either.
-- Could be generalized to "Data.Traversable" - but why play
-- with UndecidableInstances unless this is really needed.
-- | Wrapper for a list. While the normal list instance of 'ChoiceVector'
-- fails whenever it can, this type will never fail.
newtype SuccessList a = SuccessList { collectNonFailing :: [a] }
@ -247,14 +129,3 @@ instance ChoiceVector SuccessList where
collectRights :: [Either _l r] -> [r]
collectRights = collectNonFailing . untag . spreadChoice . SuccessList
where untag = fromLeft (error "Unexpected Left")
-- | A version of 'collectRights' generalized to other containers. The
-- container must be both "reducible" and "buildable". Most general containers
-- should fullfill these requirements, but there is no single typeclass
-- (that I know of) for that.
-- Therefore, they are split between 'Foldable' and 'MonadPlus'.
-- (Note that 'Data.Traversable.Traversable' alone would not be enough, either.)
collectRightsF :: (F.Foldable c, MonadPlus c) => c (Either _l r) -> c r
collectRightsF = F.foldr unTagRight mzero
where unTagRight (Right x) = mplus $ return x
unTagRight _ = id

7
src/Text/Pandoc/Readers/Odt/Generic/Utils.hs
View file

@ -38,8 +38,6 @@ module Text.Pandoc.Readers.Odt.Generic.Utils
, uncurry4
, uncurry5
, uncurry6
, uncurry7
, uncurry8
, swap
, reverseComposition
, bool
@ -148,15 +146,11 @@ uncurry3 :: (a->b->c -> z) -> (a,b,c ) -> z
uncurry4 :: (a->b->c->d -> z) -> (a,b,c,d ) -> z
uncurry5 :: (a->b->c->d->e -> z) -> (a,b,c,d,e ) -> z
uncurry6 :: (a->b->c->d->e->f -> z) -> (a,b,c,d,e,f ) -> z
uncurry7 :: (a->b->c->d->e->f->g -> z) -> (a,b,c,d,e,f,g ) -> z
uncurry8 :: (a->b->c->d->e->f->g->h -> z) -> (a,b,c,d,e,f,g,h) -> z
uncurry3 fun (a,b,c ) = fun a b c
uncurry4 fun (a,b,c,d ) = fun a b c d
uncurry5 fun (a,b,c,d,e ) = fun a b c d e
uncurry6 fun (a,b,c,d,e,f ) = fun a b c d e f
uncurry7 fun (a,b,c,d,e,f,g ) = fun a b c d e f g
uncurry8 fun (a,b,c,d,e,f,g,h) = fun a b c d e f g h
swap :: (a,b) -> (b,a)
swap (a,b) = (b,a)
@ -168,4 +162,3 @@ findBy :: (a -> Maybe b) -> [a] -> Maybe b
findBy _ [] = Nothing
findBy f ((f -> Just x):_ ) = Just x
findBy f ( _:xs) = findBy f xs

320
src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs
View file

@ -41,50 +41,17 @@ module Text.Pandoc.Readers.Odt.Generic.XMLConverter
, XMLConverterState
, XMLConverter
, FallibleXMLConverter
, swapPosition
, runConverter
, runConverter''
, runConverter'
, runConverterF'
, runConverterF
, getCurrentElement
, getExtraState
, setExtraState
, modifyExtraState
, convertingExtraState
, producingExtraState
, lookupNSiri
, lookupNSprefix
, readNSattributes
, elemName
, elemNameIs
, strContent
, elContent
, currentElem
, currentElemIs
, expectElement
, elChildren
, findChildren
, filterChildren
, filterChildrenName
, findChild'
, findChild
, filterChild'
, filterChild
, filterChildName'
, filterChildName
, isSet
, isSet'
, isSetWithDefault
, hasAttrValueOf'
, failIfNotAttrValueOf
, isThatTheAttrValue
, searchAttrIn
, searchAttrWith
, searchAttr
, lookupAttr
, lookupAttr'
, lookupAttrWithDefault
, lookupDefaultingAttr
, findAttr'
, findAttr
@ -93,25 +60,9 @@ module Text.Pandoc.Readers.Odt.Generic.XMLConverter
, readAttr'
, readAttrWithDefault
, getAttr
-- , (>/<)
-- , (?>/<)
, executeIn
, collectEvery
, withEveryL
, withEvery
, tryAll
, tryAll'
, IdXMLConverter
, MaybeEConverter
, ElementMatchConverter
, MaybeCConverter
, ContentMatchConverter
, makeMatcherE
, makeMatcherC
, prepareMatchersE
, prepareMatchersC
, matchChildren
, matchContent''
, matchContent'
, matchContent
) where
@ -121,7 +72,6 @@ import Control.Monad ( MonadPlus )
import Control.Arrow
import qualified Data.Map as M
import qualified Data.Foldable as F
import Data.Default
import Data.Maybe
@ -208,17 +158,6 @@ currentElement :: XMLConverterState nsID extraState
-> XML.Element
currentElement state = head (parentElements state)
-- | Replace the current position by another, modifying the extra state
-- in the process
swapPosition :: (extraState -> extraState')
-> [XML.Element]
-> XMLConverterState nsID extraState
-> XMLConverterState nsID extraState'
swapPosition f stack state
= state { parentElements = stack
, moreState = f (moreState state)
}
-- | Replace the current position by another, modifying the extra state
-- in the process
swapStack' :: XMLConverterState nsID extraState
@ -264,14 +203,6 @@ runConverter :: XMLConverter nsID extraState input output
-> output
runConverter converter state input = snd $ runArrowState converter (state,input)
--
runConverter'' :: (NameSpaceID nsID)
=> XMLConverter nsID extraState (Fallible ()) output
-> extraState
-> XML.Element
-> output
runConverter'' converter extraState element = runConverter (readNSattributes >>> converter) (createStartState element extraState) ()
runConverter' :: (NameSpaceID nsID)
=> FallibleXMLConverter nsID extraState () success
-> extraState
@ -279,20 +210,6 @@ runConverter' :: (NameSpaceID nsID)
-> Fallible success
runConverter' converter extraState element = runConverter (readNSattributes >>? converter) (createStartState element extraState) ()
--
runConverterF' :: FallibleXMLConverter nsID extraState x y
-> XMLConverterState nsID extraState
-> Fallible x -> Fallible y
runConverterF' a s e = runConverter (returnV e >>? a) s e
--
runConverterF :: (NameSpaceID nsID)
=> FallibleXMLConverter nsID extraState XML.Element x
-> extraState
-> Fallible XML.Element -> Fallible x
runConverterF a s = either failWith
(\e -> runConverter a (createStartState e s) e)
--
getCurrentElement :: XMLConverter nsID extraState x XML.Element
getCurrentElement = extractFromState currentElement
@ -429,58 +346,16 @@ elemNameIs nsID name = keepingTheValue (lookupNSiri nsID) >>% hasThatName
-- General content
--------------------------------------------------------------------------------
--
strContent :: XMLConverter nsID extraState x String
strContent = getCurrentElement
>>^ XML.strContent
--
elContent :: XMLConverter nsID extraState x [XML.Content]
elContent = getCurrentElement
>>^ XML.elContent
--------------------------------------------------------------------------------
-- Current element
--------------------------------------------------------------------------------
--
currentElem :: XMLConverter nsID extraState x (XML.QName)
currentElem = getCurrentElement
>>^ XML.elName
currentElemIs :: (NameSpaceID nsID)
=> nsID -> ElementName
-> XMLConverter nsID extraState x Bool
currentElemIs nsID name = getCurrentElement
>>> elemNameIs nsID name
{-
currentElemIs'' nsID name = ( (getCurrentElement >>^ XML.elName >>>
(XML.qName >>^ (&&).(== name) )
^&&&^
(XML.qIRI >>^ (==) )
) >>% (.)
) &&& lookupNSiri nsID >>% ($)
-}
--
expectElement :: (NameSpaceID nsID)
=> nsID -> ElementName
-> FallibleXMLConverter nsID extraState x ()
expectElement nsID name = currentElemIs nsID name
>>^ boolToChoice
--------------------------------------------------------------------------------
-- Chilren
--------------------------------------------------------------------------------
--
elChildren :: XMLConverter nsID extraState x [XML.Element]
elChildren = getCurrentElement
>>^ XML.elChildren
--
findChildren :: (NameSpaceID nsID)
=> nsID -> ElementName
@ -489,18 +364,6 @@ findChildren nsID name = elemName nsID name
&&& getCurrentElement
>>% XML.findChildren
--
filterChildren :: (XML.Element -> Bool)
-> XMLConverter nsID extraState x [XML.Element]
filterChildren p = getCurrentElement
>>^ XML.filterChildren p
--
filterChildrenName :: (XML.QName -> Bool)
-> XMLConverter nsID extraState x [XML.Element]
filterChildrenName p = getCurrentElement
>>^ XML.filterChildrenName p
--
findChild' :: (NameSpaceID nsID)
=> nsID
@ -517,44 +380,11 @@ findChild :: (NameSpaceID nsID)
findChild nsID name = findChild' nsID name
>>> maybeToChoice
--
filterChild' :: (XML.Element -> Bool)
-> XMLConverter nsID extraState x (Maybe XML.Element)
filterChild' p = getCurrentElement
>>^ XML.filterChild p
--
filterChild :: (XML.Element -> Bool)
-> FallibleXMLConverter nsID extraState x XML.Element
filterChild p = filterChild' p
>>> maybeToChoice
--
filterChildName' :: (XML.QName -> Bool)
-> XMLConverter nsID extraState x (Maybe XML.Element)
filterChildName' p = getCurrentElement
>>^ XML.filterChildName p
--
filterChildName :: (XML.QName -> Bool)
-> FallibleXMLConverter nsID extraState x XML.Element
filterChildName p = filterChildName' p
>>> maybeToChoice
--------------------------------------------------------------------------------
-- Attributes
--------------------------------------------------------------------------------
--
isSet :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> (Either Failure Bool)
-> FallibleXMLConverter nsID extraState x Bool
isSet nsID attrName deflt
= findAttr' nsID attrName
>>^ maybe deflt stringToBool
--
isSet' :: (NameSpaceID nsID)
=> nsID -> AttributeName
@ -570,34 +400,6 @@ isSetWithDefault nsID attrName def'
= isSet' nsID attrName
>>^ fromMaybe def'
--
hasAttrValueOf' :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> AttributeValue
-> XMLConverter nsID extraState x Bool
hasAttrValueOf' nsID attrName attrValue
= findAttr nsID attrName
>>> ( const False ^|||^ (==attrValue))
--
failIfNotAttrValueOf :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> AttributeValue
-> FallibleXMLConverter nsID extraState x ()
failIfNotAttrValueOf nsID attrName attrValue
= hasAttrValueOf' nsID attrName attrValue
>>^ boolToChoice
-- | Is the value that is currently transported in the arrow the value of
-- the specified attribute?
isThatTheAttrValue :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> FallibleXMLConverter nsID extraState AttributeValue Bool
isThatTheAttrValue nsID attrName
= keepingTheValue
(findAttr nsID attrName)
>>% right.(==)
-- | Lookup value in a dictionary, fail if no attribute found or value
-- not in dictionary
searchAttrIn :: (NameSpaceID nsID)
@ -608,18 +410,6 @@ searchAttrIn nsID attrName dict
= findAttr nsID attrName
>>?^? maybeToChoice.(`lookup` dict )
-- | Lookup value in a dictionary. Fail if no attribute found. If value not in
-- dictionary, return default value
searchAttrWith :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> a
-> [(AttributeValue,a)]
-> FallibleXMLConverter nsID extraState x a
searchAttrWith nsID attrName defV dict
= findAttr nsID attrName
>>?^ (fromMaybe defV).(`lookup` dict )
-- | Lookup value in a dictionary. If attribute or value not found,
-- return default value
searchAttr :: (NameSpaceID nsID)
@ -789,16 +579,6 @@ prepareIteration nsID name = keepingTheValue
(findChildren nsID name)
>>% distributeValue
-- | Applies a converter to every child element of a specific type.
-- Collects results in a 'Monoid'.
-- Fails completely if any conversion fails.
collectEvery :: (NameSpaceID nsID, Monoid m)
=> nsID -> ElementName
-> FallibleXMLConverter nsID extraState a m
-> FallibleXMLConverter nsID extraState a m
collectEvery nsID name a = prepareIteration nsID name
>>> foldS' (switchingTheStack a)
--
withEveryL :: (NameSpaceID nsID)
=> nsID -> ElementName
@ -826,16 +606,6 @@ tryAll nsID name a = prepareIteration nsID name
>>> iterateS (switchingTheStack a)
>>^ collectRights
-- | Applies a converter to every child element of a specific type.
-- Collects all successful results.
tryAll' :: (NameSpaceID nsID, F.Foldable c, MonadPlus c)
=> nsID -> ElementName
-> FallibleXMLConverter nsID extraState b a
-> XMLConverter nsID extraState b (c a)
tryAll' nsID name a = prepareIteration nsID name
>>> iterateS (switchingTheStack a)
>>^ collectRightsF
--------------------------------------------------------------------------------
-- Matching children
--------------------------------------------------------------------------------
@ -843,15 +613,6 @@ tryAll' nsID name a = prepareIteration nsID name
type IdXMLConverter nsID moreState x
= XMLConverter nsID moreState x x
type MaybeEConverter nsID moreState x
= Maybe (IdXMLConverter nsID moreState (x, XML.Element))
-- Chainable converter that helps deciding which converter to actually use.
type ElementMatchConverter nsID extraState x
= IdXMLConverter nsID
extraState
(MaybeEConverter nsID extraState x, XML.Element)
type MaybeCConverter nsID moreState x
= Maybe (IdXMLConverter nsID moreState (x, XML.Content))
@ -861,26 +622,6 @@ type ContentMatchConverter nsID extraState x
extraState
(MaybeCConverter nsID extraState x, XML.Content)
-- Helper function: The @c@ is actually a converter that is to be selected by
-- matching XML elements to the first two parameters.
-- The fold used to match elements however is very simple, so to use it,
-- this function wraps the converter in another converter that unifies
-- the accumulator. Think of a lot of converters with the resulting type
-- chained together. The accumulator not only transports the element
-- unchanged to the next matcher, it also does the actual selecting by
-- combining the intermediate results with '(<|>)'.
makeMatcherE :: (NameSpaceID nsID)
=> nsID -> ElementName
-> FallibleXMLConverter nsID extraState a a
-> ElementMatchConverter nsID extraState a
makeMatcherE nsID name c = ( second (
elemNameIs nsID name
>>^ bool Nothing (Just tryC)
)
>>% (<|>)
) &&&^ snd
where tryC = (fst ^&&& executeThere c >>% recover) &&&^ snd
-- Helper function: The @c@ is actually a converter that is to be selected by
-- matching XML content to the first two parameters.
-- The fold used to match elements however is very simple, so to use it,
@ -913,13 +654,6 @@ makeMatcherC nsID name c = ( second ( contentToElem
XML.Elem e' -> succeedWith e'
_ -> failEmpty
-- Creates and chains a bunch of matchers
prepareMatchersE :: (NameSpaceID nsID)
=> [(nsID, ElementName, FallibleXMLConverter nsID extraState x x)]
-> ElementMatchConverter nsID extraState x
--prepareMatchersE = foldSs . (map $ uncurry3 makeMatcherE)
prepareMatchersE = reverseComposition . (map $ uncurry3 makeMatcherE)
-- Creates and chains a bunch of matchers
prepareMatchersC :: (NameSpaceID nsID)
=> [(nsID, ElementName, FallibleXMLConverter nsID extraState x x)]
@ -927,52 +661,6 @@ prepareMatchersC :: (NameSpaceID nsID)
--prepareMatchersC = foldSs . (map $ uncurry3 makeMatcherC)
prepareMatchersC = reverseComposition . (map $ uncurry3 makeMatcherC)
-- | Takes a list of element-data - converter groups and
-- * Finds all children of the current element
-- * Matches each group to each child in order (at most one group per child)
-- * Filters non-matched children
-- * Chains all found converters in child-order
-- * Applies the chain to the input element
matchChildren :: (NameSpaceID nsID)
=> [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)]
-> XMLConverter nsID extraState a a
matchChildren lookups = let matcher = prepareMatchersE lookups
in keepingTheValue (
elChildren
>>> map (Nothing,)
^>> iterateSL matcher
>>^ catMaybes.map (\(m,e) -> fmap (swallowElem e) m)
-- >>> foldSs
>>> reverseComposition
)
>>> swap
^>> app
where
-- let the converter swallow the element and drop the element
-- in the return value
swallowElem element converter = (,element) ^>> converter >>^ fst
--
matchContent'' :: (NameSpaceID nsID)
=> [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)]
-> XMLConverter nsID extraState a a
matchContent'' lookups = let matcher = prepareMatchersC lookups
in keepingTheValue (
elContent
>>> map (Nothing,)
^>> iterateSL matcher
>>^ catMaybes.map (\(m,c) -> fmap (swallowContent c) m)
-- >>> foldSs
>>> reverseComposition
)
>>> swap
^>> app
where
-- let the converter swallow the content and drop the content
-- in the return value
swallowContent content converter = (,content) ^>> converter >>^ fst
-- | Takes a list of element-data - converter groups and
-- * Finds all content of the current element
-- * Matches each group to each piece of content in order
@ -1018,14 +706,6 @@ matchContent lookups fallback
-- Internals
--------------------------------------------------------------------------------
stringToBool :: (Monoid failure) => String -> Either failure Bool
stringToBool val -- stringToBool' val >>> maybeToChoice
| val `elem` trueValues = succeedWith True
| val `elem` falseValues = succeedWith False
| otherwise = failEmpty
where trueValues = ["true" ,"on" ,"1"]
falseValues = ["false","off","0"]
stringToBool' :: String -> Maybe Bool
stringToBool' val | val `elem` trueValues = Just True
| val `elem` falseValues = Just False

83
src/Text/Pandoc/Readers/Odt/StyleReader.hs
View file

@ -50,23 +50,11 @@ module Text.Pandoc.Readers.Odt.StyleReader
, ListLevelType (..)
, LengthOrPercent (..)
, lookupStyle
, getTextProperty
, getTextProperty'
, getParaProperty
, getListStyle
, getListLevelStyle
, getStyleFamily
, lookupDefaultStyle
, lookupDefaultStyle'
, lookupListStyleByName
, getPropertyChain
, textPropertyChain
, stylePropertyChain
, stylePropertyChain'
, getStylePropertyChain
, extendedStylePropertyChain
, extendedStylePropertyChain'
, liftStyles
, readStylesAt
) where
@ -83,7 +71,6 @@ import Data.Maybe
import qualified Text.XML.Light as XML
import Text.Pandoc.Readers.Odt.Arrows.State
import Text.Pandoc.Readers.Odt.Arrows.Utils
import Text.Pandoc.Readers.Odt.Generic.Utils
@ -623,20 +610,11 @@ chooseMostSpecificListLevelStyle ls | ls == mempty = Nothing
lookupStyle :: StyleName -> Styles -> Maybe Style
lookupStyle name Styles{..} = M.lookup name stylesByName
--
lookupDefaultStyle :: StyleFamily -> Styles -> StyleProperties
lookupDefaultStyle family Styles{..} = fromMaybe def
(M.lookup family defaultStyleMap)
--
lookupDefaultStyle' :: Styles -> StyleFamily -> StyleProperties
lookupDefaultStyle' Styles{..} family = fromMaybe def
(M.lookup family defaultStyleMap)
--
getListStyle :: Style -> Styles -> Maybe ListStyle
getListStyle Style{..} styles = listStyle >>= (`lookupListStyleByName` styles)
--
lookupListStyleByName :: StyleName -> Styles -> Maybe ListStyle
lookupListStyleByName name Styles{..} = M.lookup name listStylesByName
@ -681,64 +659,3 @@ extendedStylePropertyChain [style] styles = (stylePropertyChain style s
++ (maybeToList (fmap (lookupDefaultStyle' styles) (getStyleFamily style styles)))
extendedStylePropertyChain (style:trace) styles = (stylePropertyChain style styles)
++ (extendedStylePropertyChain trace styles)
-- Optimizable with Data.Sequence
--
extendedStylePropertyChain' :: [Style] -> Styles -> Maybe [StyleProperties]
extendedStylePropertyChain' [] _ = Nothing
extendedStylePropertyChain' [style] styles = Just (
(stylePropertyChain style styles)
++ (maybeToList (fmap (lookupDefaultStyle' styles) (getStyleFamily style styles)))
)
extendedStylePropertyChain' (style:trace) styles = fmap ((stylePropertyChain style styles) ++)
(extendedStylePropertyChain' trace styles)
--
stylePropertyChain' :: Styles -> Style -> [StyleProperties]
stylePropertyChain' = flip stylePropertyChain
--
getStylePropertyChain :: StyleName -> Styles -> [StyleProperties]
getStylePropertyChain name styles = maybe []
(`stylePropertyChain` styles)
(lookupStyle name styles)
--
getPropertyChain :: (StyleProperties -> Maybe a) -> Style -> Styles -> [a]
getPropertyChain extract style styles = catMaybes
$ map extract
$ stylePropertyChain style styles
--
textPropertyChain :: Style -> Styles -> [TextProperties]
textPropertyChain = getPropertyChain textProperties
--
paraPropertyChain :: Style -> Styles -> [ParaProperties]
paraPropertyChain = getPropertyChain paraProperties
--
getTextProperty :: (TextProperties -> a) -> Style -> Styles -> Maybe a
getTextProperty extract style styles = fmap extract
$ listToMaybe
$ textPropertyChain style styles
--
getTextProperty' :: (TextProperties -> Maybe a) -> Style -> Styles -> Maybe a
getTextProperty' extract style styles = F.asum
$ map extract
$ textPropertyChain style styles
--
getParaProperty :: (ParaProperties -> a) -> Style -> Styles -> Maybe a
getParaProperty extract style styles = fmap extract
$ listToMaybe
$ paraPropertyChain style styles
-- | Lifts the reader into another readers' state.
liftStyles :: (OdtConverterState s -> OdtConverterState Styles)
-> (OdtConverterState Styles -> OdtConverterState s )
-> XMLReader s x x
liftStyles extract inject = switchState extract inject
$ convertingExtraState M.empty readAllStyles