Free Type-Level CRUD

free-type-level-crud.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}

module Main where

import Control.Monad.Free (Free (Free, Pure))
import Control.Monad.Identity (Identity)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ask, ReaderT)

-- | wherein I play with type families and do some absurd / bad things.
-- big thanks to @acid2's talk: https://ocharles.org.uk/talk.pdf

-- | The main idea here is that we have some data types and need to do some CRUD on them. 
-- in our application we'd just like to say "get this type, update it with this value,
-- delete this other type..." yadda yadda. Then, at run time, we'd like to plug it together
-- for some arbitrary backend.
-- 
-- Unfortunately, some backends may required different data to creating a specific type.
-- For example, to create an Account using my REST service, I made just need to specify
-- a serialized JSON blob, but to create it in my database, I want a tuple with some
-- additional values. 
--
-- So, we create a CRUD algebra and index the kinds of types required to CRUD our data
-- using type families and datakinds.
--
-- at least this is what I think i'm doing! :)

-- | Some data types we want to do CRUD on
data Account = Account String
data Application = Application String String

-- | Crudable data types. Used for our singleton types.
data Crudable = AccountCRUD
              | ApplicationCRUD

-- | GADT for crudable types
data SCrudable (c :: Crudable) where
    SAccountCRUD     :: SCrudable 'AccountCRUD
    SApplicationCRUD :: SCrudable 'ApplicationCRUD

-- | Various interfaces we do CRUD over.
data Interface = PureI
               | HTTPI
               | SQLI
               | IOI

-- | GADT for interfaces
data SInterface (i :: Interface) where
    SPure :: SInterface 'PureI
    SHTTP :: SInterface 'HTTPI
    SSQL  :: SInterface 'SQLI
    SIO   :: SInterface 'IOI

-- | type familiy that maps a Crudable type to its type
type family CrudType (crudable :: Crudable) :: * where
    CrudType 'AccountCRUD     = Account
    CrudType 'ApplicationCRUD = Application

-- | type family that maps interfaces to the types of monads
-- they run in.
type family IMonad (interface :: Interface) :: * -> * where
    IMonad 'PureI = Identity
    IMonad 'HTTPI = IO
    IMonad 'SQLI  = IO
    IMonad 'IOI   = IO

-- | type family that mapping: (Crudable Type) X (Interface) -> required data
-- type to use interface. usually this is some kind of data type to hold values
-- which you pass to your backend.
type family CreateData (crudable :: Crudable) (interface :: Interface) :: * where
    CreateData 'AccountCRUD     'PureI = Int
    CreateData 'AccountCRUD     'HTTPI = String
    CreateData 'AccountCRUD     'SQLI  = (String, String)
    CreateData 'AccountCRUD     'IOI   = String
    CreateData 'ApplicationCRUD 'PureI = Int
    CreateData 'ApplicationCRUD 'HTTPI = (String, String)
    CreateData 'ApplicationCRUD 'SQLI  = (String, String, String, String)
    CreateData 'ApplicationCRUD 'IOI   = String

-- | type family mapping: (Crudable Type) X (Interface) -> required data type
-- to `get`. Usually this is some kind of identifier
type family ReadData (crudable :: Crudable) (interface :: Interface) :: * where
    ReadData 'AccountCRUD     'PureI = Int
    ReadData 'AccountCRUD     'HTTPI = Int
    ReadData 'AccountCRUD     'SQLI  = Int
    ReadData 'AccountCRUD     'IOI   = Int
    ReadData 'ApplicationCRUD 'PureI = Int
    ReadData 'ApplicationCRUD 'HTTPI = Int
    ReadData 'ApplicationCRUD 'SQLI  = Int
    ReadData 'ApplicationCRUD 'IOI   = Int

-- | type family mapping: (Crudable Type) X (Interface) -> required data type
-- to update data. usually this is some kind of identifier
type family UpdateData (crudable :: Crudable) (interface :: Interface) :: * where
    UpdateData 'AccountCRUD     'PureI = Int
    UpdateData 'AccountCRUD     'HTTPI = Int
    UpdateData 'AccountCRUD     'SQLI  = Int
    UpdateData 'AccountCRUD     'IOI   = Int
    UpdateData 'ApplicationCRUD 'PureI = Int
    UpdateData 'ApplicationCRUD 'HTTPI = (Int, Int)
    UpdateData 'ApplicationCRUD 'SQLI  = Int
    UpdateData 'ApplicationCRUD 'IOI   = Int

