{-# LANGUAGE TupleSections #-}

-- |
-- Module      : Control.Auto.Effects
-- Description : Accessing, executing, and manipulating underyling monadic
--               effects.
-- Copyright   : (c) Justin Le 2015
-- License     : MIT
-- Maintainer  : justin@jle.im
-- Stability   : unstable
-- Portability : portable
--
-- This module exports the preferred ways of interacting with the
-- underlying 'Monad' of the 'Auto' type, including accessing, executing,
-- and manipulating such effects.
--

module Control.Auto.Effects (
  -- * Running effects
  -- ** Continually
    arrM
  , effect
  -- ** From inputs
  , effects
  -- ** On 'Blip's
  , arrMB
  , effectB
  , execB
  -- * One-time effects
  , cache
  , execOnce
  , cache_
  , execOnce_
  -- * Manipulating underlying monads
  -- ** "Sealing off" monadic 'Auto's
  , sealState
  , sealState_
  , sealReader
  , sealReader_
  -- ** "Unrolling"/"reifying" monadic 'Auto's
  , runStateA
  , runReaderA
  , runWriterA
  , runTraversableA
  -- ** Hoists
  , hoistA
  , generalizeA
  -- ** Working with IO
  , catchA
  -- ** Constructing monadic 'Auto's from other monads
  , fromState
  , fromState_
  ) where

import Control.Applicative
import Control.Auto.Blip
import Control.Exception
import Control.Auto.Core
import Control.Monad.Trans.Writer (WriterT, runWriterT)
import Control.Auto.Generate
import Control.Category
import Control.Monad hiding       (mapM, mapM_)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Data.Monoid
import Control.Monad.Trans.State  (StateT, runStateT)
import Data.Foldable
import Data.Serialize
import Data.Traversable
import Prelude hiding             ((.), id, mapM, mapM_)

-- | The very first output executes a monadic action and uses the result as
-- the output, ignoring all input.  From then on, it persistently outputs
-- that first result.
--
-- Like 'execOnce', except outputs the result of the action instead of
-- ignoring it.
--
-- Useful for loading resources in IO on the "first step", like
-- a word list:
--
-- @
-- dictionary :: Auto IO a [String]
-- dictionary = cache (lines <$> readFile "wordlist.txt")
-- @
--
cache :: (Serialize b, Monad m)
      => m b          -- ^ monadic action to execute and use the result of
      -> Auto m a b
cache m = snd <$> iteratorM (_cacheF m) (False, undefined)

-- | The non-resumable/non-serializable version of 'cache'.  Every time the
-- 'Auto' is deserialized/reloaded, it re-executes the action to retrieve
-- the result again.
--
-- Useful in cases where you want to "re-load" an expensive resource on
-- every startup, instead of saving it to in the save states.
--
-- @
-- dictionary :: Auto IO a [String]
-- dictionary = cache_ (lines <$> readFile "dictionary.txt")
-- @
cache_ :: Monad m
       => m b         -- ^ monadic action to execute and use the result of
       -> Auto m a b
cache_ m = snd <$> iteratorM_ (_cacheF m) (False, undefined)

_cacheF :: Monad m => m b -> (Bool, b) -> m (Bool, b)
_cacheF m (False, _) = liftM  (True,) m
_cacheF _ (True , x) = return (True, x)
{-# INLINE _cacheF #-}

-- | Always outputs '()', but when asked for the first output, executes the
-- given monadic action.
--
-- Pretty much like 'cache', but always outputs '()'.
--
execOnce :: Monad m
         => m b           -- ^ monadic action to execute; result discared
         -> Auto m a ()
execOnce m = mkStateM (\_ -> _execOnceF m) False

-- | The non-resumable/non-serializable version of 'execOnce'.  Every time
-- the 'Auto' is deserialized/reloaded, the action is re-executed again.
execOnce_ :: Monad m
          => m b          -- ^ monadic action to execute; result discared
          -> Auto m a ()
execOnce_ m = mkStateM_ (\_ -> _execOnceF m) False

_execOnceF :: Monad m => m a -> Bool -> m ((), Bool)
_execOnceF m = go
  where
    go False = liftM (const ((), True)) m
    go _     = return ((), True)

-- | The input stream is a stream of monadic actions, and the output stream
-- is the result of their executions, through executing them.
effects :: Monad m => Auto m (m a) a
effects = arrM id

-- | Applies the given "monadic function" (function returning a monadic
-- action) to every incoming item; the result is the result of executing
-- the action returned.
--
-- Note that this essentially lifts a "Kleisli arrow"; it's like 'arr', but
-- for "monadic functions" instead of normal functions:
--
-- @
-- arr  :: (a -> b)   -> Auto m a b
-- arrM :: (a -> m b) -> Auto m a b
-- @
--
-- prop> arrM f . arrM g == arrM (f <=< g)
--
-- One neat trick you can do is that you can "tag on effects" to a normal
-- 'Auto' by using '*>' from "Control.Applicative".  For example:
--
-- >>> let a = arrM print *> sumFrom 0
-- >>> ys <- streamAuto a [1..5]
-- 1                -- IO output
-- 2
-- 3
-- 4
-- 5
-- >>> ys
-- [1,3,6,10,15]    -- the result
--
-- Here, @a@ behaves "just like" @'sumFrom' 0@...except, when you step it,
-- it prints out to stdout as a side-effect.  We just gave automatic
-- stdout logging behavior!
--
arrM :: (a -> m b)    -- ^ monadic function
     -> Auto m a b
arrM = mkFuncM
{-# INLINE arrM #-}

-- | Maps one blip stream to another; replaces every emitted value with the
-- result of the monadic function, executing it to get the result.
arrMB :: Monad m
      => (a -> m b)
      -> Auto m (Blip a) (Blip b)
arrMB = perBlip . arrM
{-# INLINE arrMB #-}

-- | Maps one blip stream to another; replaces every emitted value with the
-- result of a fixed monadic action, run every time an emitted value is
-- received.
effectB :: Monad m
        => m b
        -> Auto m (Blip a) (Blip b)
effectB = perBlip . effect
{-# INLINE effectB #-}

-- | Outputs the identical blip stream that is received; however, every
-- time it sees an emitted value, executes the given monadic action on the
-- side.
execB :: Monad m
      => m b
      -> Auto m (Blip a) (Blip a)
execB mx = perBlip (arrM $ \x -> mx >> return x)
{-# INLINE execB #-}

-- | Takes an 'Auto' that works with underlying global, mutable state, and
-- "seals off the state" from the outside world.
--
-- An 'Auto (StateT s m) a b' maps a stream of 'a' to a stream of 'b', but
-- does so in the context of requiring an initial 's' to start, and
-- outputting a modified 's'.
--
-- Consider this example 'State' 'Auto':
--
-- @
-- foo :: Auto (State s) Int Int
-- foo = proc x -> do
--     execB (modify (+1)) . emitOn odd  -< x
--     execB (modify (*2)) . emitOn even -< x
--     st   <- effect get -< ()
--     sumX <- sumFrom 0  -< x
--     id    -< sumX + st
-- @
--
-- On every output, the "global" state is incremented if the input is odd
-- and doubled if the input is even.  The stream @st@ is always the value
-- of the global state at that point.  @sumX@ is the cumulative sum of the
-- inputs.  The final result is the sum of the value of the global state
-- and the cumulative sum.
--
-- In writing like this, you lose some of the denotative properties because
-- you are working with a global state that updates at every output.  You
-- have some benefit of now being able to work with global state, if that's
-- what you wanted I guess.
--
-- To "run" it, you could use 'streamAuto' to get a @'State' Int Int@:
--
-- >>> let st = streamAuto foo [1..10] :: State Int Int
-- >>> runState st 5
-- ([  7, 15, 19, 36, 42, 75, 83,136,156,277], 222)
--
-- (The starting state is 5 and the ending state after all of that is 222)
--
-- However, writing your entire program with global state is a bad bad
-- idea!  So, how can you get the "benefits" of having small parts like
-- @foo@ be written using 'State', and being able to use it in a program
-- with no global state?
--
-- Using 'sealState'!  Write the part of your program that would like
-- shared global state with 'State'...and compose it with the rest as if it
-- doesn't, locking it away!
--
-- @
-- sealState       :: Auto (State s) a b -> s -> Auto' a b
-- sealState foo 5 :: Auto' Int Int
-- @
--
-- @
-- bar :: Auto' Int (Int, String)
-- bar = proc x -> do
--     food <- sealState foo 5 -< x
--     id -< (food, show x)
-- @
--
-- >>> streamAuto' bar [1..10]
-- [ (7, "1"), (15, "2"), (19, "3"), (36, "4"), (42, "5"), (75, "6") ...
--
-- We say that @'sealState' f s0@ takes an input stream, and the output
-- stream is the result of running the stream through @f@, first with an
-- initial state of @s0@, and afterwards with each next updated state.
--
sealState :: (Monad m, Serialize s)
          => Auto (StateT s m) a b    -- ^ 'Auto' run over 'State'
          -> s                        -- ^ initial state
          -> Auto m a b
sealState a s0 = mkAutoM (sealState <$> resumeAuto a <*> get)
                         (saveAuto a *> put s0)
                       $ \x -> do
                           ((y, a'), s1) <- runStateT (stepAuto a x) s0
                           return (y, sealState a' s1)

-- | The non-resuming/non-serializing version of 'sealState'.
sealState_ :: Monad m
           => Auto (StateT s m) a b   -- ^ 'Auto' run over 'State'
           -> s                       -- ^ initial state
           -> Auto m a b
sealState_ a s0 = mkAutoM (sealState_ <$> resumeAuto a <*> pure s0)
                          (saveAuto a)
                          $ \x -> do
                              ((y, a'), s1) <- runStateT (stepAuto a x) s0
                              return (y, sealState_ a' s1)

-- | Turns an @a -> 'StateT' s m b@ Kleisli arrow into an @'Auto' m a b@,
-- when given an initial state.  Will continually "run the function", using
-- the state returned from the last run.
fromState :: (Serialize s, Monad m)
          => (a -> StateT s m b)      -- ^ 'State' arrow
          -> s                        -- ^ initial state
          -> Auto m a b
fromState st = mkStateM (runStateT . st)

-- | Non-seralizing/non-resuming version of 'fromState'.  The state isn't
-- serialized/resumed, so every time the 'Auto' is resumed, it starts over
-- with the given initial state.
fromState_ :: Monad m
           => (a -> StateT s m b)     -- ^ 'State' arrow
           -> s                       -- ^ initial state
           -> Auto m a b
fromState_ st = mkStateM_ (runStateT . st)

-- | "Unrolls" the underlying @'WriterT' w m@ 'Monad', so that an 'Auto'
-- that takes in a stream of @a@ and outputs a stream of @b@ will now
-- output a stream @(b, w)@, where @w@ is the "new log" of the underlying
-- 'Writer' at every step.
--
-- @
-- foo :: Auto (Writer (Sum Int)) Int Int
-- foo = effect (tell 1) *> effect (tell 1) *> sumFrom 0
-- @
--
-- >>> let fooWriter = streamAuto foo
-- >>> runWriter $ fooWriter [1..10]
-- ([1,3,6,10,15,21,28,36,45,55], Sum 20)
--
-- @foo@ increments an underlying counter twice every time it is stepped;
-- its "result" is just the cumulative sum of the inputs.
--
-- When we "stream" it, we get a @[Int] -> 'Writer' (Sum Int)
-- [Int]@...which we can give an input list and 'runWriter' it, getting
-- a list of outputs and a "final accumulator state" of 10, for stepping it
-- ten times.
--
-- However, if we use 'runWriterA' before streaming it, we get:
--
-- >>> let fooW = runWriterA foo
-- >>> streamAuto' fooW [1..10]
-- [ (1 , Sum 2), (3 , Sum 2), (6 , Sum 2)
-- , (10, Sum 2), (15, Sum 2), (21, Sum 2), -- ...
--
-- Instead of accumulating it between steps, we get to "catch" the 'Writer'
-- output at every individual step.
--
-- We can write and compose our own 'Auto's under 'Writer', using the
-- convenience of a shared accumulator, and then "use them" with other
-- 'Auto's:
--
-- @
-- bar :: Auto' Int Int
-- bar = proc x -> do
--   (y, w) <- runWriterA foo -< x
--   blah <- blah -< w
-- @
--
-- And now you have access to the underlying accumulator of @foo@ to
-- access.  There, @w@ represents the continually updating accumulator
-- under @foo@, and will be different/growing at every "step".
--
runWriterA :: (Monad m, Monoid w)
           => Auto (WriterT w m) a b
           -> Auto m a (b, w)
runWriterA a = mkAutoM (runWriterA <$> resumeAuto a)
                       (saveAuto a)
                     $ \x -> do
                         ((y, a'), w) <- runWriterT (stepAuto a x)
                         return ((y, w), runWriterA a')

-- | Takes an 'Auto' that operates under the context of a read-only
-- environment, an environment value, and turns it into a normal 'Auto'
-- that always "sees" that value when it asks for one.
--
-- >>> let a   = effect ask :: Auto (Reader b) a b
-- >>> let rdr = streamAuto' a [1..5] :: Reader b [b]
-- >>> runReader rdr "hey"
-- ["hey", "hey", "hey", "hey", "hey"]
--
-- Useful if you wanted to use it inside/composed with an 'Auto' that does
-- not have a global environment:
--
-- @
-- bar :: Auto' Int String
-- bar = proc x -> do
--     hey <- sealReader (effect ask) "hey" -< ()
--     id -< hey ++ show x
-- @
--
-- >>> streamAuto' bar [1..5]
-- ["hey1", "hey2", "hey3", "hey4", "hey5"]
--
-- Note that this version serializes the given @r@ environment, so that
-- every time the 'Auto' is reloaded/resumed, it resumes with the
-- originally given @r@ environment, ignoring whatever @r@ is given to it
-- when trying to resume it.  If this is not the behavior you want, use
-- 'sealReader_'.
--
sealReader :: (Monad m, Serialize r)
           => Auto (ReaderT r m) a b    -- ^ 'Auto' run over 'Reader'
           -> r                         -- ^ the perpetual environment
           -> Auto m a b
sealReader a r = mkAutoM (sealReader <$> resumeAuto a <*> get)
                         (saveAuto a *> put r)
                       $ \x -> do
                           (y, a') <- runReaderT (stepAuto a x) r
                           return (y, sealReader a' r)

-- | The non-resuming/non-serializing version of 'sealReader'.  Does not
-- serialize/reload the @r@ environment, so that whenever you "resume" the
-- 'Auto', it uses the new @r@ given when you are trying to resume, instead
-- of loading the originally given one.
sealReader_ :: Monad m
            => Auto (ReaderT r m) a b   -- ^ 'Auto' run over 'Reader'
            -> r                        -- ^ the perpetual environment
            -> Auto m a b
sealReader_ a r = mkAutoM (sealReader_ <$> resumeAuto a <*> pure r)
                          (saveAuto a)
                        $ \x -> do
                            (y, a') <- runReaderT (stepAuto a x) r
                            return (y, sealReader_ a' r)

-- | "Unrolls" the underlying 'StateT' of an 'Auto' into an 'Auto' that
-- takes in an input state every turn (in addition to the normal input) and
-- outputs, along with the original result, the modified state.
--
-- So now you can use any @'StateT' s m@ as if it were an @m@.  Useful if
-- you want to compose and create some isolated 'Auto's with access to an
-- underlying state, but not your entire program.
--
-- Also just simply useful as a convenient way to use an 'Auto' over
-- 'State' with 'stepAuto' and friends.
--
-- When used with @'State' s@, it turns an @'Auto' ('State' s) a b@ into an
-- @'Auto'' (a, s) (b, s)@.
runStateA :: Monad m
          => Auto (StateT s m) a b      -- ^ 'Auto' run over a state transformer
          -> Auto m (a, s) (b, s)       -- ^ 'Auto' whose inputs and outputs are a start transformer
runStateA a = mkAutoM (runStateA <$> resumeAuto a)
                      (saveAuto a)
                    $ \(x, s) -> do
                        ((y, a'), s') <- runStateT (stepAuto a x) s
                        return ((y, s'), runStateA a')

-- | "Unrolls" the underlying 'ReaderT' of an 'Auto' into an 'Auto' that
-- takes in the input "environment" every turn in addition to the normal
-- input.
--
-- So you can use any @'ReaderT' r m@ as if it were an @m@.  Useful if you
-- want to compose and create some isolated 'Auto's with access to an
-- underlying environment, but not your entire program.
--
-- Also just simply useful as a convenient way to use an 'Auto' over
-- 'Reader' with 'stepAuto' and friends.
--
-- When used with @'Reader' r@, it turns an @'Auto' ('Reader' r) a b@ into
-- an @'Auto'' (a, r) b@.
runReaderA :: Monad m
           => Auto (ReaderT r m) a b    -- ^ 'Auto' run over global environment
           -> Auto m (a, r) b           -- ^ 'Auto' receiving environments
runReaderA a = mkAutoM (runReaderA <$> resumeAuto a)
                       (saveAuto a)
                     $ \(x, r) -> do
                         (y, a') <- runReaderT (stepAuto a x) r
                         return (y, runReaderA a')

-- | "Unrolls" the underlying 'Monad' of an 'Auto' if it happens to be
-- 'Traversable' ('[]', 'Maybe', etc.).
--
-- It can turn, for example, an @'Auto' [] a b@ into an @'Auto'' a [b]@; it
-- collects all of the results together.  Or an @'Auto' 'Maybe' a b@ into
-- an @'Auto'' a ('Maybe' b)@.
--
-- This might be useful if you want to make some sort of "underyling
-- inhibiting" 'Auto' where the entire computation might just end up being
-- 'Nothing' in the end.  With this, you can turn that
-- possibly-catastrophically-failing 'Auto' (with an underlying 'Monad' of
-- 'Maybe') into a normal 'Auto', and use it as a normal 'Auto' in
-- composition with other 'Auto's...returning 'Just' if your computation
-- succeeded.
runTraversableA :: (Monad f, Traversable f)
                => Auto f a b           -- ^ 'Auto' run over traversable structure
                -> Auto m a (f b)       -- ^ 'Auto' returning traversable structure
runTraversableA = go . return
  where
    go a = mkAuto (go <$> mapM resumeAuto a)
                  (mapM_ saveAuto a)
                  $ \x -> let o  = a >>= (`stepAuto` x)
                              y  = liftM fst o
                              a' = liftM snd o
                          in  (y, go a')

-- | Wraps a "try" over an underlying 'IO' monad; if the Auto encounters a
-- runtime exception while trying to "step" itself, it'll output a 'Left'
-- with the 'Exception'.  Otherwise, will output 'left'.
--
-- Note that you have to explicitly specify the type of the exceptions you
-- are catching; see "Control.Exception" documentation for more details.
--
-- TODO: Possibly look into bringing in some more robust tools from
-- monad-control and other industry established error handling routes?
-- Also, can we modify an underlying monad with implicit cacting behavior?
catchA :: Exception e
       => Auto IO a b               -- ^ Auto over IO, expecting an
                                    --     exception of a secific type.
       -> Auto IO a (Either e b)
catchA a = a_
  where
    a_ = mkAutoM (catchA <$> resumeAuto a)
                 (saveAuto a)
               $ \x -> do
                   eya' <- try $ stepAuto a x
                   case eya' of
                     Right (y, a') -> return (Right y, catchA a')
                     Left e        -> return (Left e , a_)
