{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TupleSections     #-}
{- |
   Module      : Text.Pandoc.Readers.ODT.Arrows.State
   Copyright   : Copyright (C) 2015 Martin Linnemann
   License     : GNU GPL, version 2 or above

   Maintainer  : Martin Linnemann <theCodingMarlin@googlemail.com>
   Stability   : alpha
   Portability : portable

An arrow that transports a state. It is in essence a more powerful version of
the standard state monad. As it is such a simple extension, there are
other version out there that do exactly the same.
The implementation is duplicated, though, to add some useful features.
Most of these might be implemented without access to innards, but it's much
faster and easier to implement this way.
-}

module Text.Pandoc.Readers.ODT.Arrows.State where

import Control.Arrow
import qualified Control.Category as Cat
import Control.Monad
import Data.List (foldl')
import Text.Pandoc.Readers.ODT.Arrows.Utils
import Text.Pandoc.Readers.ODT.Generic.Fallible


newtype ArrowState state a b = ArrowState
  { forall state a b. ArrowState state a b -> (state, a) -> (state, b)
runArrowState :: (state, a) -> (state, b) }

-- | Constructor
withState           :: (state -> a -> (state, b)) -> ArrowState state a b
withState :: forall state a b.
(state -> a -> (state, b)) -> ArrowState state a b
withState            = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry

-- | Constructor
modifyState         :: (state      ->  state    ) -> ArrowState state a a
modifyState :: forall state a. (state -> state) -> ArrowState state a a
modifyState          = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first

-- | Constructor
ignoringState       :: (         a ->         b ) -> ArrowState state a b
ignoringState :: forall a b state. (a -> b) -> ArrowState state a b
ignoringState        = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second

-- | Constructor
fromState           :: (state      -> (state, b)) -> ArrowState state a b
fromState :: forall state b a. (state -> (state, b)) -> ArrowState state a b
fromState            = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst)

-- | Constructor
extractFromState    :: (state      ->         b ) -> ArrowState state x b
extractFromState :: forall state b x. (state -> b) -> ArrowState state x b
extractFromState   state -> b
f = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall a b. (a -> b) -> a -> b
$ \(state
state,x
_) -> (state
state, state -> b
f state
state)

-- | Constructor
tryModifyState      :: (state ->  Either f state)
                    -> ArrowState state a (Either f a)
tryModifyState :: forall state f a.
(state -> Either f state) -> ArrowState state a (Either f a)
tryModifyState     state -> Either f state
f = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall a b. (a -> b) -> a -> b
$ \(state
state,a
a)
                                  -> (state
state,)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. a -> Either a b
Left forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| (,forall a b. b -> Either a b
Right a
a) forall a b. (a -> b) -> a -> b
$ state -> Either f state
f state
state

instance Cat.Category (ArrowState s) where
  id :: forall a. ArrowState s a a
id                = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall a. a -> a
id
  ArrowState s b c
arrow2 . :: forall b c a.
ArrowState s b c -> ArrowState s a b -> ArrowState s a c
. ArrowState s a b
arrow1   = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall a b. (a -> b) -> a -> b
$ forall state a b. ArrowState state a b -> (state, a) -> (state, b)
runArrowState ArrowState s b c
arrow2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state a b. ArrowState state a b -> (state, a) -> (state, b)
runArrowState ArrowState s a b
arrow1

instance Arrow (ArrowState state) where
  arr :: forall b c. (b -> c) -> ArrowState state b c
arr               = forall a b state. (a -> b) -> ArrowState state a b
ignoringState
  first :: forall b c d.
ArrowState state b c -> ArrowState state (b, d) (c, d)
first  ArrowState state b c
a          = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall a b. (a -> b) -> a -> b
$ \(state
s,(b
aF,d
aS))
                                    -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (,d
aS) forall a b. (a -> b) -> a -> b
$ forall state a b. ArrowState state a b -> (state, a) -> (state, b)
runArrowState ArrowState state b c
a (state
s,b
aF)
  second :: forall b c d.
ArrowState state b c -> ArrowState state (d, b) (d, c)
second ArrowState state b c
a          = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall a b. (a -> b) -> a -> b
$ \(state
s,(d
aF,b
aS))
                                    -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (d
aF,) forall a b. (a -> b) -> a -> b
$ forall state a b. ArrowState state a b -> (state, a) -> (state, b)
runArrowState ArrowState state b c
a (state
s,b
aS)

instance ArrowChoice (ArrowState state) where
  left :: forall b c d.
ArrowState state b c -> ArrowState state (Either b d) (Either c d)
left   ArrowState state b c
a          = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall a b. (a -> b) -> a -> b
$ \(state
s,Either b d
e) -> case Either b d
e of
                                 Left  b
l -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a b. a -> Either a b
Left  forall a b. (a -> b) -> a -> b
$ forall state a b. ArrowState state a b -> (state, a) -> (state, b)
runArrowState ArrowState state b c
a (state
s,b
l)
                                 Right d
r -> (state
s, forall a b. b -> Either a b
Right d
r)
  right :: forall b c d.
ArrowState state b c -> ArrowState state (Either d b) (Either d c)
right  ArrowState state b c
a          = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall a b. (a -> b) -> a -> b
$ \(state
s,Either d b
e) -> case Either d b
e of
                                 Left  d
l -> (state
s, forall a b. a -> Either a b
Left d
l)
                                 Right b
r -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall state a b. ArrowState state a b -> (state, a) -> (state, b)
runArrowState ArrowState state b c
a (state
s,b
r)

instance ArrowApply (ArrowState state) where
   app :: forall b c. ArrowState state (ArrowState state b c, b) c
app             = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall a b. (a -> b) -> a -> b
$ \(state
s, (ArrowState state b c
f,b
b)) -> forall state a b. ArrowState state a b -> (state, a) -> (state, b)
runArrowState ArrowState state b c
f (state
s,b
b)

-- | 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.
withSubStateF  :: ArrowState s  x (Either f s')
               -> ArrowState s' s (Either f s )
               -> ArrowState s  x (Either f x )
withSubStateF :: forall s x f s'.
ArrowState s x (Either f s')
-> ArrowState s' s (Either f s) -> ArrowState s x (Either f x)
withSubStateF  ArrowState s x (Either f s')
unlift ArrowState s' s (Either f s)
a = forall (a :: * -> * -> *) b c. Arrow a => a b c -> a b (b, c)
keepingTheValue (forall s x f s'.
ArrowState s x (Either f s')
-> ArrowState s' s (Either f s) -> ArrowState s x (Either f s')
withSubStateF' ArrowState s x (Either f s')
unlift ArrowState s' s (Either f s)
a)
                          forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ forall (v :: * -> *) f a.
ChoiceVector v =>
v (Either f a) -> Either f (v a)
spreadChoice
                          forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst

-- | Switches the type of the state temporarily.
-- Returns the resulting sub-state.
withSubStateF' :: ArrowState s  x (Either f s')
               -> ArrowState s' s (Either f s )
               -> ArrowState s  x (Either f s')
withSubStateF' :: forall s x f s'.
ArrowState s x (Either f s')
-> ArrowState s' s (Either f s) -> ArrowState s x (Either f s')
withSubStateF' ArrowState s x (Either f s')
unlift ArrowState s' s (Either f s)
a = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState (s, x) -> (s, Either f s')
go
  where go :: (s, x) -> (s, Either f s')
go p :: (s, x)
p@(s
s,x
_) = forall {b} {a} {a} {a} {b}.
ArrowState b a (Either a a)
-> ((a, b) -> (s, Either a b)) -> (b, a) -> (s, Either a b)
tryRunning ArrowState s x (Either f s')
unlift
                                ( forall {b} {a} {a} {a} {b}.
ArrowState b a (Either a a)
-> ((a, b) -> (s, Either a b)) -> (b, a) -> (s, Either a b)
tryRunning ArrowState s' s (Either f s)
a (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a b. b -> Either a b
Right) )
                                (s, x)
p
          where tryRunning :: ArrowState b a (Either a a)
-> ((a, b) -> (s, Either a b)) -> (b, a) -> (s, Either a b)
tryRunning ArrowState b a (Either a a)
a' (a, b) -> (s, Either a b)
b (b, a)
v = case forall state a b. ArrowState state a b -> (state, a) -> (state, b)
runArrowState ArrowState b a (Either a a)
a' (b, a)
v of
                                      (b
_ , Left  a
f) -> (s
s, forall a b. a -> Either a b
Left a
f)
                                      (b
x , Right a
y) -> (a, b) -> (s, Either a b)
b (a
y,b
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.
foldS :: (Foldable f, Monoid m) => ArrowState s x m -> ArrowState s (f x) m
foldS :: forall (f :: * -> *) m s x.
(Foldable f, Monoid m) =>
ArrowState s x m -> ArrowState s (f x) m
foldS ArrowState s x m
a = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall a b. (a -> b) -> a -> b
$ \(s
s,f x
f) -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr x -> (s, m) -> (s, m)
a' (s
s,forall a. Monoid a => a
mempty) f x
f
  where a' :: x -> (s, m) -> (s, m)
a' x
x (s
s',m
m) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall a. Monoid a => a -> a -> a
mappend m
m)  forall a b. (a -> b) -> a -> b
$ forall state a b. ArrowState state a b -> (state, a) -> (state, b)
runArrowState ArrowState s x m
a (s
s',x
x)

-- | Fold a state arrow through something 'Foldable'. Collect the results in a
-- 'MonadPlus'.
iterateS :: (Foldable f, MonadPlus m)
         => ArrowState s    x     y
         -> ArrowState s (f x) (m y)
iterateS :: forall (f :: * -> *) (m :: * -> *) s x y.
(Foldable f, MonadPlus m) =>
ArrowState s x y -> ArrowState s (f x) (m y)
iterateS ArrowState s x y
a = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall a b. (a -> b) -> a -> b
$ \(s
s,f x
f) -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {m :: * -> *}. MonadPlus m => x -> (s, m y) -> (s, m y)
a' (s
s,forall (m :: * -> *) a. MonadPlus m => m a
mzero) f x
f
  where a' :: x -> (s, m y) -> (s, m y)
a' x
x (s
s',m y
m) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus m y
mforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (m :: * -> *) a. Monad m => a -> m a
return) forall a b. (a -> b) -> a -> b
$ forall state a b. ArrowState state a b -> (state, a) -> (state, b)
runArrowState ArrowState s x y
a (s
s',x
x)

-- | Fold a state arrow through something 'Foldable'. Collect the results in a
-- 'MonadPlus'.
iterateSL :: (Foldable f, MonadPlus m)
          => ArrowState s    x     y
          -> ArrowState s (f x) (m y)
iterateSL :: forall (f :: * -> *) (m :: * -> *) s x y.
(Foldable f, MonadPlus m) =>
ArrowState s x y -> ArrowState s (f x) (m y)
iterateSL ArrowState s x y
a = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall a b. (a -> b) -> a -> b
$ \(s
s,f x
f) -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {m :: * -> *}. MonadPlus m => (s, m y) -> x -> (s, m y)
a' (s
s,forall (m :: * -> *) a. MonadPlus m => m a
mzero) f x
f
  where a' :: (s, m y) -> x -> (s, m y)
a' (s
s',m y
m) x
x = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus m y
mforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (m :: * -> *) a. Monad m => a -> m a
return) forall a b. (a -> b) -> a -> b
$ forall state a b. ArrowState state a b -> (state, a) -> (state, b)
runArrowState ArrowState s x y
a (s
s',x
x)


