diff options
Diffstat (limited to 'src/Text/Pandoc/Readers/Odt/Arrows/State.hs')
-rw-r--r-- | src/Text/Pandoc/Readers/Odt/Arrows/State.hs | 253 |
1 files changed, 253 insertions, 0 deletions
diff --git a/src/Text/Pandoc/Readers/Odt/Arrows/State.hs b/src/Text/Pandoc/Readers/Odt/Arrows/State.hs new file mode 100644 index 000000000..310ca028e --- /dev/null +++ b/src/Text/Pandoc/Readers/Odt/Arrows/State.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} +{- +Copyright (C) 2015 Martin Linnemann <theCodingMarlin@googlemail.com> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + 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 Prelude hiding ( foldr, foldl ) + +import qualified Control.Category as Cat +import Control.Arrow +import Control.Monad + +import Data.Monoid +import Data.Foldable + +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) } + +-- | Constructor +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 + +-- | Constructor +ignoringState :: ( a -> b ) -> ArrowState state a b +ignoringState = ArrowState . second + +-- | Constructor +fromState :: (state -> (state, b)) -> ArrowState state a b +fromState = ArrowState . (.fst) + +-- | Constructor +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) + -> (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) + + +-- | 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. +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 + +-- | 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' 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) + +-- | 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 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) + => 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) + +-- | 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 a = ArrowState $ \(s,f) -> foldl a' (s,mzero) f + where a' (s',m) x = second ((mplus m).return) $ runArrowState a (s',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' 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 + +-- | 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 |