Inspired by a Next Level MTL - George Wilson - BFPG 2016-06 talk https://www.youtube.com/watch?v=GZPup5Iuaqw and by Keynote from Lennart Augustsson - Giving Haskell Types to a Relational Algebra Library in C++ https://skillsmatter.com/skillscasts/6683-keynote-from-lennart-augustsson
-- Inspired by a Next Level MTL - George Wilson - BFPG 2016-06 talk | |
-- https://www.youtube.com/watch?v=GZPup5Iuaqw | |
-- | |
-- and by | |
-- | |
-- Keynote from Lennart Augustsson - Giving Haskell Types to a Relational Algebra Library in C++ | |
-- https://skillsmatter.com/skillscasts/6683-keynote-from-lennart-augustsson | |
-- | |
-- | |
-- Different levels of abstraction | |
-- | |
-- Suppose you are writing a dashboard service, with GitHub and YourService | |
-- integrations. The first task is users from GitHub and YourService, merge | |
-- them pairwise for display. | |
-- | |
-- You can load this package into @stack --resolver=lts-6.0 ghci@, | |
-- to see that it type-checks! | |
-- | |
-- You might need to @stack --resolver=lts-6.0 install http-client lens generics-sop@ | |
{-# LANGUAGE DataKinds #-} | |
{-# LANGUAGE FlexibleInstances #-} | |
{-# LANGUAGE FunctionalDependencies #-} | |
{-# LANGUAGE GADTs #-} | |
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
{-# LANGUAGE RankNTypes #-} | |
{-# LANGUAGE ScopedTypeVariables #-} | |
{-# LANGUAGE TypeFamilies #-} | |
{-# LANGUAGE TypeOperators #-} | |
{-# LANGUAGE PolyKinds #-} | |
import Data.Maybe (isJust, fromMaybe) | |
import Data.Text (Text) | |
import Data.Vector (Vector) | |
import Network.HTTP.Client (Manager) | |
import Control.Lens | |
import Control.Monad.Except | |
-- import Control.Monad.IO.Class | |
import Control.Monad.Reader | |
import Control.Monad.State | |
import Generics.SOP | |
import qualified Data.Vector as V | |
------------------------------------------------------------------------------- | |
-- No abstraction: concrete data and functions | |
------------------------------------------------------------------------------- | |
-- | Newtype, for less stringly-typed-programming. | |
newtype GitHubLogin = GitHubLogin Text | |
-- | GitHub user data | |
data GitHubUser = GitHubUser | |
{ ghUserLogin :: !GitHubLogin | |
, ghUserName :: !Text | |
-- .. and other fields | |
} | |
-- | Error type for GitHub requests, invalid requests, json decoding errors, etc. | |
-- You probably want to have a sum type in the real thing. | |
newtype GitHubError = GitHubError Text | |
-- | GitHub authentication token | |
newtype GitHubAuth = GitHubToken Text | |
-- | Github users (let's say in our organisation) | |
githubGetUsers :: Manager -> GitHubAuth -> IO (Either GitHubError (Vector GitHubUser)) | |
githubGetUsers = error "Implementation omitted" | |
-- Similarly for YourService | |
-- | YousService user | |
data YSUser = YSUser | |
{ ysLogin :: !Text | |
, ysGHLogin :: !(Maybe GitHubLogin) | |
, ysName :: !Text | |
-- ... and other fields | |
} | |
-- | And errors. | |
newtype YSError = YSError Text | |
-- | YourService is tricky, as it's a bit stateful. | |
-- It requires you to pass always a larget 'Int' with every request. | |
-- We have no idea why it works that way. | |
newtype YSState = YSState Int | |
incrYSState :: YSState -> YSState | |
incrYSState (YSState n) = YSState (n + 1) | |
-- | We like dollars so much, we have them on the type level! | |
infixr 0 $ | |
type ($) f a = f a | |
-- | YourService users. | |
ysGetUsers :: Manager -> YSState -> IO $ Either YSError $ Vector YSUser | |
ysGetUsers = error "Implementation omitted" | |
-- | Then we need to combine the data: | |
-- | |
-- There is a lot of boilerplate. Actually this whole function is boilerplate! | |
dashboardData | |
:: Manager -> GitHubAuth -> YSState | |
-> IO $ Either (Either GitHubError YSError) $ Vector (GitHubUser, YSUser) | |
dashboardData mgr gauth yss = do | |
ghUsers <- githubGetUsers mgr gauth | |
ysUsers <- ysGetUsers mgr yss | |
case ghUsers of | |
Left err -> return (Left (Left err)) | |
Right ghUsers' -> case ysUsers of | |
Left err -> return (Left (Right err)) | |
Right ysUsers' -> return $ Right $ mergeUsers ghUsers' ysUsers' | |
mergeUsers :: Vector GitHubUser -> Vector YSUser -> Vector (GitHubUser, YSUser) | |
mergeUsers _ _ = error "Implementation omitted, though this is the most interestign part." | |
------------------------------------------------------------------------------- | |
-- The half abstraction: transformers | |
------------------------------------------------------------------------------- | |
-- | Using monad tranformers. | |
-- While it helps when working inside single integration, it doesn't really help when | |
-- we have different ones. | |
-- | |
-- It will help us to carry 'YSState' around, but combining stuff is still difficult. | |
githubGetUsers' :: | |
(ReaderT (Manager, GitHubAuth) $ ExceptT GitHubError $ IO) (Vector GitHubUser) | |
githubGetUsers' = do | |
(mgr, gauth) <- ask | |
lift $ ExceptT $ githubGetUsers mgr gauth | |
-- | Here the transformers are to benefit, as we can carry 'YSState' in | |
-- 'StateT', so we won't forget to increment it. | |
ysGetUsers' :: | |
(ReaderT Manager $ StateT YSState $ ExceptT YSError $ IO) | |
(Vector YSUser) | |
ysGetUsers' = do | |
mgr <- ask | |
yss <- get | |
put (incrYSState yss) | |
lift . lift $ ExceptT $ ysGetUsers mgr yss | |
-- THis can be written using githubGetUsers' and ysGetUsers', Writing one is left as an exercise for the readers. | |
-- My gut feelign says that defining this directly in terms of 'dashboardData' is still simpler, | |
-- so the value of this abstraction is questionable. | |
dashboardData' :: | |
(ReaderT (Manager, GitHubAuth) $ StateT YSState $ ExceptT (Either GitHubError YSError) $ IO) | |
(Vector (GitHubUser, YSUser)) | |
dashboardData' = do | |
(mgr, gauth) <- ask | |
yss <- get | |
put (incrYSState yss) | |
lift . lift $ ExceptT $ dashboardData mgr gauth yss | |
------------------------------------------------------------------------------- | |
-- First abstraction: mtl + lens | |
------------------------------------------------------------------------------- | |
-- We define optics' classes to work with environment and exceptions. | |
-- Then everything will compose quite nicely: | |
class HasManager env where | |
manager :: Lens' env Manager | |
class HasGitHubAuth env where | |
githubAuth :: Lens' env GitHubAuth | |
class HasYSState env where | |
ysstate :: Lens' env YSState | |
class AsGitHubError exc where | |
_GitHubError :: Prism' exc GitHubError | |
instance AsGitHubError GitHubError where | |
_GitHubError = id | |
class AsYSError exc where | |
_YSError :: Prism' exc YSError | |
instance AsYSError YSError where | |
_YSError = id | |
-- This is boilerplate as well, wrapping around 'githubGetUsers'. | |
-- But it will enable us to compose stuff! | |
githubGetUsers'' | |
:: ( MonadReader env m, HasManager env, HasGitHubAuth env | |
, MonadError exc m, AsGitHubError exc | |
, MonadIO m | |
) | |
=> m (Vector GitHubUser) | |
githubGetUsers'' = do | |
mgr <- view manager | |
gauth <- view githubAuth | |
res <- liftIO $ githubGetUsers mgr gauth | |
magicReturn _GitHubError res | |
-- | There must be a better name for this | |
magicReturn :: MonadError exc' m => APrism' exc' exc -> Either exc x -> m x | |
magicReturn p (Left exc) = throwError (clonePrism p # exc) | |
magicReturn _ (Right x) = pure x | |
ysGetUsers'' | |
:: ( MonadReader env m, HasManager env | |
, MonadState s m, HasYSState s | |
, MonadError exc m, AsYSError exc | |
, MonadIO m | |
) | |
=> m (Vector YSUser) | |
ysGetUsers'' = do | |
mgr <- view manager | |
yss <- ysstate <%= incrYSState -- This looks like a magic already! | |
res <- liftIO (ysGetUsers mgr yss) | |
magicReturn _YSError res | |
-- We defined a bunch of boilerplate above. But it starts to pay-off when we | |
-- start to combine stuff. | |
-- | |
-- The only drawback: type-signatures starts to be constraint heavy. Although, | |
-- I first wrote the definition, and let the GHC tell me what constraints I | |
-- need to add. | |
-- | |
-- Also GHC-8.0 will tell which constraints are unncessary, which is useful as | |
-- well. | |
dashboardData'' | |
:: ( MonadIO m | |
, MonadReader env m, HasManager env, HasGitHubAuth env | |
, MonadError exc m, AsYSError exc, AsGitHubError exc | |
, MonadState s m, HasYSState s | |
) | |
=> m (Vector (GitHubUser, YSUser)) | |
dashboardData'' = mergeUsers <$> githubGetUsers'' <*> ysGetUsers'' | |
-- The missing part is a concrete types satisfying @Has@ and @As@ constraints. | |
-- So we could execute this thing. But it's not that hard to write. | |
-- | |
-- This is something where extensible records (and sums!) could be handy. | |
------------------------------------------------------------------------------- | |
-- Second abstraction: classes for services! | |
------------------------------------------------------------------------------- | |
-- We could do even better, and create type-classes for integrations! | |
class Monad m => MonadGitHub m where | |
getGitHubUsers :: m (Vector GitHubUser) | |
-- | Example, you might need this in your business logic | |
catchGitHubError :: m a -> (GitHubError -> m a) -> m a | |
class Monad m => MonadYS m where | |
getYsUsers :: m (Vector YSUser) | |
-- The definition is still simple, but now also the constraints. | |
dashboardData''' :: (MonadGitHub m, MonadYS m) => m (Vector (GitHubUser, YSUser)) | |
dashboardData''' = mergeUsers <$> getGitHubUsers <*> getYsUsers | |
-- And we can reuse lower abstraction to write an interpreter for this combination. | |
newtype GHYSM (env :: *) (exc :: *) (s :: *) m a = GHYSM { runGHYSM :: m a } | |
deriving (Functor, Applicative, Monad, MonadError exc) | |
instance | |
( MonadReader env m, HasManager env, HasGitHubAuth env | |
, MonadError exc m, AsGitHubError exc | |
, MonadIO m | |
) | |
=> MonadGitHub (GHYSM env exc s m) where | |
getGitHubUsers = GHYSM githubGetUsers'' | |
-- This might be required, if we want to recover from some business errors | |
-- in the business logic. | |
catchGitHubError m handler = catchError m handler' | |
where | |
handler' = either throwError handler . matching _GitHubError | |
instance | |
( MonadReader env m, HasManager env | |
, MonadState s m, HasYSState s | |
, MonadError exc m, AsYSError exc | |
, MonadIO m | |
) | |
=> MonadYS (GHYSM env exc s m) where | |
getYsUsers = GHYSM ysGetUsers'' | |
interpret | |
:: ( MonadIO m | |
, MonadReader env m, HasManager env, HasGitHubAuth env | |
, MonadError exc m, AsYSError exc, AsGitHubError exc | |
, MonadState s m, HasYSState s | |
) | |
=> (forall n. (MonadGitHub n, MonadYS n) => n a) | |
-> m a | |
interpret = runGHYSM | |
-- But you are free to write 'interpret' using 'Haxl' monad, or similar "super | |
-- monad". You could have @getGitHubUsers :: Haxl (Vector GitHub User)@, but | |
-- that is too general definition. Almost as bad as having @getGitHubUsers :: | |
-- IO (Vector GitHubUsers)@ which reads environment from @IOVar@ and throws | |
-- @Exception@s. | |
-- | |
-- Or you can use extensible effects approach, as integrations monads | |
-- transformers if written could be swapped, i.e. @GithubT (YST m) a ~ YST | |
-- (GitHubT m) a@ | |
------------------------------------------------------------------------------- | |
-- Level three: relations (DSL) | |
------------------------------------------------------------------------------- | |
-- Let's recap: we are building dashboards by fetching data from numerous | |
-- services, and then combining them. | |
-- | |
-- For this purpose we could write a DSL so we state only what data we need, | |
-- and how we combine them. | |
class Record fields a | a -> fields where | |
fields :: NP ((->) a) fields | |
instance Record '[GitHubLogin] GitHubUser where | |
fields = ghUserLogin :* Nil | |
-- | The very concrete definition, a value and a function how to indice values. | |
-- More clever interpretation could encode how to get the @a@, not the value | |
-- itself. Also the mapping to indices could have inspectable form, so we can | |
-- use this information to make more efficient queries. | |
data Rel fields a = Rel (NP ((->) a) fields) (Vector a) | |
toRel :: Record fields a => Vector a -> Rel fields a | |
toRel xs = Rel fields xs | |
-- Using above framework we could have generic way to work with relational data: | |
-- This functions work on the first field of relation, but could be extended further: | |
filterNothing :: Rel (Maybe a ': xs) a -> Rel (a ': xs) a | |
filterNothing (Rel fs xs) = case fs of | |
f :* fs' -> | |
-- | Here we know that fromMaybe should be safe to do. | |
let fields' = fromMaybe (error "panic: filterNothing inconsistent") . f :* fs' | |
xs' = V.filter (isJust . f) xs | |
in Rel fields' xs' | |
innerJoin :: Rel (x ': ys) a -> Rel (x ': zs) b -> Rel (x ': ys ++ zs) (a, b) | |
innerJoin = error "left as an exercise" | |
type family (++) as bs where | |
(++) '[] bs = bs | |
(++) (a ': as) bs = a ': (as ++ bs) | |
-- If our implementation of 'Rel' and its combinators is smart enough, | |
-- that it could e.g. directly query from YourService only users with non-empty | |
-- GitHubLogin, our dashboard would be even more performant. | |
-- | |
-- Of course for the implementation of actual data fatching we could use | |
-- any 'MonadYS', so we build on top of previous abstractions. | |
------------------------------------------------------------------------------- | |
-- Conclusion | |
------------------------------------------------------------------------------- | |
-- The more business logic you have, the more obvious it will be to use higher | |
-- abstraction level. For a single throw-away script no-abstractions is | |
-- probably sufficient. OTOH when you have numerous integrations, and the size | |
-- of the business logic code starts to dominate, it starts to pay off to move | |
-- the boilerplate down by using higher abstractions levels. Which one, it | |
-- depends. |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment