Generically derive hasql encoders and decoders using generics-sop (proof of concept)

HasqlSOP.hs

{-# LANGUAGE DataKinds, TypeFamilies, FlexibleContexts, ScopedTypeVariables, TypeOperators, DefaultSignatures  #-}
{-# LANGUAGE OverloadedStrings, DeriveGeneric #-}
module HasqlSOP where

import Data.Functor.Contravariant
import qualified Data.Map as M
import Data.Text
import Generics.SOP
import qualified GHC.Generics as GHC
import qualified Hasql.Encoders as E
import qualified Hasql.Decoders as D

-- Generic encoder

class HasEValue a where
  mkEValue :: E.Params a

class HasParams a where
  mkParams :: E.Params a
  default mkParams :: (Generic a, Code a ~ '[ xs ], All HasEValue xs) => E.Params a
  mkParams = gParams

gParams :: (Generic a, Code a ~ '[ xs ], All HasEValue xs) => E.Params a
gParams =
  contramap (unZ . unSOP . from)
    (mconcat $ hcollapse
      (hcmap (Proxy :: Proxy HasEValue)
         (\ (Fn p) -> K (contramap (unI . p . K) mkEValue))
         projections
      )
    )

-- Generic decoder

class HasDValue a where
  mkDValue :: D.Row a

class HasRow a where
  mkRow :: D.Row a
  default mkRow :: (Generic a, Code a ~ '[ xs ], All HasDValue xs) => D.Row a
  mkRow = gRow

gRow :: (Generic a, Code a ~ '[ xs ], All HasDValue xs) => D.Row a
gRow =
  to . SOP . Z <$> hsequence (hcpure (Proxy :: Proxy HasDValue) mkDValue)

-- Generic definition of HasEValue and HasDValue for enumeration types

gEValue :: (Generic a, All ((~) '[]) (Code a)) => NP (K Text) (Code a) -> E.Params a
gEValue names =
  E.value (contramap (hcollapse . hzipWith const names . unSOP . from) E.text)

gDValue :: (Generic a, All ((~) '[]) (Code a)) => NP (K Text) (Code a) -> D.Row a
gDValue names =
  D.value D.text >>= \ n -> case M.lookup n table of
    Nothing -> fail "unknown constructor"
    Just v  -> return v
  where
    table =
      M.fromList
        (hcollapse
          (hczipWith (Proxy :: Proxy ((~) '[]))
            (\ (K n) (Fn c) -> K (n, to (SOP (unK (c Nil)))))
            names injections
          )
        )

-- Example from the docs

instance HasEValue Int where
  mkEValue = contramap fromIntegral (E.value E.int8)

instance HasEValue Text where
  mkEValue = E.value E.text

instance HasDValue Int where
  mkDValue = fmap fromIntegral (D.value D.int8)

instance HasDValue Text where
  mkDValue = D.value D.text

data Person =
  Person { name :: Text, gender :: Gender, age :: Int }
  deriving (GHC.Generic)

data Gender =
  Male | Female
  deriving (GHC.Generic)

-- We could compute these automatically from the constructor names
genderNames :: NP (K Text) (Code Gender)
genderNames = K "male" :* K "female" :* Nil

instance Generic Person
instance Generic Gender

instance HasEValue Gender where
  mkEValue = gEValue genderNames

instance HasDValue Gender where
  mkDValue = gDValue genderNames

instance HasParams Person
instance HasRow Person