module Text.Pandoc.Readers.Odt.Arrows.State where
import Prelude hiding ( foldr, foldl )
import qualified Control.Category as Cat
import Control.Arrow
import Control.Monad
import Data.Foldable
import Data.Monoid
import Text.Pandoc.Readers.Odt.Arrows.Utils
import Text.Pandoc.Readers.Odt.Generic.Fallible
newtype ArrowState state a b = ArrowState
{ runArrowState :: (state, a) -> (state, b) }
withState :: (state -> a -> (state, b)) -> ArrowState state a b
withState = ArrowState . uncurry
withState' :: ((state, a) -> (state, b)) -> ArrowState state a b
withState' = ArrowState
modifyState :: (state -> state ) -> ArrowState state a a
modifyState = ArrowState . first
ignoringState :: ( a -> b ) -> ArrowState state a b
ignoringState = ArrowState . second
fromState :: (state -> (state, b)) -> ArrowState state a b
fromState = ArrowState . (.fst)
extractFromState :: (state -> b ) -> ArrowState state x b
extractFromState f = ArrowState $ \(state,_) -> (state, f state)
withUnchangedState :: (state -> a -> b ) -> ArrowState state a b
withUnchangedState f = ArrowState $ \(state,a) -> (state, f state a)
tryModifyState :: (state -> Either f state)
-> ArrowState state a (Either f a)
tryModifyState f = ArrowState $ \(state,a)
-> (state,).Left ||| (,Right a) $ f state
instance Cat.Category (ArrowState s) where
id = ArrowState id
arrow2 . arrow1 = ArrowState $ (runArrowState arrow2).(runArrowState arrow1)
instance Arrow (ArrowState state) where
arr = ignoringState
first a = ArrowState $ \(s,(aF,aS))
-> second (,aS) $ runArrowState a (s,aF)
second a = ArrowState $ \(s,(aF,aS))
-> second (aF,) $ runArrowState a (s,aS)
instance ArrowChoice (ArrowState state) where
left a = ArrowState $ \(s,e) -> case e of
Left l -> second Left $ runArrowState a (s,l)
Right r -> (s, Right r)
right a = ArrowState $ \(s,e) -> case e of
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)
switchState :: (s -> s') -> (s' -> s) -> ArrowState s' x y -> ArrowState s x y
switchState there back a = ArrowState $ first there
>>> runArrowState a
>>> first back
liftToState :: (s -> s') -> ArrowState s' s s -> ArrowState s x x
liftToState unlift a = modifyState $ unlift &&& id
>>> runArrowState a
>>> snd
withSubState :: ArrowState s x s2 -> ArrowState s2 s s -> ArrowState s x x
withSubState unlift a = keepingTheValue (withSubState unlift a) >>^ fst
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)
withSubStateF :: ArrowState s x (Either f s')
-> ArrowState s' s (Either f s )
-> ArrowState s x (Either f x )
withSubStateF unlift a = keepingTheValue (withSubStateF' unlift a)
>>^ spreadChoice
>>^ fmap fst
withSubStateF' :: ArrowState s x (Either f s')
-> ArrowState s' s (Either f s )
-> ArrowState s x (Either f s')
withSubStateF' unlift a = ArrowState go
where go p@(s,_) = tryRunning unlift
( tryRunning a (second Right) )
p
where tryRunning a' b v = case runArrowState a' v of
(_ , Left f) -> (s, Left f)
(x , Right y) -> b (y,x)
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)
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)
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
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
iterateS :: (Foldable f, MonadPlus m)
=> ArrowState s x y
-> ArrowState s (f x) (m y)
iterateS a = ArrowState $ \(s,f) -> foldr a' (s,mzero) f
where a' x (s',m) = second ((mplus m).return) $ runArrowState a (s',x)
iterateSL :: (Foldable f, MonadPlus m)
=> ArrowState s x y
-> ArrowState s (f x) (m y)
iterateSL a = ArrowState $ \(s,f) -> foldl a' (s,mzero) f
where a' (s',m) x = second ((mplus m).return) $ runArrowState a (s',x)
iterateS' :: (Foldable f, MonadPlus m)
=> ArrowState s x (Either e y )
-> ArrowState s (f x) (Either e (m y))
iterateS' a = ArrowState $ \(s,f) -> foldr (a' s) (s,Right mzero) f
where a' s x (s',Right m) = case runArrowState a (s',x) of
(s'',Right m') -> (s'',Right $ mplus m $ return m')
(_ ,Left e ) -> (s ,Left e )
a' _ _ e = e
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