haskelltemplate-haskellopaleye

Declaring an Opaleye table without using TemplateHaskell


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.


Solution

  • 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"