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 :: forall s a. 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 :: forall a b. (a -> b) -> St s a -> St s b
fmap a -> b
f (St s -> (a, s)
g)
    = forall s a. (s -> (a, s)) -> St s a
St forall a b. (a -> b) -> a -> b
$ (\(a
a, s
s') -> (a -> b
f a
a, s
s')) forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> (a, s)
g
  {-# INLINE fmap #-}

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

  St s -> (a -> b, s)
l <*> :: forall a b. St s (a -> b) -> St s a -> St s b
<*> St s -> (a, s)
r
    = forall s a. (s -> (a, s)) -> St s a
St 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 :: forall a. a -> St s a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE return #-}

  St s -> (a, s)
action >>= :: forall a b. St s a -> (a -> St s b) -> St s b
>>= a -> St s b
f
    = forall s a. (s -> (a, s)) -> St s a
St 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 :: forall w a. Monoid w => Wr w a -> w
execWr
  = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. s -> St s a -> (a, s)
runSt forall a. Monoid a => a
mempty

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