-- | 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.
iterateS' :: (Foldable f, MonadPlus m)
          => ArrowState s    x  (Either e    y )
          -> ArrowState s (f x) (Either e (m y))
iterateS' :: forall (f :: * -> *) (m :: * -> *) s x e y.
(Foldable f, MonadPlus m) =>
ArrowState s x (Either e y) -> ArrowState s (f x) (Either e (m y))
iterateS' ArrowState s x (Either e y)
a = forall state a b.
((state, a) -> (state, b)) -> ArrowState state a b
ArrowState forall a b. (a -> b) -> a -> b
$ \(s
s,f x
f) -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall {m :: * -> *}.
MonadPlus m =>
s -> x -> (s, Either e (m y)) -> (s, Either e (m y))
a' s
s) (s
s,forall a b. b -> Either a b
Right forall (m :: * -> *) a. MonadPlus m => m a
mzero) f x
f
  where a' :: s -> x -> (s, Either e (m y)) -> (s, Either e (m y))
a' s
s x
x (s
s',Right m y
m) = case forall state a b. ArrowState state a b -> (state, a) -> (state, b)
runArrowState ArrowState s x (Either e y)
a (s
s',x
x) of
                                (s
s'',Right y
m') -> (s
s'',forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus m y
m forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return y
m')
                                (s
_  ,Left  e
e ) -> (s
s  ,forall a b. a -> Either a b
Left  e
e )
        a' s
_ x
_   (s, Either e (m y))
e          = (s, Either e (m y))
e