Created
July 11, 2016 15:15
-
-
Save phadej/fedba3ca4492296af61726be7a8a028c to your computer and use it in GitHub Desktop.
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
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- 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