Skip to content

Instantly share code, notes, and snippets.

@unclechu
Created January 9, 2017 01:20
Show Gist options
  • Save unclechu/bd4d000e3dbd42676c59ea9ef2d27c07 to your computer and use it in GitHub Desktop.
Save unclechu/bd4d000e3dbd42676c59ea9ef2d27c07 to your computer and use it in GitHub Desktop.
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|----------------------------------------|]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment