Free CRUD as a library

finally_crud.hs

-- | at the end of this post (http://aaronlevin.ca/post/106721413033/type-families-make-life-and-free-monads-simpler) I conjectured
-- if it would be possible to expose the Free Crud monad as a library (for some definition of the term). Thanks to a huge help
-- from @a_cowley, I think I'm converging on an idea. All the hard stuff was suggested to me by anthony!

-- | kitchen sink of extensions

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module FreeCrud where

import Control.Monad.Free(Free(Free, Pure))

-- the library portion is below

-- | type checking support, thanks to @a_cowley
data Elem (x :: k) (xs :: [k]) where
    Here :: Elem x (x ': xs)
    There :: Elem x xs -> Elem x (y ': xs)

class Implicit a where
    implicitly :: a

instance Implicit (Elem x (x ': xs)) where
    implicitly = Here

instance Implicit (Elem x xs) => Implicit (Elem x (y ': xs)) where
    implicitly = There implicitly

type IElem x xs = Implicit (Elem x xs)

-- | Index of types that can be crudded / singleton support
data family CrudSing :: k -> *

-- | crud verbs used to collapse `CrudF` to a single constructor
data CRUD = Create | Read | Update | Delete
data CrudVerb (a :: CRUD) :: * where
    SCreate :: CrudVerb 'Create
    SRead   :: CrudVerb 'Read
    SUpdate :: CrudVerb 'Update
    SDelete :: CrudVerb 'Delete

-- | open type families to index data types
type family InputData  (v :: CRUD) (a :: k) :: *
type family ReturnData (v :: CRUD) (a :: k) :: *

-- | The new CrudF functor
data CrudF :: [k] -> * -> * where
    CrudF :: IElem f fs
          => CrudVerb v
          -> CrudSing f
          -> InputData v f
          -> (ReturnData v f -> a)
          -> CrudF fs a

-- | functor instance
instance Functor (CrudF fs) where
   fmap f (CrudF v s i g) = CrudF v s i (f . g)

-- | sample smart constructor
create :: IElem f fs
       => CrudVerb g
       -> CrudSing f
       -> InputData g f
       -> Free (CrudF fs) (ReturnData g f)
create v s d = Free $ CrudF v s d Pure

-- | User code

data Product = Product
data ProductData = ProductData Int
data Order = Order
data OrderData = OrderData

-- | index of crudable types
data MyCrud = ProductCRUD | OrderCRUD

-- | data family instance
data instance CrudSing (a :: MyCrud) where
    SProduct :: CrudSing ProductCRUD
    SOrder   :: CrudSing OrderCRUD

-- | type family defs
type instance InputData  'Create ProductCRUD = ProductData
type instance InputData  'Read   ProductCRUD = Product
type instance InputData  'Update ProductCRUD = Product
type instance InputData  'Delete ProductCRUD = Int
type instance ReturnData 'Create ProductCRUD = Product
type instance ReturnData 'Read   ProductCRUD = Product
type instance ReturnData 'Update ProductCRUD = Product
type instance ReturnData 'Delete ProductCRUD = Product

type instance InputData  'Create OrderCRUD = OrderData
type instance InputData  'Read   OrderCRUD = Order
type instance InputData  'Update OrderCRUD = Order
type instance InputData  'Delete OrderCRUD = Int
type instance ReturnData 'Create OrderCRUD = Order
type instance ReturnData 'Read   OrderCRUD = Order
type instance ReturnData 'Update OrderCRUD = Order
type instance ReturnData 'Delete OrderCRUD = Order

-- | sample smart(er) constructor
createProduct :: ProductData -> Free (CrudF '[ProductCRUD, OrderCRUD]) Product
createProduct = create SCreate SProduct

-- | sample, non-exhaustive interpreter
interpreter :: Free (CrudF '[ProductCRUD, OrderCRUD]) a -> IO a
interpreter (Pure a) = return a
interpreter (Free (CrudF SCreate SProduct (ProductData _) g)) = interpreter $ g Product
interpreter (Free (CrudF SCreate SOrder _ g)) = interpreter $ g Order