summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJohn MacFarlane <jgm@berkeley.edu>2017-06-01 10:26:25 +0200
committerGitHub <noreply@github.com>2017-06-01 10:26:25 +0200
commita61dce88e85fdc3d8cc19347b156e2e408f3f405 (patch)
tree3df57ce167c0d1b4ad843970339419efa4476b4c
parente1a066668921e60dd3ca1e1154a5741650294463 (diff)
parentf955af58e6a668179ec678c13d2c5a6c0c3d7b63 (diff)
Merge pull request #3714 from tarleb/odt-reader-cleanup
Odt reader: remove dead code
-rw-r--r--src/Text/Pandoc/Readers/Odt/Arrows/State.hs90
-rw-r--r--src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs272
-rw-r--r--src/Text/Pandoc/Readers/Odt/ContentReader.hs5
-rw-r--r--src/Text/Pandoc/Readers/Odt/Generic/Fallible.hs129
-rw-r--r--src/Text/Pandoc/Readers/Odt/Generic/Utils.hs7
-rw-r--r--src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs320
-rw-r--r--src/Text/Pandoc/Readers/Odt/StyleReader.hs83
7 files changed, 4 insertions, 902 deletions
diff --git a/src/Text/Pandoc/Readers/Odt/Arrows/State.hs b/src/Text/Pandoc/Readers/Odt/Arrows/State.hs
index b056f1ecc..3d716ba19 100644
--- a/src/Text/Pandoc/Readers/Odt/Arrows/State.hs
+++ b/src/Text/Pandoc/Readers/Odt/Arrows/State.hs
@@ -59,10 +59,6 @@ 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
@@ -79,10 +75,6 @@ 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)
tryModifyState f = ArrowState $ \(state,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
diff --git a/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs b/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs
index 218a85661..ecef8b6e3 100644
--- a/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs
+++ b/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs
@@ -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 ^&&&, &&&^, ^&&&^
-( ^*** ) :: (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')
+infixr 3 ^&&&, &&&^
-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`
-
-
diff --git a/src/Text/Pandoc/Readers/Odt/ContentReader.hs b/src/Text/Pandoc/Readers/Odt/ContentReader.hs
index a1bd8cb59..777c10df5 100644
--- a/src/Text/Pandoc/Readers/Odt/ContentReader.hs
+++ b/src/Text/Pandoc/Readers/Odt/ContentReader.hs
@@ -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
diff --git a/src/Text/Pandoc/Readers/Odt/Generic/Fallible.hs b/src/Text/Pandoc/Readers/Odt/Generic/Fallible.hs
index 877443543..4d6a67b8e 100644
--- a/src/Text/Pandoc/Readers/Odt/Generic/Fallible.hs
+++ b/src/Text/Pandoc/Readers/Odt/Generic/Fallible.hs
@@ -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
diff --git a/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs b/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs
index 6c10ed61d..4af4242b6 100644
--- a/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs
+++ b/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs
@@ -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
-
diff --git a/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs b/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs
index 8c03d1a09..1c3e08a7f 100644
--- a/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs
+++ b/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs
@@ -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
@@ -210,17 +160,6 @@ 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
-> [XML.Element]
-> ( XMLConverterState nsID extraState , [XML.Element] )
@@ -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
@@ -280,20 +211,6 @@ runConverter' :: (NameSpaceID nsID)
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
@@ -430,57 +347,15 @@ elemNameIs nsID name = keepingTheValue (lookupNSiri nsID) >>% hasThatName
--------------------------------------------------------------------------------
--
-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
@@ -490,18 +365,6 @@ findChildren nsID name = elemName nsID name
>>% 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
-> ElementName
@@ -517,45 +380,12 @@ 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
-> XMLConverter nsID extraState x (Maybe Bool)
@@ -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))
@@ -862,26 +623,6 @@ type ContentMatchConverter nsID extraState x
(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,
-- this function wraps the converter in another converter that unifies
@@ -914,13 +655,6 @@ makeMatcherC nsID name c = ( second ( contentToElem
_ -> 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)]
-> ContentMatchConverter nsID extraState x
@@ -928,52 +662,6 @@ prepareMatchersC :: (NameSpaceID nsID)
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
-- (at most one group per piece of content)
@@ -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
diff --git a/src/Text/Pandoc/Readers/Odt/StyleReader.hs b/src/Text/Pandoc/Readers/Odt/StyleReader.hs
index 26ba6df82..87a6dc91c 100644
--- a/src/Text/Pandoc/Readers/Odt/StyleReader.hs
+++ b/src/Text/Pandoc/Readers/Odt/StyleReader.hs
@@ -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
@@ -624,20 +611,11 @@ 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
-