Skip to content

Instantly share code, notes, and snippets.

@parsonsmatt
Last active October 23, 2020 03:47
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save parsonsmatt/b4fb1ba2d44103f71469225f3fe77ee8 to your computer and use it in GitHub Desktop.
{-# language TypeApplications, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}
{-# language DataKinds, RankNTypes, PolyKinds, ScopedTypeVariables, GADTs, UndecidableInstances, TypeOperators #-}
{-# language ConstraintKinds #-}
module CatchR where
import Control.Monad.Reader
import Control.Monad.Except
to :: Reader (r, rest) a -> (r -> Reader rest a)
to k r = reader $ \rest -> runReader k (r, rest)
from :: (r -> Reader rest a) -> Reader (r, rest) a
from k = do
(r, s) <- ask
pure $ runReader (k r) s
catchE
:: Either (Either l r) a
-- ^ Given a set of three possible outputs,
-> (l -> Either r a)
-- ^ And a means of mapping one possible output into the other two,
-> Either r a
-- ^ Return one of two possible outputs.
catchE e k =
case e of
Left lr ->
case lr of
Left l ->
k l
Right r ->
Left r
Right a ->
Right a
catchR
:: Reader (r, rest) a
-- ^ Given a recipe requiring an `r` and a `rest`
-> Reader rest r
-- ^ And a recipe for producing an `r` from a `rest`,
-> Reader rest a
-- ^ Give me an recipe producing an `a` from only a `rest`.
catchR f g = do
rest <- ask
r <- g
pure $ runReader f (r, rest)
catchR'
:: (r -> rest -> a)
-> (rest -> r)
-> (rest -> a)
catchR' = (=<<)
hatch
:: (rest -> r)
-> (r -> rest -> a)
-> (rest -> a)
hatch = (>>=)
provide
:: (MonadReader (HList rest) m)
=> m r
-> ReaderT (HList (r ': rest)) m a
-> m a
provide f g = do
r <- f
rest <- ask
runReaderT g (r ::: rest)
data HList xs where
HNil :: HList '[]
(:::) :: a -> HList as -> HList (a ': as)
class Has t env where
get :: HList env -> t
instance {-# overlapping #-} Has x (x ': xs) where
get (a ::: _) = a
instance forall x xs y. (Has x xs) => Has x (y ': xs) where
get (_ ::: xs) = get @x xs
data Logger = Logger
data DbHandle = DbHandle
type App r m = (MonadReader (HList r) m, MonadIO m)
getUserIds
:: (App x m, Has Logger x, Has DbHandle x)
=> m [Int]
getUserIds = do
logFoo "getting user ids"
pure [1,2,3]
mkDatabase
:: (App env m, Has Logger env)
=> m DbHandle
mkDatabase = do
logFoo "getting database handle"
pure DbHandle
start :: (App r m) => m Logger
start = pure Logger
runApp
:: (forall m. (MonadIO m, MonadReader (HList '[]) m) => m a)
-> IO a
runApp action = runReaderT action HNil
logFoo :: (App r m, Has Logger r) => String -> m ()
logFoo msg = liftIO $ putStrLn msg
main :: IO ()
main = do
runApp $ do
provide start $ do
-- here we have the 'Has Logger env' in scope, so we can log
logFoo "hello world!"
provide mkDatabase $ do
-- now we have the 'Has DbHandle env' in scope, so we can query
xs <- getUserIds
forM_ xs $ \x -> do
logFoo (show x)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment