module Barbies.Internal.Writer
  ( Wr
  , execWr
  , tell
  ) where

-- ---------------------------------------------------------------------
-- We roll our own State/efficient-Writer monad, not to add dependencies
-- ---------------------------------------------------------------------

newtype St s a
  = St (s -> (a, s))

runSt :: s -> St s a -> (a, s)
runSt :: s -> St s a -> (a, s)
runSt s
s (St s -> (a, s)
f)
  = s -> (a, s)
f s
s

instance Functor (St s) where
  fmap :: (a -> b) -> St s a -> St s b
fmap a -> b
f (St s -> (a, s)
g)
    = (s -> (b, s)) -> St s b
forall s a. (s -> (a, s)) -> St s a
St ((s -> (b, s)) -> St s b) -> (s -> (b, s)) -> St s b
forall a b. (a -> b) -> a -> b
$ (\(a
a, s
s') -> (a -> b
f a
a, s
s')) ((a, s) -> (b, s)) -> (s -> (a, s)) -> s -> (b, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> (a, s)
g
  {-# INLINE fmap #-}

instance Applicative (St s) where
  pure :: a -> St s a
pure
    = (s -> (a, s)) -> St s a
forall s a. (s -> (a, s)) -> St s a
St ((s -> (a, s)) -> St s a) -> (a -> s -> (a, s)) -> a -> St s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,)
  {-# INLINE pure #-}

  St s -> (a -> b, s)
l <*> :: St s (a -> b) -> St s a -> St s b
<*> St s -> (a, s)
r
    = (s -> (b, s)) -> St s b
forall s a. (s -> (a, s)) -> St s a
St ((s -> (b, s)) -> St s b) -> (s -> (b, s)) -> St s b
forall a b. (a -> b) -> a -> b
$ \s
s ->
        let (a -> b
f, s
s')  = s -> (a -> b, s)
l s
s
            (a
x, s
s'') = s -> (a, s)
r s
s'
        in (a -> b
f a
x, s
s'')
  {-# INLINE (<*>) #-}

instance Monad (St s) where
  return :: a -> St s a
return = a -> St s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE return #-}

  St s -> (a, s)
action >>= :: St s a -> (a -> St s b) -> St s b
>>= a -> St s b
f
    = (s -> (b, s)) -> St s b
forall s a. (s -> (a, s)) -> St s a
St ((s -> (b, s)) -> St s b) -> (s -> (b, s)) -> St s b
forall a b. (a -> b) -> a -> b
$ \s
s ->
        let
          (a
a, s
s') = s -> (a, s)
action s
s
          St s -> (b, s)
go  = a -> St s b
f a
a
        in
          s -> (b, s)
go s
s'
  {-# INLINE (>>=) #-}

type Wr = St

execWr :: Monoid w => Wr w a -> w
execWr :: Wr w a -> w
execWr
  = (a, w) -> w
forall a b. (a, b) -> b
snd ((a, w) -> w) -> (Wr w a -> (a, w)) -> Wr w a -> w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Wr w a -> (a, w)
forall s a. s -> St s a -> (a, s)
runSt w
forall a. Monoid a => a
mempty

tell :: Monoid w => w -> Wr w ()
tell :: w -> Wr w ()
tell w
w
  = (w -> ((), w)) -> Wr w ()
forall s a. (s -> (a, s)) -> St s a
St (\w
s -> ((), w -> w -> w
seq w
s w
s w -> w -> w
forall a. Monoid a => a -> a -> a
`mappend` w
w))