{-# LANGUAGE RankNTypes #-}
module Data.TMS.Helpers where
import Control.Monad.State
import Control.Monad.ST.Trans
import Control.Monad.Except
import Control.Monad.Extra
import Data.List
anyByM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
anyByM :: (a -> m Bool) -> [a] -> m Bool
anyByM a -> m Bool
_ [] = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
anyByM a -> m Bool
k (a
x : [a]
xs) = do
Bool
b <- a -> m Bool
k a
x
if Bool
b then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else (a -> m Bool) -> [a] -> m Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyByM a -> m Bool
k [a]
xs
anyMM :: (Monad m) => (a -> m Bool) -> m [a] -> m Bool
anyMM :: (a -> m Bool) -> m [a] -> m Bool
anyMM a -> m Bool
predM m [a]
srcM = do
[a]
src <- m [a]
srcM
(a -> m Bool) -> [a] -> m Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyByM a -> m Bool
predM [a]
src
allByM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
allByM :: (a -> m Bool) -> [a] -> m Bool
allByM a -> m Bool
_ [] = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
allByM a -> m Bool
k (a
x : [a]
xs) = do
Bool
b <- a -> m Bool
k a
x
if Bool
b then (a -> m Bool) -> [a] -> m Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allByM a -> m Bool
k [a]
xs else Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
ordSubsetp :: Ord a => [a] -> [a] -> Bool
ordSubsetp :: [a] -> [a] -> Bool
ordSubsetp [] [a]
_ = Bool
True
ordSubsetp (a
_ : [a]
_) [] = Bool
False
ordSubsetp l1 :: [a]
l1@(a
n1 : [a]
ns1) l2 :: [a]
l2@(a
n2 : [a]
ns2) =
case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
n1 a
n2 of
Ordering
LT -> Bool
False
Ordering
EQ -> [a] -> [a] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
ordSubsetp [a]
ns1 [a]
ns2
Ordering
GT -> [a] -> [a] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
ordSubsetp [a]
l1 [a]
ns2
formatList :: Monad m => String -> (a -> m String) -> [a] -> m String
formatList :: String -> (a -> m String) -> [a] -> m String
formatList String
s a -> m String
f [a]
xs = (a -> m String) -> [a] -> m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m String
f [a]
xs m [String] -> ([String] -> m String) -> m String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String)
-> ([String] -> String) -> [String] -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
s
forMM_ :: (Monad m, Foldable t) => m (t a) -> (a -> m ()) -> m ()
forMM_ :: m (t a) -> (a -> m ()) -> m ()
forMM_ m (t a)
srcM a -> m ()
f = do
t a
src <- m (t a)
srcM
t a -> (a -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t a
src a -> m ()
f
whileDo :: Monad m => m Bool -> m () -> m ()
whileDo :: m Bool -> m () -> m ()
whileDo m Bool
cond m ()
body =
m Bool
cond m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b then m ()
body m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whileDo m Bool
cond m ()
body else () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
whileDoWith :: Monad m => m a -> (a -> Bool) -> (a -> m ()) -> m ()
whileDoWith :: m a -> (a -> Bool) -> (a -> m ()) -> m ()
whileDoWith m a
src a -> Bool
predicate a -> m ()
body = do
a
val <- m a
src
if a -> Bool
predicate a
val then (do a -> m ()
body a
val
m a -> (a -> Bool) -> (a -> m ()) -> m ()
forall (m :: * -> *) a.
Monad m =>
m a -> (a -> Bool) -> (a -> m ()) -> m ()
whileDoWith m a
src a -> Bool
predicate a -> m ()
body)
else () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
forMwhile_ :: Monad m => [a] -> m Bool -> (a -> m ()) -> m ()
forMwhile_ :: [a] -> m Bool -> (a -> m ()) -> m ()
forMwhile_ [] m Bool
_ a -> m ()
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
forMwhile_ (a
x : [a]
xs) m Bool
pred a -> m ()
bodyf = do
m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
pred (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
a -> m ()
bodyf a
x
[a] -> m Bool -> (a -> m ()) -> m ()
forall (m :: * -> *) a.
Monad m =>
[a] -> m Bool -> (a -> m ()) -> m ()
forMwhile_ [a]
xs m Bool
pred a -> m ()
bodyf
forMMwhile_ :: Monad m => m [a] -> m Bool -> (a -> m ()) -> m ()
forMMwhile_ :: m [a] -> m Bool -> (a -> m ()) -> m ()
forMMwhile_ m [a]
xsM m Bool
condM a -> m ()
bodyf = do
[a]
xs <- m [a]
xsM
[a] -> m Bool -> (a -> m ()) -> m ()
forall (m :: * -> *) a.
Monad m =>
[a] -> m Bool -> (a -> m ()) -> m ()
forMwhile_ [a]
xs m Bool
condM a -> m ()
bodyf
whileReturnJust :: Monad m => m (Maybe a) -> (a -> m ()) -> m ()
whileReturnJust :: m (Maybe a) -> (a -> m ()) -> m ()
whileReturnJust m (Maybe a)
gen a -> m ()
f = do
Maybe a
res <- m (Maybe a)
gen
case Maybe a
res of
Maybe a
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just a
x -> do
a -> m ()
f a
x
m (Maybe a) -> (a -> m ()) -> m ()
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whileReturnJust m (Maybe a)
gen a -> m ()
f
unlessMM :: Monad m => m Bool -> m () -> m ()
unlessMM :: m Bool -> m () -> m ()
unlessMM m Bool
cnd m ()
body = m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (m Bool -> m Bool
forall (m :: * -> *). Functor m => m Bool -> m Bool
notM m Bool
cnd) m ()
body
nullR :: Monad m => STRef s [a] -> STT s m Bool
nullR :: STRef s [a] -> STT s m Bool
nullR STRef s [a]
ref = do
[a]
xs <- STRef s [a] -> STT s m [a]
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s [a]
ref
Bool -> STT s m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> STT s m Bool) -> Bool -> STT s m Bool
forall a b. (a -> b) -> a -> b
$ [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs
nonnullR :: Monad m => STRef s [a] -> STT s m Bool
nonnullR :: STRef s [a] -> STT s m Bool
nonnullR STRef s [a]
ref = do
[a]
xs <- STRef s [a] -> STT s m [a]
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s [a]
ref
Bool -> STT s m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> STT s m Bool) -> Bool -> STT s m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs
whenNonnullR :: (Monad m0, Monad m) =>
(forall r . STT s m0 r -> m r) -> STRef s [a] -> ([a] -> m ()) -> m ()
whenNonnullR :: (forall r. STT s m0 r -> m r)
-> STRef s [a] -> ([a] -> m ()) -> m ()
whenNonnullR forall r. STT s m0 r -> m r
lifter STRef s [a]
ref [a] -> m ()
bodyf = do
[a]
xs <- STT s m0 [a] -> m [a]
forall r. STT s m0 r -> m r
lifter (STT s m0 [a] -> m [a]) -> STT s m0 [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ STRef s [a] -> STT s m0 [a]
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s [a]
ref
if ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs) then () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else [a] -> m ()
bodyf [a]
xs
mapRefs :: Monad m => (a -> b) -> [STRef s a] -> STT s m [b]
mapRefs :: (a -> b) -> [STRef s a] -> STT s m [b]
mapRefs a -> b
f [] = [b] -> STT s m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return []
mapRefs a -> b
f (STRef s a
xr : [STRef s a]
xrs) = do
a
x <- STRef s a -> STT s m a
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s a
xr
[b]
xs' <- (a -> b) -> [STRef s a] -> STT s m [b]
forall (m :: * -> *) a b s.
Monad m =>
(a -> b) -> [STRef s a] -> STT s m [b]
mapRefs a -> b
f [STRef s a]
xrs
[b] -> STT s m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return ([b] -> STT s m [b]) -> [b] -> STT s m [b]
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
xs'
foldrRefs :: Monad m => (a -> b -> b) -> b -> [STRef s a] -> STT s m b
foldrRefs :: (a -> b -> b) -> b -> [STRef s a] -> STT s m b
foldrRefs a -> b -> b
f b
z [] = b -> STT s m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
z
foldrRefs a -> b -> b
f b
z (STRef s a
xr : [STRef s a]
xrs) = do
a
x <- STRef s a -> STT s m a
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s a
xr
b
z' <- (a -> b -> b) -> b -> [STRef s a] -> STT s m b
forall (m :: * -> *) a b s.
Monad m =>
(a -> b -> b) -> b -> [STRef s a] -> STT s m b
foldrRefs a -> b -> b
f b
z [STRef s a]
xrs
b -> STT s m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> STT s m b) -> b -> STT s m b
forall a b. (a -> b) -> a -> b
$ a -> b -> b
f a
x b
z'
foldlRefs :: Monad m => (b -> a -> b) -> b -> [STRef s a] -> STT s m b
foldlRefs :: (b -> a -> b) -> b -> [STRef s a] -> STT s m b
foldlRefs b -> a -> b
f b
z [] = b -> STT s m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
z
foldlRefs b -> a -> b
f b
z (STRef s a
xr : [STRef s a]
xrs) = do
a
x <- STRef s a -> STT s m a
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s a
xr
(b -> a -> b) -> b -> [STRef s a] -> STT s m b
forall (m :: * -> *) b a s.
Monad m =>
(b -> a -> b) -> b -> [STRef s a] -> STT s m b
foldlRefs b -> a -> b
f (b -> a -> b
f b
z a
x) [STRef s a]
xrs
forRM_ ::
(Monad m, Monad m0, Foldable t) =>
(STT s m0 (t a) -> m (t a)) ->
STRef s (t a) -> (a -> m ()) -> m ()
forRM_ :: (STT s m0 (t a) -> m (t a)) -> STRef s (t a) -> (a -> m ()) -> m ()
forRM_ STT s m0 (t a) -> m (t a)
liftSTT STRef s (t a)
srcR a -> m ()
f = do
t a
src <- STT s m0 (t a) -> m (t a)
liftSTT (STT s m0 (t a) -> m (t a)) -> STT s m0 (t a) -> m (t a)
forall a b. (a -> b) -> a -> b
$ STRef s (t a) -> STT s m0 (t a)
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s (t a)
srcR
t a -> (a -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t a
src a -> m ()
f
push :: Monad m => a -> STRef s [a] -> STT s m ()
push :: a -> STRef s [a] -> STT s m ()
push a
v STRef s [a]
r = do
[a]
prev <- STRef s [a] -> STT s m [a]
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s [a]
r
STRef s [a] -> [a] -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s [a]
r ([a] -> STT s m ()) -> [a] -> STT s m ()
forall a b. (a -> b) -> a -> b
$ a
v a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
prev
pushM :: Monad m => m a -> STRef s [a] -> STT s m ()
pushM :: m a -> STRef s [a] -> STT s m ()
pushM m a
m STRef s [a]
r = do
a
v <- m a -> STT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
m
a -> STRef s [a] -> STT s m ()
forall (m :: * -> *) a s. Monad m => a -> STRef s [a] -> STT s m ()
push a
v STRef s [a]
r
pushAll :: (Monad m, Traversable t) => t a -> STRef s [a] -> STT s m ()
pushAll :: t a -> STRef s [a] -> STT s m ()
pushAll t a
vs STRef s [a]
r = t a -> (a -> STT s m ()) -> STT s m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t a
vs ((a -> STT s m ()) -> STT s m ())
-> (a -> STT s m ()) -> STT s m ()
forall a b. (a -> b) -> a -> b
$ \a
v -> a -> STRef s [a] -> STT s m ()
forall (m :: * -> *) a s. Monad m => a -> STRef s [a] -> STT s m ()
push a
v STRef s [a]
r
pushAllM :: (Monad m, Traversable t) => m (t a) -> STRef s [a] -> STT s m ()
pushAllM :: m (t a) -> STRef s [a] -> STT s m ()
pushAllM m (t a)
m STRef s [a]
r = do
t a
vs <- m (t a) -> STT s m (t a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (t a)
m
t a -> STRef s [a] -> STT s m ()
forall (m :: * -> *) (t :: * -> *) a s.
(Monad m, Traversable t) =>
t a -> STRef s [a] -> STT s m ()
pushAll t a
vs STRef s [a]
r
pop :: Monad m => STRef s [a] -> STT s m (Maybe a)
pop :: STRef s [a] -> STT s m (Maybe a)
pop STRef s [a]
queue = do
[a]
queueList <- STRef s [a] -> STT s m [a]
forall (m :: * -> *) s a. Applicative m => STRef s a -> STT s m a
readSTRef STRef s [a]
queue
case [a]
queueList of
[] -> Maybe a -> STT s m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
(a
x : [a]
xs) -> do
STRef s [a] -> [a] -> STT s m ()
forall (m :: * -> *) s a.
Applicative m =>
STRef s a -> a -> STT s m ()
writeSTRef STRef s [a]
queue [a]
xs
Maybe a -> STT s m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> STT s m (Maybe a)) -> Maybe a -> STT s m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
whileListM_ :: (Monad m0, Monad m) =>
(forall r . STT s m0 r -> m r) -> STRef s [a] -> (a -> m ()) -> m ()
whileListM_ :: (forall r. STT s m0 r -> m r) -> STRef s [a] -> (a -> m ()) -> m ()
whileListM_ forall r. STT s m0 r -> m r
lifter STRef s [a]
listRef a -> m ()
bodyf = m ()
whileListM_'
where whileListM_' :: m ()
whileListM_' = do
Maybe a
top <- STT s m0 (Maybe a) -> m (Maybe a)
forall r. STT s m0 r -> m r
lifter (STT s m0 (Maybe a) -> m (Maybe a))
-> STT s m0 (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ STRef s [a] -> STT s m0 (Maybe a)
forall (m :: * -> *) s a.
Monad m =>
STRef s [a] -> STT s m (Maybe a)
pop STRef s [a]
listRef
case Maybe a
top of
Maybe a
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just a
x -> do
a -> m ()
bodyf a
x
m ()
whileListM_'
commaList :: (a -> String) -> [a] -> String
commaList :: (a -> String) -> [a] -> String
commaList a -> String
f [] = String
""
commaList a -> String
f [a]
xs = (String -> String -> String) -> [String] -> String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\ String
x String
y -> String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y) ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
f [a]
xs
unmaybe :: [Maybe a] -> [a]
unmaybe [] = []
unmaybe (Just a
a : [Maybe a]
xs) = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [Maybe a] -> [a]
unmaybe [Maybe a]
xs
unmaybe (Maybe a
_ : [Maybe a]
xs) = [Maybe a] -> [a]
unmaybe [Maybe a]
xs