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 Text.Pandoc.Readers.Odt.Generic.Fallible
import Text.Pandoc.Readers.Odt.Generic.Utils
and2 :: (Arrow a) => a b c -> a b c' -> a b (c,c')
and2 = (&&&)
and3 :: (Arrow a)
=> a b c0->a b c1->a b c2
-> a b (c0,c1,c2 )
and4 :: (Arrow a)
=> a b c0->a b c1->a b c2->a b c3
-> a b (c0,c1,c2,c3 )
and5 :: (Arrow a)
=> a b c0->a b c1->a b c2->a b c3->a b c4
-> a b (c0,c1,c2,c3,c4 )
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 )
and4 a b c d = (and3 a b c ) &&& d
>>^ \((z,y,x ) , w) -> (z,y,x,w )
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
liftA3 :: (Arrow a) => (z->y->x -> r)
-> a b z->a b y->a b x
-> a b r
liftA4 :: (Arrow a) => (z->y->x->w -> r)
-> a b z->a b y->a b x->a b w
-> a b r
liftA5 :: (Arrow a) => (z->y->x->w->v -> r)
-> a b z->a b y->a b x->a b w->a b v
-> a b 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
duplicate :: (Arrow a) => a b (b,b)
duplicate = arr $ join (,)
joinOn :: (Arrow a) => (x -> y -> z) -> a (x,y) z
joinOn = arr.uncurry
(>>%) :: (Arrow a) => a x (b,c) -> (b -> c -> d) -> a x d
a >>% f = a >>^ uncurry f
(%<<) :: (Arrow a) => (b -> c -> d) -> a x (b,c) -> a x d
(%<<) = flip (>>%)
(%>>) :: (Arrow a) => (b -> c -> d) -> a d r -> a (b,c) r
f %>> a = uncurry f ^>> a
(<<%) :: (Arrow a) => a d r -> (b -> c -> d) -> a (b,c) r
(<<%) = flip (%>>)
infixr 2 >>%, %<<, %>>, <<%
keepingTheValue :: (Arrow a) => a b c -> a b (b,c)
keepingTheValue a = returnA &&& a
keepingTheValue' :: (Arrow a) => a b c -> a b (c,b)
keepingTheValue' a = a &&& returnA
(>>>=) :: (ArrowChoice a) => a x (Maybe b) -> a b (Maybe c) -> a x (Maybe c)
a1 >>>= a2 = a1 >>> maybeToChoice >>> right a2 >>> choiceToMaybe >>^ join
infixr 2 >>>=
(>++<) :: (Arrow a, MonadPlus m) => a x (m b) -> a x (m b) -> a x (m b)
(>++<) = liftA2 mplus
leftLift :: (ArrowChoice a) => (l -> l') -> a (Either l r) (Either l' r)
leftLift = left.arr
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
l ^||| r = arr l ||| r
l |||^ r = l ||| arr r
l ^|||^ r = arr l ||| arr r
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')
l ^*** r = arr l *** r
l ***^ r = l *** arr r
l ^***^ r = arr l *** arr r
infixr 3 ^***, ***^, ^***^
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
choiceToMaybe :: (ArrowChoice a) => a (Either l r) (Maybe r)
choiceToMaybe = arr eitherToMaybe
maybeToChoice :: (ArrowChoice a) => a (Maybe b) (Fallible b)
maybeToChoice = arr maybeToEither
returnV :: (Arrow a) => c -> a x c
returnV = arr.const
returnA_ :: (Arrow a) => a _b ()
returnA_ = returnV ()
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
coEval :: (Arrow a, F.Foldable f, Monoid m) => f (a b m) -> a b m
coEval = evalParallelArrow . (F.foldMap CoEval)
type FallibleArrow a input failure success = a input (Either failure success)
type ReFallibleArrow a failure success success'
= FallibleArrow a (Either failure success) failure success'
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'
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
liftError :: (ArrowChoice a, Monoid failure)
=> failure
-> ReFallibleArrow a failure success success
liftError e = leftLift (e <>)
_raiseA :: (ArrowChoice a)
=> failure
-> FallibleArrow a x failure success
_raiseA e = returnV (Left e)
_raiseAEmpty :: (ArrowChoice a, Monoid failure)
=> FallibleArrow a x failure success
_raiseAEmpty = _raiseA mempty
raiseA :: (ArrowChoice a, Monoid failure)
=> failure
-> ReFallibleArrow a failure success success
raiseA e = arr $ Left.(either (<> e) (const e))
raiseAEmpty :: (ArrowChoice a, Monoid failure)
=> ReFallibleArrow a failure success success
raiseAEmpty = arr (fromRight (const mempty) >>> Left)
(>>?) :: (ArrowChoice a)
=> FallibleArrow a x failure success
-> FallibleArrow a success failure success'
-> FallibleArrow a x failure success'
a >>? b = a >>> Left ^||| b
(>>?^) :: (ArrowChoice a)
=> FallibleArrow a x failure success
-> (success -> success')
-> FallibleArrow a x failure success'
a >>?^ f = a >>^ Left ^|||^ Right . f
(>>?^?) :: (ArrowChoice a)
=> FallibleArrow a x failure success
-> (success -> Either failure success')
-> FallibleArrow a x failure success'
a >>?^? b = a >>> Left ^|||^ b
(^>>?) :: (ArrowChoice a)
=> (x -> Either failure success)
-> FallibleArrow a success failure success'
-> FallibleArrow a x failure success'
a ^>>? b = a ^>> Left ^||| b
(^>>?^) :: (ArrowChoice a)
=> (x -> Either failure success)
-> (success -> success')
-> FallibleArrow a x failure success'
a ^>>?^ f = arr $ a >>> right f
(^>>?^?) :: (ArrowChoice a)
=> (x -> Either failure success)
-> (success -> Either failure success')
-> FallibleArrow a x failure success'
a ^>>?^? f = a ^>> Left ^|||^ f
(>>?!) :: (ArrowChoice a)
=> FallibleArrow a x failure success
-> a success success'
-> FallibleArrow a x failure success'
a >>?! f = a >>> right f
(>>?%) :: (ArrowChoice a)
=> FallibleArrow a x f (b,b')
-> (b -> b' -> c)
-> FallibleArrow a x f c
a >>?% f = a >>?^ (uncurry f)
(^>>?%) :: (ArrowChoice a)
=> (x -> Either f (b,b'))
-> (b -> b' -> c)
-> FallibleArrow a x f c
a ^>>?% f = arr a >>?^ (uncurry f)
(>>?%?) :: (ArrowChoice a)
=> FallibleArrow a x f (b,b')
-> (b -> b' -> (Either f c))
-> FallibleArrow a x f c
a >>?%? f = a >>?^? (uncurry f)
infixr 1 >>?, >>?^, >>?^?
infixr 1 ^>>?, ^>>?^, ^>>?^?, >>?!
infixr 1 >>?%, ^>>?%, >>?%?
ifFailedUse :: (ArrowChoice a) => v -> a (Either f v) v
ifFailedUse v = arr $ either (const v) id
(<&&>) :: (Arrow a) => a x Bool -> a x Bool -> a x Bool
(<&&>) = liftA2 (&&)
(<||>) :: (Arrow a) => a x Bool -> a x Bool -> a x Bool
(<||>) = liftA2 (||)
(>&&<) :: (ArrowChoice a, Monoid f) => FallibleArrow a x f s
-> FallibleArrow a x f s'
-> FallibleArrow a x f (s,s')
(>&&<) = liftA2 chooseMin
(>||<) :: (ArrowChoice a, Monoid f, Monoid s) => FallibleArrow a x f s
-> FallibleArrow a x f s
-> FallibleArrow a x f s
(>||<) = liftA2 chooseMax
ifFailedDo :: (ArrowChoice a)
=> FallibleArrow a x f y
-> FallibleArrow a x f y
-> FallibleArrow a x f y
ifFailedDo a b = keepingTheValue a >>> repackage ^>> (b |||^ Right)
where repackage (x , Left _) = Left x
repackage (_ , Right y) = Right y
infixr 4 <&&>, <||>, >&&<, >||<
infixr 1 `ifFailedDo`