ToRow and FromRow with GHC.Generics

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
{-# LANGUAGE DeriveGeneric, TypeOperators, FlexibleContexts #-}
module GenFromRow where

import GHC.Generics
import Data.Text (Text)
import Control.Applicative
import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow
import Database.SQLite.Simple.FromField
import Database.SQLite.Simple.ToRow
import Database.SQLite.Simple.ToField

type ISBN = Integer

data Book = Book
  { bookTitle :: Text
  , bookAuthor :: Text
  , bookISBN :: ISBN
  , bookPublishYear :: Int
  }
  deriving (Generic, Read, Show, Eq)

instance FromRow Book where fromRow = genericFromRow
instance ToRow   Book where toRow   = genericToRow

------------------------------------------------------------------------
-- Generics implementation of FromRow
------------------------------------------------------------------------

genericFromRow :: (Generic a, GFromRow (Rep a)) => RowParser a
genericFromRow = fmap to gfromRow

class                                GFromRow f          where gfromRow :: RowParser (f a)
instance FromField a              => GFromRow (K1 i a)   where gfromRow = fmap K1 field
instance (GFromRow f, GFromRow g) => GFromRow (f :*: g)  where gfromRow = liftA2 (:*:) gfromRow gfromRow
instance GFromRow f               => GFromRow (M1 i c f) where gfromRow = fmap M1 gfromRow
instance                             GFromRow U1         where gfromRow = pure U1

------------------------------------------------------------------------
-- Generics implementation of ToRow
------------------------------------------------------------------------

genericToRow :: (Generic a, GToRow (Rep a)) => a -> [SQLData]
genericToRow = gtoRow . from

class                            GToRow f          where gtoRow           :: f a -> [SQLData]
instance ToField a            => GToRow (K1 i a)   where gtoRow (K1 x)    = [toField x]
instance (GToRow f, GToRow g) => GToRow (f :*: g)  where gtoRow (x :*: y) = gtoRow x ++ gtoRow y
instance GToRow f             => GToRow (M1 i c f) where gtoRow (M1 x)    = gtoRow x
instance                         GToRow U1         where gtoRow U1        = []