Skip to content

Instantly share code, notes, and snippets.

@unclechu
Last active December 18, 2016 20:24
Show Gist options
  • Save unclechu/246245136717b2f7d85189c86df14e85 to your computer and use it in GitHub Desktop.
Save unclechu/246245136717b2f7d85189c86df14e85 to your computer and use it in GitHub Desktop.
Haskell: breakable composition experiments
#!/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'}|]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment