module Language.KURE.Combinators
(
MonadCatch(..)
, (<<+)
, catchesM
, tryM
, mtryM
, attemptM
, testM
, notM
, modFailMsg
, setFailMsg
, prefixFailMsg
, withPatFailMsg
, guardMsg
, guardM
, ifM
, whenM
, unlessM
, CategoryCatch(..)
, (<+)
, readerT
, acceptR
, accepterR
, tryR
, attemptR
, changedR
, repeatR
, (>+>)
, orR
, andR
, catchesT
, result
, argument
, toFst
, toSnd
, swap
, fork
, forkFirst
, forkSecond
, constant
) where
import Prelude hiding (id , (.), foldr)
import Control.Monad
import Control.Category
import Control.Arrow
import Data.Foldable
import Data.Monoid
import Data.List (isPrefixOf)
infixl 3 >+>, <+, <<+
class Monad m => MonadCatch m where
catchM :: m a -> (String -> m a) -> m a
(<<+) :: MonadCatch m => m a -> m a -> m a
ma <<+ mb = ma `catchM` const mb
catchesM :: (Foldable f, MonadCatch m) => f (m a) -> m a
catchesM = foldr (<<+) (fail "catchesM failed")
tryM :: MonadCatch m => a -> m a -> m a
tryM a ma = ma <<+ return a
mtryM :: (MonadCatch m, Monoid a) => m a -> m a
mtryM = tryM mempty
attemptM :: MonadCatch m => m a -> m (Either String a)
attemptM ma = liftM Right ma `catchM` (return . Left)
testM :: MonadCatch m => m a -> m Bool
testM ma = liftM (const True) ma <<+ return False
notM :: MonadCatch m => m a -> m ()
notM ma = ifM (testM ma) (fail "notM of success") (return ())
modFailMsg :: MonadCatch m => (String -> String) -> m a -> m a
modFailMsg f ma = ma `catchM` (fail . f)
setFailMsg :: MonadCatch m => String -> m a -> m a
setFailMsg msg = modFailMsg (const msg)
prefixFailMsg :: MonadCatch m => String -> m a -> m a
prefixFailMsg msg = modFailMsg (msg ++)
withPatFailMsg :: MonadCatch m => String -> m a -> m a
withPatFailMsg msg = modFailMsg (\ e -> if "Pattern match failure" `isPrefixOf` e then msg else e)
guardMsg :: Monad m => Bool -> String -> m ()
guardMsg b msg = unless b (fail msg)
guardM :: Monad m => Bool -> m ()
guardM b = guardMsg b "guardM failed"
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM mb m1 m2 = do b <- mb
if b then m1 else m2
whenM :: Monad m => m Bool -> m a -> m a
whenM mb ma = ifM mb ma (fail "whenM: condition False")
unlessM :: Monad m => m Bool -> m a -> m a
unlessM mb ma = ifM mb (fail "unlessM: condition True") ma
class Category arr => CategoryCatch arr where
failT :: String -> arr a b
catchT :: arr a b -> (String -> arr a b) -> arr a b
(<+) :: CategoryCatch arr => arr a b -> arr a b -> arr a b
f <+ g = f `catchT` \ _ -> g
readerT :: ArrowApply arr => (a -> arr a b) -> arr a b
readerT f = (f &&& id) ^>> app
acceptR :: (CategoryCatch arr, ArrowApply arr) => (a -> Bool) -> String -> arr a a
acceptR p msg = readerT $ \ a -> if p a then id else failT msg
accepterR :: (CategoryCatch arr, ArrowApply arr) => arr a Bool -> String -> arr a a
accepterR t msg = forkFirst t >>> readerT (\ (b,a) -> if b then constant a else failT msg)
tryR :: CategoryCatch arr => arr a a -> arr a a
tryR r = r <+ id
attemptR :: (CategoryCatch arr, Arrow arr) => arr a a -> arr a (Bool,a)
attemptR r = (r >>^ (True,)) <+ arr (False,)
changedR :: (CategoryCatch arr, ArrowApply arr, Eq a) => arr a a -> arr a a
changedR r = readerT (\ a -> r >>> acceptR (/=a) "changedR: value is unchanged")
repeatR :: CategoryCatch arr => arr a a -> arr a a
repeatR r = r >>> tryR (repeatR r)
(>+>) :: (CategoryCatch arr, ArrowApply arr) => arr a a -> arr a a -> arr a a
r1 >+> r2 = attemptR r1 >>> readerT (\ (b,_) -> snd ^>> if b then tryR r2 else r2)
orR :: (Foldable f, CategoryCatch arr, ArrowApply arr) => f (arr a a) -> arr a a
orR = foldr (>+>) (failT "orR failed")
andR :: (Foldable f, Category arr) => f (arr a a) -> arr a a
andR = foldr (>>>) id
catchesT :: (Foldable f, CategoryCatch arr) => f (arr a b) -> arr a b
catchesT = foldr (<+) (failT "catchesT failed")
result :: Arrow arr => (b -> c) -> arr a b -> arr a c
result f a = a >>^ f
argument :: Arrow arr => (a -> b) -> arr b c -> arr a c
argument f a = f ^>> a
toFst :: Arrow arr => arr a b -> arr (a,x) b
toFst f = fst ^>> f
toSnd :: Arrow arr => arr a b -> arr (x,a) b
toSnd f = snd ^>> f
swap :: Arrow arr => arr (a,b) (b,a)
swap = arr (\(a,b) -> (b,a))
fork :: Arrow arr => arr a (a,a)
fork = arr (\a -> (a,a))
forkFirst :: Arrow arr => arr a b -> arr a (b,a)
forkFirst sf = fork >>> first sf
forkSecond :: Arrow arr => arr a b -> arr a (a,b)
forkSecond sf = fork >>> second sf
constant :: Arrow arr => b -> arr a b
constant b = arr (const b)