Skip to content

Instantly share code, notes, and snippets.

@danstn
Forked from aaronlevin/reasonable.hs
Created March 29, 2016 15:29
Show Gist options
  • Save danstn/d64b0bfe7f991f03d3b4 to your computer and use it in GitHub Desktop.
Save danstn/d64b0bfe7f991f03d3b4 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment