{-# LANGUAGE DeriveAnyClass #-}

-- | A grab bag of fun stuff.
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)

-- | Often 'f' is primary, not 't'. Relate them with this constraint.
type Whole t f = (f ~ Base t)

-- | Constraint for recursive structures
type RecursiveWhole t f = (Recursive t, Whole t f)

-- | Traverses a recursive structure
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

-- | A nicely-named 'Bool' for tracking state changes
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
(<>)

-- | Embeds a function that may fail in a stateful context
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)

-- | Embeds a function that may fail in a stateful context
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

-- | Embeds a function that may fail in a stateful context with change tracking
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

-- -- | Embeds a stateful action in a larger context
-- stateLens :: Lens' s a -> State a b -> State s b
-- stateLens l act = state $ \s ->
--   let (b, a') = runState act (view l s)
--       s' = set l a' s
--   in (b, s')

-- | 'foldM' specialized and flipped.
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 #-}