-- | type family mapping: (Crudable Type) X (Interface) -> required data type
-- to delete data. usually this is some kind of identifier
type family DeleteData (crudable :: Crudable) (interface :: Interface) :: * where
    DeleteData 'AccountCRUD     'PureI = Int
    DeleteData 'AccountCRUD     'HTTPI = Int
    DeleteData 'AccountCRUD     'SQLI  = Int
    DeleteData 'AccountCRUD     'IOI   = Int
    DeleteData 'ApplicationCRUD 'PureI = Int
    DeleteData 'ApplicationCRUD 'HTTPI = Int
    DeleteData 'ApplicationCRUD 'SQLI  = Int
    DeleteData 'ApplicationCRUD 'IOI   = Int

-- | CRUD algebra.
data CrudF c i x = CreateF (CreateData c i) (CrudType c -> x)
                 -- | ReadF   (ReadData c i) (CrudType c -> x)
                 -- | UpdateF (UpdateData c i) x
                 -- | DeleteF (DeleteData c i) x
                 deriving (Functor)

-- | smart constructor for `create`
create :: SCrudable c
       -> ReaderT (SInterface i,  CreateData c i)
                  (Free (CrudF c i))
                  (CrudType c)
create _ = do
    (_,d) <- ask
    lift . Free $ CreateF d Pure

-- | an interpreter that does arbitrary IO
ioInterpreter :: SCrudable c
              -> Free (CrudF c 'IOI) a
              -> (IMonad 'IOI) a
ioInterpreter SAccountCRUD inst = case inst of
    Free (CreateF _ g) -> do
        print "io!"
        ioInterpreter SAccountCRUD . g $ Account "io"
    Pure a -> return a
ioInterpreter SApplicationCRUD inst = case inst of
    Free (CreateF _ g) -> do
        print "io!"
        ioInterpreter SApplicationCRUD . g $ Application "fake" "fake"
    Pure a -> return a

-- | full interpreter (exhausting!)
interpreter :: SInterface i
            -> SCrudable c
            -> Free (CrudF c i) a
            -> (IMonad i) a
interpreter SPure SAccountCRUD     inst = case inst of
    Free (CreateF _ g) ->
        interpreter SPure SAccountCRUD . g $ Account "fake"
    Pure a -> return a
interpreter SHTTP SAccountCRUD     inst = case inst of
    Free (CreateF _ g) -> do
        print "CREATE http:account"
        interpreter SHTTP SAccountCRUD . g $ Account "fake"
    Pure a -> return a
interpreter SSQL  SAccountCRUD     inst = case inst of
    Free (CreateF _ g) -> do
        print "CREATE sql:account"
        interpreter SSQL SAccountCRUD . g $ Account "fake"
    Pure a -> return a
interpreter SIO   SAccountCRUD     inst = case inst of
    Free (CreateF _ g) -> do
        print "CREATE io:account"
        interpreter SIO SAccountCRUD . g $ Account "fake"
    Pure a -> return a
interpreter SPure SApplicationCRUD inst = case inst of
    Free (CreateF _ g) -> 
        interpreter SPure SApplicationCRUD . g  $ Application "fake" "fake"
    Pure a -> return a
interpreter SHTTP SApplicationCRUD inst = case inst of
    Free (CreateF _ g) -> do
        print "CREATE http:application"
        interpreter SHTTP SApplicationCRUD . g $ Application "fake" "fake"
    Pure a -> return a
interpreter SSQL  SApplicationCRUD inst = case inst of
    Free (CreateF _ g) -> do
        print "CREATE sql:application"
        interpreter SSQL SApplicationCRUD . g $ Application "fake" "fake"
    Pure a -> return a
interpreter SIO   SApplicationCRUD inst = case inst of
    Free (CreateF _ g) -> do
        print "CREATE io:application"
        interpreter SIO SApplicationCRUD . g $ Application "fake" "fake"
    Pure a -> return a

main :: IO ()
main = print "hi"