either-state-t-combined.hs

either-state-t-combined.hs

#!/usr/bin/env stack
-- stack runghc --resolver lts-7.7 --install-ghc --package interpolatedstring-perl6 --package transformers --package either --package mtl --package lens

{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}

import "base" Data.Either (Either(Left, Right), either)
import "base" Data.Functor.Identity (Identity, runIdentity)
import "base" Data.Function ((&))
import "base" Control.Monad (liftM)
import "base" Control.Monad.IO.Class (liftIO)

import "interpolatedstring-perl6" Text.InterpolatedString.Perl6 (qc)
import "transformers" Control.Monad.Trans.Class (MonadTrans, lift)
import "transformers" Control.Monad.Trans.State
  (StateT, runStateT, evalStateT, execStateT)
import "either" Control.Monad.Trans.Either (EitherT, runEitherT, left, right)
import "mtl" Control.Monad.State.Class (MonadState(get, put, state))

import "lens" Control.Lens ((%~), (+~), over)
import "lens" Control.Lens.Iso (iso)
import "lens" Control.Lens.Wrapped
  (Rewrapped, Wrapped, Unwrapped, _Wrapped', _Wrapped, _Wrapping)
import "lens" Control.Lens.TH (makeWrapped)

newtype MyState = MyState Int deriving (Show, Eq)

-- instance (t ~ MyState) => Rewrapped MyState t
-- instance Wrapped MyState where
--   type Unwrapped MyState = Int
--   _Wrapped' = iso (\(MyState x) -> x) MyState
--   {-# INLINE _Wrapped' #-}

-- i don't even have to describe these instances by my bare hands!
makeWrapped ''MyState

type EitherStateT s l m r = EitherT l (StateT s m) r


foo :: IO ()
foo = fmap (either id id) . flip evalStateT (MyState 3) . runEitherT $ bar
  where bar :: EitherT () (StateT MyState IO) ()
        bar = do
          get >>= \s -> liftIO $ putStrLn [qc| bar #1 >>> s: {s} <<< |]

          over _Wrapped (+ 10) <$> get >>= put
          get >>= \s -> liftIO $ putStrLn [qc| bar #2 >>> s: {s} <<< |]

          -- explicit wrapping (a lot safer)
          over (_Wrapping MyState) (+ 100) <$> get >>= put
          get >>= \s -> liftIO $ putStrLn [qc| bar #3 >>> s: {s} <<< |]

          -- explicit wrapping replacing `over` with `(%~)` operator
          (_Wrapping MyState %~ (+ 1000)) <$> get >>= put
          get >>= \s -> liftIO $ putStrLn [qc| bar #4 >>> s: {s} <<< |]

          -- getting even more fun with syntax sugar using `(+~)` operator,
          -- with `state` and `TupleSections`.
          state $ ((),) . (_Wrapping MyState +~ 10000)
          get >>= \s -> liftIO $ putStrLn [qc| bar #5 >>> s: {s} <<< |]

          right ()
          liftIO $ putStrLn [qc| bar After Right ---{""
                               } this message must be shown |]

          left ()
          liftIO $ putStrLn [qc| bar After Left --- this message MUSTN'T{""
                               } be shown (because of Left of Either) |]

          return ()


checkIfBreaked :: (Show l, Show r) => EitherT l (StateT s IO) r -> s -> IO ()
checkIfBreaked m initState =
  putStrLn =<< (fmap mf . flip evalStateT initState . runEitherT $ m)

  where mf (Left  x) = [qc| Left:  {x} |]
        mf (Right y) = [qc| Right: {y} |]

breaked :: EitherStateT MyState Int IO Double
breaked = left 15 >> return 123

notBreaked :: EitherStateT Int Double IO Int
notBreaked = right 30


-- extracting value from state
checkIfBreakedFromState :: (Show s) => EitherStateT s () IO () -> s -> IO ()
checkIfBreakedFromState m initState =
  putStrLn =<< (fmap mf . flip evalStateT initState . t . runEitherT $ m)

  where mf (Left  x) = [qc| Left:  {x} |]
        mf (Right y) = [qc| Right: {y} |]

        t :: StateT s IO (Either () ()) -> StateT s IO (Either s s)
        t = (>>= m)
          where m (Left  _) = Left  <$> get
                m (Right _) = Right <$> get

fromStateBreaked :: EitherStateT MyState () IO ()
fromStateBreaked =
  (state $ ((),) . (_Wrapping MyState +~ 9000))
    >> (state $ ((),) . (_Wrapping MyState +~ 100))
    >> left ()
    >> (state $ ((),) . (_Wrapping MyState +~ 50)) -- MUSTN'T be done

fromStateNotBreaked :: EitherStateT Int () IO ()
fromStateNotBreaked =
  (state $ ((),) . (+ 9000))
    >> (state $ ((),) . (+ 100))
    >> right ()
    >> (state $ ((),) . (+ 50)) -- MUST be done


main :: IO ()
main = do

  separate
  foo

  separate
  checkIfBreaked breaked $ MyState 5

  separate
  checkIfBreaked notBreaked 7

  separate
  checkIfBreakedFromState fromStateBreaked $ MyState 8

  separate
  checkIfBreakedFromState fromStateNotBreaked 9

  separate

  where separate = putStrLn [qc|----------------------------------------|]