Declaring an Opaleye table without using TemplateHaskell

121 views Asked by At

The opaleye basic tutorial gives an example on how to use user defined types in record types and queries:

data Birthday' a b = Birthday { bdName :: a, bdDay :: b }
type Birthday = Birthday' String Day
type BirthdayColumn = Birthday' (Column PGText) (Column PGDate)

birthdayTable :: Table BirthdayColumn BirthdayColumn
birthdayTable = table "birthdayTable"
    (pBirthday Birthday { bdName = tableColumn "name"
                        , bdDay  = tableColumn "birthday" })

Function pBirthday is generated using TemplateHaskell:

 $(makeAdaptorAndInstance "pBirthday" ''Birthday')

Where makeAdaptorAndInstance is a defined in Data.Functor.Product.TH.

I would like to avoid using TemplateHaskell. The opaleye tutorial simply refers to the documentation of Data.Functor.Product.TH, which only explains that the instances generated by makeAdaptorAndInstance will be:

instance (ProductProfunctor p, Default p a a', Default p b b', Default p c c')
  => Default p (Birthday a b c) (Birthday a' b' c')

and pBirthday will have the type:

pBirthday :: ProductProfunctor p =>
    Birthday (p a a') (p b b') (p c c') -> p (Birthday a b c) (Birthday a' b' c')

But I cannot find any information on how to fill implement these functions by hand.

1

There are 1 answers

2
Li-yao Xia On BEST ANSWER

GHC has a -ddump-splices option to see the code generated with TH. I think that should be useful as it probably doesn't look too bad. (With -ddump-to-file and -dumpdir to control the output location.)

Here's one way to write it:

instance (ProductProfunctor p, Default p a a', Default p b b') => Default p (Birthday' a b) (Birthday' a' b') where
  def :: p (Birthday' a b) (Birthday' a' b')
  def = pBirthday (Birthday def def)


pBirthday :: ProductProfunctor p =>
  Birthday' (p a a') (p b b') -> p (Birthday a b) (Birthday a' b')
pBirthday (Birthday pa pb) =
  Birthday `rmap` lmap bdName pa **** lmap bdDay pb
  -- It generalizes the applicative construct
  --   "Birthday <$> pa <*> pb"