Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {-# 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
Add Comment
Please, Sign In to add comment