HLists in postgresql-simple

pghlist.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.HList (
  HList(..)
, All
, HLFun
, feed
, Sing(..)
, SingI(..)
) where

import Control.Applicative
import Database.PostgreSQL.Simple.FromField
import Database.PostgreSQL.Simple.FromRow
import GHC.Exts (Constraint)


infixr 5 :::

data HList (xs :: [*]) where
  HNil :: HList '[]
  (:::) :: x -> HList xs -> HList (x ': xs)

type family All (c :: * -> Constraint) (xs :: [*]) :: Constraint
type instance All c '[] = ()
type instance All c (x ': xs) = (c x, All c xs)

instance All Eq xs => Eq (HList xs) where
  HNil == HNil = True
  (x ::: xs) == (y ::: ys) = x == y && xs == ys
  _ == _ = False

instance All Show xs => Show (HList xs) where
  show HNil = "HNil"
  show (x ::: xs) = show x ++ " ::: " ++ show xs

type family HLFun (xs :: [*]) (r :: *) :: *
type instance HLFun '[] r = r
type instance HLFun (x ': xs) r = x -> HLFun xs r

feed :: HList xs -> HLFun xs r -> r
feed HNil r = r
feed (x ::: xs) r = feed xs (r x)

data Sing (xs :: [*]) where
  SNil :: Sing '[]
  SCons :: Sing xs -> Sing (x ': xs)

class SingI (xs :: [*]) where
  sing :: Sing xs

instance SingI '[] where
  sing = SNil

instance SingI xs => SingI (x ': xs) where
  sing = SCons sing

fromRowImpl :: All FromField xs => Sing xs -> RowParser (HList xs)
fromRowImpl SNil = return HNil
fromRowImpl (SCons xs) = (:::) <$> field <*> fromRowImpl xs

instance (All FromField xs, SingI xs) => FromRow (HList xs) where
  fromRow = fromRowImpl sing