Constraint-preserving composition of functions with constraints

constraint-composition.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FunctionalDependencies #-}

import GHC.Exts

class Handler h a where
  type HCtx h a :: Constraint

  handle :: HCtx h a => h a -> a -> String

class Handler h b => Middleware m h a b where
  type MCtx m a b :: Constraint

  extendHandler :: (Handler h b, HCtx h b, MCtx m a b) =>
    m h a b -> h b -> (a -> String)

data BaseHandler a = BaseHandler (a -> String)

data ConstrainedHandler (p :: Constraint) a =
  ConstrainedHandler (p => a -> String)

data ConstrainedMiddleware
  (p :: Constraint) h a b = ConstrainedMiddleware {
    getMiddleware :: ((Handler h b, HCtx h b, p) => h b -> a -> String)
  }

instance Handler BaseHandler a where
  type HCtx BaseHandler a = ()

  handle (BaseHandler h) = h

instance Handler (ConstrainedHandler p) a where
  type HCtx (ConstrainedHandler p) a = p

  handle (ConstrainedHandler h) = h

instance (Handler h b) =>
  Middleware (ConstrainedMiddleware p) h a b where
    type MCtx (ConstrainedMiddleware p) a b = p

    extendHandler (ConstrainedMiddleware m) h = m h

composeHandlers ::
  forall f g a.
  (Handler f a, Handler g a) =>
  f a ->
  g a ->
  ConstrainedHandler ((HCtx f a), (HCtx g a)) a
composeHandlers f g = ConstrainedHandler $ \c ->
  "(compose-handler " ++ (handle f c) ++ " " ++ (handle g c) ++ ")"

applyMiddleware ::
  forall m h a b.
  (Handler h b,
  Middleware m h a b) =>
  m h a b ->
  h b ->
  ConstrainedHandler (HCtx h b, MCtx m a b) a
applyMiddleware m h = ConstrainedHandler $ extendHandler m h


class HasFoo a where
  getFoo :: a -> String

class HasBar a where
  getBar :: a -> String

fooHandler :: forall a. ConstrainedHandler (HasFoo a) a
fooHandler = ConstrainedHandler $ \x ->
  "(foo-handler " ++ (getFoo x) ++ ")"

barHandler :: forall a. ConstrainedHandler (HasBar a) a
barHandler = ConstrainedHandler $ \x ->
  "(bar-handler " ++ (getBar x) ++ ")"

barMiddleware ::
  forall h a b.
  ConstrainedMiddleware (SetBar a b) h a b
barMiddleware = ConstrainedMiddleware $ \h x ->
  handle h $ setBar x "injectedBarVal"

combinedHandler = composeHandlers fooHandler barHandler

extendedHandler = applyMiddleware barMiddleware combinedHandler


data Config = Config { foo :: String, bar :: String }

data PartialConfig = PartialConfig { foo :: String }

instance HasFoo Config where
  getFoo = foo

instance HasBar Config where
  getBar = bar

class HasBar b => SetBar a b | a -> b where
  setBar :: a -> String -> b

instance SetBar PartialConfig Config where
  setBar (PartialConfig fooVal) barVal = Config { foo = fooVal, bar = barVal }

result = handle extendedHandler $ PartialConfig { foo = "fooVal" }

main :: IO ()
main = putStrLn result