aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Readers/Odt/Arrows
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc/Readers/Odt/Arrows')
-rw-r--r--src/Text/Pandoc/Readers/Odt/Arrows/State.hs90
-rw-r--r--src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs272
2 files changed, 4 insertions, 358 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`
-
-