TypedClient.hs

{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
module TypedClient
  ( Handlers(..)
  , someException
  , ClientT(..)
  , runClientT
  , throwT
  , generalizeT
  ) where

import Import hiding (Text, Index)

import Data.Kind (Type, Constraint)
import GHC.TypeLits (TypeError, ErrorMessage(..))

import Control.Monad.Except (ExceptT, runExceptT, withExceptT, MonadError(..))

infixr 5 :&
data Handlers :: [Type] -> Type -> Type where
  Nil  :: Handlers '[] a
  (:&) :: (x -> a) -> Handlers xs a -> Handlers (x ': xs) a

class UniversalHandler (c :: Type -> Constraint) (as :: [Type]) where
  universal :: (forall x. c x => x -> e) -> Handlers as e

instance UniversalHandler c '[] where
  universal _ = Nil

instance (c a, UniversalHandler c as) => UniversalHandler c (a ': as) where
  universal f = f :& universal @c f

someException :: forall as. UniversalHandler Exception as => Handlers as SomeException
someException = universal @Exception toException

data Union :: [Type] -> Type where
  Here  :: x -> Union (x ': xs)
  There :: Union xs -> Union (x ': xs)

type family All (f :: u -> Constraint) (xs :: [u]) :: Constraint where
  All _ '[] = ()
  All f (x ': xs) = (f x, All f xs)

deriving instance All Show xs => Show (Union xs)

-- | A union of no elements is impossible
emptyUnion :: Union '[] -> false
emptyUnion = \case{}

match :: Union xs -> Handlers xs a -> a
match (Here v) (handler :& _) = handler v
match (There vs) (_ :& handlers) = match vs handlers

class Member (a :: Type) (as :: [Type]) where
  inj :: a -> Union as

type NotFoundMessage err =
  ShowType err :<>: Text " not found in error set" :$$:
  Text "Consider adding " :<>: ShowType err :<>: Text " to the type level error set" :$$:
  Text "EX: (Client '[ " :<>: ShowType err :<>: Text ", ... ] ())"

instance TypeError (NotFoundMessage x) => Member x '[] where
  inj = error "type error"

instance Member x (x ': xs) where
  inj = Here

instance {-# OVERLAPS #-} Member x xs => Member x (y ': xs) where
  inj val = There (inj val)

type family Subset (as :: [Type]) (bs :: [Type]) :: Constraint where
  Subset '[] _ = ()
  Subset (x ': xs) ys = (Member x ys, Subset xs ys)

class Subset as bs => Members (as :: [Type]) (bs :: [Type]) where
  relax :: Union as -> Union bs

instance Members '[] ys where
  relax = emptyUnion

instance (Member x ys, Members xs ys) => Members (x ': xs) ys where
  relax (Here val) = inj val
  relax (There vs) = relax vs

-- | An ExceptT with an optionally open or closed universe of possible throwable errors
-- The universe is a type level list EX: [ ParseError, HTTPError ]
newtype ClientT errs m a = ClientT { unClientT :: ExceptT (Union errs) m a }
  deriving ( Functor, Applicative, Monad, Foldable, Traversable, MonadIO, MonadTrans, MonadReader r )

-- | You can run a 'ClientT' if you can provide a handler for every possible error
runClientT :: forall errs e m a. Functor m => Handlers errs e -> ClientT errs m a -> m (Either e a)
runClientT handlers = fmap (bimap (\err -> match err handlers) id) . runExceptT . unClientT

type Client errs a = ClientT errs Handler a

-- | Throw an exception found in the error set
throwT :: forall err errs m a. (Member err errs, Monad m) => err -> ClientT errs m a
throwT err = ClientT (throwError (inj err))

-- | Transform a closed universe of error types to an open universe
-- generalizeT
--   :: Members '[ ParseError, HTTPError ] errs
--   => Client '[ ParseError, HTTPError ] ()
--   -> Client errs ()
generalizeT :: (Members errs1 errs2, Functor m)
            => ClientT errs1 m a
            -> ClientT errs2 m a
generalizeT = ClientT . withExceptT relax . unClientT

data ParseError = ParseError String deriving Show
instance Exception ParseError
data HTTPError = HTTPError deriving Show
instance Exception HTTPError
data DatabaseError = DatabaseError deriving Show
instance Exception DatabaseError

json :: FromJSON a => String -> Client '[ ParseError ] a
json str = throwT (ParseError str)

http :: Members '[ HTTPError ] errs => Bool -> Client errs Bool
http _ = throwT HTTPError

db :: Members '[ DatabaseError ] errs => Client errs [String]
db = throwT DatabaseError

-- example :: Members '[ ParseError, HTTPError ] errs => Client errs ()
example :: Client '[ ParseError, HTTPError ] ()
example = do
  val <- generalizeT (json "{ foo: true }")
  req <- http val
  -- rows <- db
  print req

exampleRun :: Handler (Either SomeException ())
exampleRun = runClientT (someException @'[ ParseError, HTTPError ]) example