Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
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
You can’t perform that action at this time.