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

abstraction-evolution.hs

-- 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.