module Control.Monad.Stepwise.Derived
( localChoice, mergeSteps
, globalChoice
) where
import Control.Monad.Stepwise.Core
import Control.Applicative
import Control.Monad.Error
import Control.Monad.State.Strict
import Data.Monoid
instance Error e => MonadError e (Stepwise e i o w) where
throwError = abort
catchError m h = case smallStep m of
Step i m' -> info i (catchError m' h)
Fin v -> return v
Failed mb -> h (maybe noMsg id mb)
Lookahead f -> lookahead f
instance Error e => Applicative (Stepwise e i o w) where
pure = return
p <*> q = let !r1 = (\f -> let !r2 = return . f in q >>= r2)
in p >>= r1
instance (Monoid (i w), Monoid e, Error e) => Alternative (Stepwise e i o w) where
empty = fail "empty alternative"
p <|> q = localChoice mergeSteps (\e1 e2 -> abort (e1 `mappend` e2)) p q
mergeSteps :: (Monoid (i w), Monoid e, Error e) => i w -> Stepwise e i o w a -> i w -> Stepwise e i o w a -> Stepwise e i o w a
mergeSteps i1 p1 i2 p2 = info (i1 `mappend` i2) (p1 <|> p2)
localChoice :: (i w -> Stepwise e i o w a -> i w -> Stepwise e i o w a -> Stepwise e i o w a) -> (e -> e -> Stepwise e i o w a) -> Stepwise e i o w a -> Stepwise e i o w a -> Stepwise e i o w a
localChoice !f !g p q = merge (localStep p) (localStep q) where
merge (Step i1 p1) (Step i2 p2) = f i1 p1 i2 p2
merge (Fin x) _ = final x
merge _ (Fin x) = final x
merge (Failed mb1) (Failed mb2) = case mb1 of
Just s1 -> case mb2 of
Just s2 -> g s1 s2
Nothing -> failure mb1
Nothing -> failure mb2
merge (Step i m) (Failed _) = info i m
merge (Failed _) (Step i m) = info i m
globalChoice :: Error e => (forall v . Stepwise e i Lazy v a) -> (forall v . Stepwise e i Lazy v a) -> Stepwise e i o w a
globalChoice l r = lookahead (\k -> merge (l >>= k) (r >>= k))
where merge = localChoice both (\e _ -> abort e)
both i1 p1 _ p2 = info i1 (p1 `merge` p2)