{-# LANGUAGE DeriveAnyClass #-}
module Overeasy.Util
( Whole
, RecursiveWhole
, foldWholeM
, Changed (..)
, stateFail
, stateOption
, stateFailChanged
, stateFold
) where
import Control.DeepSeq (NFData)
import Control.Monad (foldM, forM_)
import Control.Monad.State.Strict (State, get, put)
import Data.Functor.Foldable (Base, Recursive (..))
import Data.Hashable (Hashable)
import GHC.Generics (Generic)
type Whole t f = (f ~ Base t)
type RecursiveWhole t f = (Recursive t, Whole t f)
foldWholeM :: (RecursiveWhole t f, Traversable f, Monad m) => (f a -> m a) -> t -> m a
foldWholeM :: forall t (f :: * -> *) (m :: * -> *) a.
(RecursiveWhole t f, Traversable f, Monad m) =>
(f a -> m a) -> t -> m a
foldWholeM f a -> m a
h = t -> m a
go where
go :: t -> m a
go t
t = do
let ft :: Base t t
ft = forall t. Recursive t => t -> Base t t
project t
t
f a
fa <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse t -> m a
go Base t t
ft
f a -> m a
h f a
fa
data Changed = ChangedNo | ChangedYes
deriving stock (Changed -> Changed -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Changed -> Changed -> Bool
$c/= :: Changed -> Changed -> Bool
== :: Changed -> Changed -> Bool
$c== :: Changed -> Changed -> Bool
Eq, Eq Changed
Changed -> Changed -> Bool
Changed -> Changed -> Ordering
Changed -> Changed -> Changed
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Changed -> Changed -> Changed
$cmin :: Changed -> Changed -> Changed
max :: Changed -> Changed -> Changed
$cmax :: Changed -> Changed -> Changed
>= :: Changed -> Changed -> Bool
$c>= :: Changed -> Changed -> Bool
> :: Changed -> Changed -> Bool
$c> :: Changed -> Changed -> Bool
<= :: Changed -> Changed -> Bool
$c<= :: Changed -> Changed -> Bool
< :: Changed -> Changed -> Bool
$c< :: Changed -> Changed -> Bool
compare :: Changed -> Changed -> Ordering
$ccompare :: Changed -> Changed -> Ordering
Ord, Int -> Changed -> ShowS
[Changed] -> ShowS
Changed -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Changed] -> ShowS
$cshowList :: [Changed] -> ShowS
show :: Changed -> String
$cshow :: Changed -> String
showsPrec :: Int -> Changed -> ShowS
$cshowsPrec :: Int -> Changed -> ShowS
Show, forall x. Rep Changed x -> Changed
forall x. Changed -> Rep Changed x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Changed x -> Changed
$cfrom :: forall x. Changed -> Rep Changed x
Generic)
deriving anyclass (Eq Changed
Int -> Changed -> Int
Changed -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Changed -> Int
$chash :: Changed -> Int
hashWithSalt :: Int -> Changed -> Int
$chashWithSalt :: Int -> Changed -> Int
Hashable, Changed -> ()
forall a. (a -> ()) -> NFData a
rnf :: Changed -> ()
$crnf :: Changed -> ()
NFData)
instance Semigroup Changed where
Changed
c1 <> :: Changed -> Changed -> Changed
<> Changed
c2 =
case Changed
c1 of
Changed
ChangedYes -> Changed
ChangedYes
Changed
_ -> Changed
c2
instance Monoid Changed where
mempty :: Changed
mempty = Changed
ChangedNo
mappend :: Changed -> Changed -> Changed
mappend = forall a. Semigroup a => a -> a -> a
(<>)
stateFail :: (s -> Maybe (b, s)) -> State s (Maybe b)
stateFail :: forall s b. (s -> Maybe (b, s)) -> State s (Maybe b)
stateFail s -> Maybe (b, s)
f = do
s
s <- forall s (m :: * -> *). MonadState s m => m s
get
case s -> Maybe (b, s)
f s
s of
Maybe (b, s)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Just (b
b, s
s') -> forall s (m :: * -> *). MonadState s m => s -> m ()
put s
s' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just b
b)
stateOption :: (s -> (b, Maybe s)) -> State s b
stateOption :: forall s b. (s -> (b, Maybe s)) -> State s b
stateOption s -> (b, Maybe s)
f = do
s
s <- forall s (m :: * -> *). MonadState s m => m s
get
let (b
b, Maybe s
ms) = s -> (b, Maybe s)
f s
s
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe s
ms forall s (m :: * -> *). MonadState s m => s -> m ()
put
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
stateFailChanged :: (s -> Maybe s) -> State s Changed
stateFailChanged :: forall s. (s -> Maybe s) -> State s Changed
stateFailChanged s -> Maybe s
f = do
s
s <- forall s (m :: * -> *). MonadState s m => m s
get
case s -> Maybe s
f s
s of
Maybe s
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Changed
ChangedNo
Just s
s' -> forall s (m :: * -> *). MonadState s m => s -> m ()
put s
s' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Changed
ChangedYes
stateFold :: Foldable t => b -> t a -> (b -> a -> State s b) -> State s b
stateFold :: forall (t :: * -> *) b a s.
Foldable t =>
b -> t a -> (b -> a -> State s b) -> State s b
stateFold b
b t a
as b -> a -> State s b
f = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM b -> a -> State s b
f b
b t a
as
{-# INLINE stateFold #-}