provide.hs

{-# 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)