Haskell: breakable composition experiments

breakable-composition.hs

#!/usr/bin/env stack
-- stack runghc --resolver lts-7.7 --install-ghc --package data-default-0.7.1.1 --package interpolatedstring-perl6-1.0.0 --package transformers-0.5.2.0 --package either-4.4.1.1

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

import "base" Data.Either (Either(Left, Right), either)

import "interpolatedstring-perl6" Text.InterpolatedString.Perl6 (qc)
import "data-default" Data.Default (Default, def)
import "transformers" Control.Monad.Trans.Class (MonadTrans, lift)
import "either" Control.Monad.Trans.Either (EitherT, runEitherT, left, right)


data State a = State a deriving (Show, Eq)

instance (Num a) => Default (State a) where
  def = State 1

instance Functor State where
  fmap f (State x) = State $ f x

type S = State Int


type BreakableVal a = Either a a
type BreakableIO a = EitherT a IO a



-- Simple Either

foo :: Bool -> BreakableVal S -> IO (BreakableVal S)
foo _        (Left  state) = return $ Left state
foo continue (Right state) = do
  let newState = fmap (+10) state
  printState [qc|foo {continue}|] newState
  return $ (if continue then Right else Left) newState

bar :: Bool -> BreakableVal S -> IO (BreakableVal S)
bar _        (Left  state) = return $ Left state
bar continue (Right state) = do
  let newState = fmap (+100) state
  printState [qc|bar {continue}|] newState
  return $ (if continue then Right else Left) newState

baz :: Bool -> BreakableVal S -> IO (BreakableVal S)
baz _        (Left  state) = return $ Left state
baz continue (Right state) = do
  let newState = fmap (+1000) state
  printState [qc|baz {continue}|] newState
  return $ (if continue then Right else Left) newState

fooBarBazComposed :: BreakableVal S -> IO (BreakableVal S)
fooBarBazComposed s = foo True s >>= bar True >>= baz True

fooBrakeBarBazComposed :: BreakableVal S -> IO (BreakableVal S)
fooBrakeBarBazComposed s = foo False s >>= bar True >>= baz True

fooBarBrakeBazComposed :: BreakableVal S -> IO (BreakableVal S)
fooBarBrakeBazComposed s = foo True s >>= bar False >>= baz True

fooBarBazBrakeComposed :: BreakableVal S -> IO (BreakableVal S)
fooBarBazBrakeComposed s = foo True s >>= bar True >>= baz False

fooBarBrakeBazBrakeComposed :: BreakableVal S -> IO (BreakableVal S)
fooBarBrakeBazBrakeComposed s = foo True s >>= bar False >>= baz False



-- Monadic Either with IO transformer

mFoo :: Bool -> S -> BreakableIO S
mFoo continue state = do
  let newState = fmap (+10) state
  lift $ printState [qc|mFoo {continue}|] newState
  (if continue then right else left) newState

mBar :: Bool -> S -> BreakableIO S
mBar continue state = do
  let newState = fmap (+100) state
  lift $ printState [qc|mBar {continue}|] newState
  lift $ if continue
            then putStrLn "before"
            else putStrLn "before breaking"
  if continue
     then return newState
     else left newState -- Breaks (anything below will be ignored)
  lift $ if continue
            then putStrLn "after"
            else putStrLn "after breaking" -- Mustn't be seen
  return newState

mBaz :: Bool -> S -> BreakableIO S
mBaz continue state = do
  let newState = fmap (+1000) state
  lift $ printState [qc|mBaz {continue}|] newState
  (if continue then right else left) newState

mFooBarBazComposed :: S -> BreakableIO S
mFooBarBazComposed s = mFoo True s >>= mBar True >>= mBaz True

mFooBrakeBarBazComposed :: S -> BreakableIO S
mFooBrakeBarBazComposed s = mFoo False s >>= mBar True >>= mBaz True

mFooBarBrakeBazComposed :: S -> BreakableIO S
mFooBarBrakeBazComposed s = mFoo True s >>= mBar False >>= mBaz True

mFooBarBazBrakeComposed :: S -> BreakableIO S
mFooBarBazBrakeComposed s = mFoo True s >>= mBar True >>= mBaz False

mFooBarBrakeBazBrakeComposed :: S -> BreakableIO S
mFooBarBrakeBazBrakeComposed s = mFoo True s >>= mBar False >>= mBaz False



-- Parent-wrapper-based breakable composition

type Wrapper = (S -> IO S) -> IO S
type WMonad = S -> IO S

-- wFoo :: Bool -> ((S -> IO S) -> IO S) -> (S -> IO S) -> IO S
wFoo :: Bool -> Wrapper -> WMonad -> IO S
wFoo continue wrap m = wrap $ \state -> do
  let newState = fmap (+10) state
  printState [qc|wFoo {continue}|] newState
  if continue then m newState else return newState

wBar :: Bool -> Wrapper -> WMonad -> IO S
wBar continue wrap m = wrap $ \state -> do
  let newState = fmap (+100) state
  printState [qc|wBar {continue}|] newState
  if continue then m newState else return newState

wBaz :: Bool -> Wrapper -> WMonad -> IO S
wBaz continue wrap m = wrap $ \state -> do
  let newState = fmap (+1000) state
  printState [qc|wBaz {continue}|] newState
  if continue then m newState else return newState

(.>) = flip (.)

-- wCompose :: S -> (((S -> IO S) -> IO S) -> (S -> IO S) -> IO S) -> IO S
wCompose :: S -> (Wrapper -> WMonad -> IO S) -> IO S
wCompose s f = f ($ s) return

-- wFooBarBazComposed :: S -> IO S
-- wFooBarBazComposed s = wCompose s $ wFoo True .> wBar True .> wBaz True
-- wFooBarBazComposed s = (wFoo True .> wBar True .> wBaz True) ($ s) return
wFooBarBazComposed :: Wrapper -> WMonad -> IO S
wFooBarBazComposed = wFoo True .> wBar True .> wBaz True

wFooBrakeBarBazComposed :: Wrapper -> WMonad -> IO S
wFooBrakeBarBazComposed = wFoo False .> wBar True .> wBaz True

wFooBarBrakeBazComposed :: Wrapper -> WMonad -> IO S
wFooBarBrakeBazComposed = wFoo True .> wBar False .> wBaz True

wFooBarBazBrakeComposed :: Wrapper -> WMonad -> IO S
wFooBarBazBrakeComposed = wFoo True .> wBar True .> wBaz False

wFooBarBrakeBazBrakeComposed :: Wrapper -> WMonad -> IO S
wFooBarBrakeBazBrakeComposed = wFoo True .> wBar False .> wBaz False



printState :: String -> State Int -> IO ()
printState msg state =
  putStrLn [qc|Message: {msg} | State: {state}|]

main :: IO ()
main = do

  -- Simple Either

  sepItem >> fooBarBazComposed (Right def)           >>= print
    -- >>= return . either id id >>= print
  sepItem >> fooBrakeBarBazComposed (Right def)      >>= print
  sepItem >> fooBarBazComposed (Left def)            >>= print -- Do nothing
  sepItem >> fooBarBrakeBazComposed (Right def)      >>= print
  sepItem >> fooBarBazBrakeComposed (Right def)      >>= print
  sepItem >> fooBarBrakeBazBrakeComposed (Right def) >>= print

  sepItem
  -- All composed in one
  -- (shows us opportunities of composition using this implementation).
  fooBarBazComposed (Right def)
    >>= fooBrakeBarBazComposed
    >>= fooBarBrakeBazComposed
    >>= fooBarBazBrakeComposed
    >>= fooBarBrakeBazBrakeComposed
    >>= return . either id id
    >>= print


  -- Monadic Either with IO transformer

  sepType >> runEitherT (mFooBarBazComposed def)           >>= print
    -- >>= return . either id id >>= print
  sepItem >> runEitherT (mFooBrakeBarBazComposed def)      >>= print
  sepItem >> runEitherT (mFooBarBrakeBazComposed def)      >>= print
  sepItem >> runEitherT (mFooBarBazBrakeComposed def)      >>= print
  sepItem >> runEitherT (mFooBarBrakeBazBrakeComposed def) >>= print

  -- All composed in one
  -- (shows us opportunities of composition using this implementation).
  let chain = mFooBarBazComposed def
          >>= mFooBrakeBarBazComposed
          >>= mFooBarBrakeBazComposed
          >>= mFooBarBazBrakeComposed
          >>= mFooBarBrakeBazBrakeComposed
   in sepItem >> runEitherT chain >>= return . either id id >>= print


  -- Parent-wrapper-based breakable composition

  sepType >> wCompose def wFooBarBazComposed           >>= print
  sepItem >> wCompose def wFooBrakeBarBazComposed      >>= print
  sepItem >> wCompose def wFooBarBrakeBazComposed      >>= print
  sepItem >> wCompose def wFooBarBazBrakeComposed      >>= print
  sepItem >> wCompose def wFooBarBrakeBazBrakeComposed >>= print

  let chain = wFooBarBazComposed
           .> wFooBrakeBarBazComposed
           .> wFooBarBrakeBazComposed
           .> wFooBarBazBrakeComposed
           .> wFooBarBrakeBazBrakeComposed
   in sepItem >> wCompose def chain >>= print


  sepItem
  return ()

  where sepItem = putStrLn [qc|----------------------------------------|]
        sepType = putStrLn
          [qc|{'\\n'}////////////////////////////////////////{'\\n'}|]