Ch21.purs

module Ch21 where

import Prelude

import Control.Monad.Error.Class (class MonadError, class MonadThrow, catchError, throwError)
import Control.Monad.Except.Trans (ExceptT, runExceptT)
import Control.Monad.Reader.Class (class MonadAsk, ask)
import Control.Monad.State.Class (class MonadState, get, put)
import Control.Monad.Trans.Class (class MonadTrans, lift)
import Control.Monad.Writer.Class (class MonadTell, tell)
import Control.Monad.Writer.Trans (WriterT, runWriterT)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Effect (Effect)
import Effect.Console as Console

newtype StateT s m a = StateT (s -> m (Tuple a s))

------------------------
-- 1. Write runStateT --
------------------------

runStateT :: ∀ s m a. StateT s m a -> s -> m (Tuple a s)
runStateT (StateT f) = f

----------------------
-- 2. Write Functor --
----------------------

-- class Functor f where
-- map :: forall a b. (a -> b) -> f a -> f b

instance functorStateT :: Functor m => Functor (StateT s m) where
  map f (StateT g) = StateT \s -> g s <#> (\(Tuple a b) -> Tuple (f a) b)

--------------------
-- 3. Write Apply --
--------------------

-- class (Functor f) <= Apply f where
-- apply :: forall a b. f (a -> b) -> f a -> f b

instance applyStateT :: Monad m => Apply (StateT s m) where
  apply = ap

--------------------------
-- 4. Write Applicative --
--------------------------

-- class (Apply f) <= Applicative f where
-- pure :: forall a. a -> f a

instance applicativeStateT :: Monad m => Applicative (StateT s m) where
  pure x = StateT \s -> pure $ Tuple x s

-------------------
-- 5. Write Bind --
-------------------

-- class (Apply m) <= Bind m where
-- bind :: forall a b. m a -> (a -> m b) -> m b

instance bindStateT :: Monad m => Bind (StateT s m) where
  bind (StateT x) f = StateT \s -> x s >>= \(Tuple x1 s1) -> runStateT (f x1) s1

--------------------
-- 6. Write Monad --
--------------------

-- class (Applicative m, Bind m) <= Monad m

instance monadStateT :: Monad m => Monad (StateT s m)

-------------------------
-- 7. Write MonadState --
-------------------------

-- class (Monad m) <= MonadState s m | m -> s where
-- state :: forall a. (s -> (Tuple a s)) -> m a

instance monadStateStateT :: Monad m => MonadState s (StateT s m) where
  state f = StateT $ pure <<< f

-----------------------
-- 8. Write MonadAsk --
-----------------------

-- class (Monad m) <= MonadAsk r m | m -> r where
-- ask :: m r

-- instance monadAskStateT :: MonadAsk r m => MonadAsk r (StateT s m) where
--   ask = StateT \s -> ask <#> \r -> Tuple r s

------------------------
-- 9. Write MonadTell --
------------------------

-- class (Semigroup w, Monad m) <= MonadTell w m | m -> w where
-- tell :: w -> m Unit

-- instance monadTellStateT :: MonadTell w m => MonadTell w (StateT s m) where
--   tell w = StateT \s -> tell w <#> \_ -> Tuple unit s
-- tell w = StateT \s -> tell w <#> \unit -> Tuple unit s

--------------------------
-- 10. Write MonadTrans --
--------------------------

-- class MonadTrans t where
-- lift :: forall m a. Monad m => m a -> t m a

instance monadTransStateT :: MonadTrans (StateT s) where
  lift m = StateT \s -> m <#> \a -> Tuple a s

-------------------------------------------------------------------------
-- 11. Write monadAskStateT and monadTellStateT in terms of MonadTrans --
-------------------------------------------------------------------------

instance monadAskStateT :: MonadAsk r m => MonadAsk r (StateT s m) where
  ask = lift ask

instance monadTellStateT :: MonadTell w m => MonadTell w (StateT s m) where
  tell = lift <<< tell

--------------------
-- 12. MonadThrow --
--------------------

-- class (Monad m) <= MonadThrow e m | m -> e where
-- throwError :: forall a. e -> m a

instance monadThrowStateT :: (MonadThrow e m, Monad m) => MonadThrow e (StateT s m) where
  throwError = lift <<< throwError

--------------------
-- 13. MonadError --
--------------------

-- class (MonadThrow e m) <= MonadError e m | m -> e where
-- catchError :: forall a. m a -> (e -> m a) -> m a

instance monadErrorStateT :: MonadError e m => MonadError e (StateT s m) where
  catchError :: ∀ a. StateT s m a -> (e -> StateT s m a) -> StateT s m a
  catchError (StateT fmx) f = StateT \s -> catchError (fmx s) \e -> runStateT (f e) s

-- Given: we want this to be our Monad stack
type AppStack e w s a = ExceptT e (WriterT w (StateT s Effect)) a

-----------------------------------------
-- 14. Write AppM in terms of AppStack --
-----------------------------------------

-- We’ll want our error to be a String, our State to be an Int, our log to be a String
-- and the final result of our application to be Unit.
type AppM = AppStack String String Int Unit

----------------------
-- 15. Write runApp --
----------------------

-- Use the type hole to find out about the application result
runApp :: Int -> AppM -> Effect AppResult
runApp st = (results <$> _) <<< flip runStateT st <<< runWriterT <<< runExceptT

------------------------------------
-- 16. Factor out the return type --
------------------------------------

-- update runApp with new type alias

type StackResult = Tuple (Tuple (Either String Unit) String) Int

----------------------------------------------------------------------------------------
-- 17. Write a type alias using a record to store all side-effects of the monad stack --
----------------------------------------------------------------------------------------

type AppEffects =
  { log :: String
  , state :: Int
  , result :: Maybe Unit
  }

-- Given: AppResult contains our side-effect values from running our monad stack, i.e. AppEffects
--        and, optionally, the error if one occurred
type AppResult = Tuple (Maybe String) AppEffects

---------------------------------------------------------------------------
-- 18. Write a mapping function that turns StackResult into an AppResult --
---------------------------------------------------------------------------

-- use results function to change runApp

results :: StackResult -> AppResult
results (Tuple (Tuple (Left err) l) s) = Tuple (Just err) { log: l, state: s, result: Nothing }
results (Tuple (Tuple (Right result) l) s) = Tuple Nothing { log: l, state: s, result: Just result }

-------------------------------------
-- 19. Write the application monad --
-------------------------------------

-- the requirements for the body of app in the specified order:

-- write to the log "Starting App..."
-- get the State
-- check the State to make sure it is non-zero, otherwise error with "WE CANNOT HAVE 0 STATE!"
-- add 1 to the State
-- write to the log "Incremented State"
-- return the Pure Computational Value

app :: AppM
app = do
  log "Starting App..."
  n <- get
  when (n /= 0) $ void $ throwError "WE CANNOT HAVE 0 STATE"
  put $ n + 1
  log "Incremented State"
  pure unit

--------------------------------------------------------------------------------------
-- 20. Write a helper function that adds a newline after every string to the writer --
--------------------------------------------------------------------------------------

-- use function 'log' in function 'app'

log :: ∀ m. MonadTell String m => String -> m Unit
log s = tell $ s <> "\n"

-------------------
-- Test Function --
-------------------

test :: Effect Unit
test = do
  result1 <- runApp 0 app
  Console.log $ show result1 -- (Tuple Nothing { log: "Starting App...\nIncremented State\n", result: (Just unit), state: 1 })
  result2 <- runApp 99 app
  Console.log $ show result2 -- (Tuple (Just "WE CANNOT HAVE 0 STATE") { log: "Starting App...\n", result: Nothing, state: 99 })

spago.dhall

{ name = "my-project"
, dependencies = [ "console", "effect", "prelude", "psci-support", "either", "tuples", "maybe", "strings", "arrays", "foldable-traversable", "unicode", "control", "unfoldable", "transformers" ]
, packages = ./packages.dhall
, sources = [ "src/**/*.purs", "test/**/*.purs" ]
}