Skip to content

Instantly share code, notes, and snippets.

@aaronlevin
Last active June 8, 2017 14:55
Show Gist options
  • Save aaronlevin/87465696ba6c554bc72b to your computer and use it in GitHub Desktop.
Save aaronlevin/87465696ba6c554bc72b to your computer and use it in GitHub Desktop.
Reasonably Priced Monads in Haskell
-- | simple/basic Scala -> Haskell translation of Runar's presentation
-- | (https://dl.dropboxusercontent.com/u/4588997/ReasonablyPriced.pdf)
-- | trying to use minimal extensions and magic.
-- | (earlier I had a version using MultiParamTypeClasses for Runar's
-- | Inject class, but scraped it opting for simplicity)
-- | my question: what do we lose by moving towards simplicity?
-- | Future work: use DataKinds, TypeOperators, and potentially TypeFamilies
-- | to maintain and automate the folding of types in Coproduct.
{-# LANGUAGE Rank2Types, DeriveFunctor #-}
module Main where
import Control.Applicative ((<$>), Applicative(..))
import Data.Functor.Coproduct (Coproduct(Coproduct), getCoproduct)
data Free f a = Pure a
| Free( f (Free f a) )
deriving Functor
instance Functor f => Applicative (Free f) where
pure = Pure
Pure f <*> Pure x = Pure $ f x
Pure f <*> Free mx = Free $ fmap f <$> mx
Free mf <*> x = Free $ (<*> x) <$> mf
instance Functor f => Monad (Free f) where
return = Pure
Pure x >>= f = f x
Free mx >>= f = Free ((>>= f) <$> mx)
infixr 6 |*|
(|*|) :: (Functor f, Functor g) => (forall a. f a -> g a) -> (forall b. h b -> g b) -> Coproduct f h c -> g c
fg |*| hg = \x -> case getCoproduct x of
Left f -> fg f
Right h -> hg h
-- TOOD: this function will probably explode the stack for deep nesting. can we optimize?
-- is optimization necessary?
threadF :: (Functor f, Functor g) => (forall b. f b -> g b) -> Free f a -> Free g a
threadF _ (Pure x) = Pure x
threadF t (Free fa) = Free(t $ fmap (threadF t) fa)
-- Data
data Interaction a = Ask String (String -> a)
| Tell String a
deriving Functor
data User = User String
data Auth a = Login String String (Maybe User -> a)
| HasPermission User String (Bool -> a)
deriving Functor
data Logging a = Logging String a deriving Functor
-- Combinators
tellC :: (Functor f) => (forall a. Interaction a -> f a) -> String -> Free f ()
tellC fa msg = threadF fa (Free(Tell msg (Pure ())))
askC :: (Functor f) => (forall a. Interaction a -> f a) -> String -> Free f String
askC fa msg = threadF fa (Free(Ask msg Pure))
loginC :: (Functor f) => (forall a. Auth a -> f a) -> String -> String -> Free f (Maybe User)
loginC fa username password = threadF fa (Free(Login username password Pure))
hasPermissionC :: (Functor f) => (forall a. Auth a -> f a) -> User -> String -> Free f Bool
hasPermissionC fa user permission = threadF fa (Free(HasPermission user permission Pure))
logC :: (Functor f) => (forall a. Logging a -> f a) -> String -> Free f ()
logC fa msg = threadF fa (Free(Logging msg (Pure ())))
-- Program
newtype Program a = Program { run :: Coproduct Interaction (Coproduct Auth Logging) a } deriving Functor
-- Program-specific combinators
-- This is where the complexity happens if you add a new layer
tell :: String -> Free Program ()
tell = tellC (Program . Coproduct . Left)
ask :: String -> Free Program String
ask = askC (Program . Coproduct . Left)
login :: String -> String -> Free Program (Maybe User)
login = loginC (Program . Coproduct . Right . Coproduct . Left)
hasPermission :: User -> String -> Free Program Bool
hasPermission = hasPermissionC (Program . Coproduct . Right . Coproduct . Left)
logger :: String -> Free Program ()
logger = logC (Program . Coproduct . Right . Coproduct . Right)
-- IO Interpreters
interactionIO :: Interaction a -> IO a
interactionIO (Tell msg a) = do
putStrLn msg
return a
interactionIO (Ask msg f) = do
putStrLn msg
s <- getLine
return (f s)
authIO :: Auth a -> IO a
authIO (Login _ _ next) = do
putStrLn "logging in user"
return (next Nothing)
authIO (HasPermission _ permission next) = return $ next (permission == "admin")
loggingIO :: Logging a -> IO a
loggingIO (Logging msg a) = do
putStrLn $ "LOG: " ++ msg
return a
-- A Program
program :: Free Program ()
program = do
userid <- ask "what's your user id?"
logger $ "user id: " ++ userid
pass <- ask "password please:"
logger $ "password: " ++ pass
permission <- ask "permission level"
user <- login userid pass
case user of
Just u -> hasPermission u permission >>= \t -> tell (if t then "permission!" else "no permission :(")
Nothing -> tell "user failed"
return ()
-- helper
foldRunar :: (Functor f, Monad g) => (forall b. f b -> g b) -> Free f a -> g a
foldRunar _ (Pure a) = return a
foldRunar f (Free fa) = f fa >>= foldRunar f
-- main
main :: IO ()
main = foldRunar ( (interactionIO |*| authIO |*| loggingIO) . run) program
@danstn
Copy link

danstn commented Mar 29, 2016

Would that be an idiomatic Haskell approach for using coproducts?

Seems like a lot of additional boilerplate to achieve DSL composition. Do you think we can do better?

Great translation!

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment