Skip to content

Instantly share code, notes, and snippets.

@kosmikus kosmikus/HasqlSOP.hs
Created Nov 24, 2016

Embed
What would you like to do?
Generically derive hasql encoders and decoders using generics-sop (proof of concept)
{-# 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
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.