module Database.PostgreSQL.Store.Tuple (
Tuple (..),
appendElement,
HasElement,
getElementN,
getElement0,
getElement1,
getElement2,
getElement3,
getElement4,
getElement5,
getElement6,
getElement7,
getElement8,
getElement9,
FunctionType,
WithTuple,
withTuple
) where
import GHC.TypeLits
import Data.List
import Data.Kind
import Data.Tagged
type family (|>) (x :: [a]) (y :: a) :: [a] where
'[] |> y = '[y]
(x ': xs) |> y = x ': (xs |> y)
infixl 5 |>
data Tuple (ts :: [Type]) where
Empty :: Tuple '[]
Cons :: t -> !(Tuple ts) -> Tuple (t ': ts)
class ShowElement ts where
gatherShown :: Tuple ts -> [String]
instance ShowElement '[] where
gatherShown _ = []
instance (Show t, ShowElement ts) => ShowElement (t ': ts) where
gatherShown (Cons x rest) = show x : gatherShown rest
instance (ShowElement ts) => Show (Tuple ts) where
show params = concat ["(", intercalate ", " (gatherShown params), ")"]
class HasElement (n :: Nat) (ts :: [Type]) r | n ts -> r where
getElementN :: Tuple ts -> Tagged n r
instance HasElement 0 (t ': ts) t where
getElementN (Cons x _) = Tagged x
instance (1 <= n, HasElement (n 1) ts r) => HasElement n (t ': ts) r where
getElementN (Cons _ !xs) = retag (getElementN xs :: Tagged (n 1) r)
getElement0 :: Tuple (r ': ts) -> r
getElement0 p = untag (getElementN @0 p)
getElement1 :: Tuple (t0 ': r ': ts) -> r
getElement1 p = untag (getElementN @1 p)
getElement2 :: Tuple (t0 ': t1 ': r ': ts) -> r
getElement2 p = untag (getElementN @2 p)
getElement3 :: Tuple (t0 ': t1 ': t2 ': r ': ts) -> r
getElement3 p = untag (getElementN @3 p)
getElement4 :: Tuple (t0 ': t1 ': t2 ': t3 ': r ': ts) -> r
getElement4 p = untag (getElementN @4 p)
getElement5 :: Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': r ': ts) -> r
getElement5 p = untag (getElementN @5 p)
getElement6 :: Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': r ': ts) -> r
getElement6 p = untag (getElementN @6 p)
getElement7 :: Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': r ': ts) -> r
getElement7 p = untag (getElementN @7 p)
getElement8 :: Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': t7 ': r ': ts) -> r
getElement8 p = untag (getElementN @8 p)
getElement9 :: Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': t7 ': t8 ': r ': ts) -> r
getElement9 p = untag (getElementN @9 p)
class AppendElement ts where
appendElement :: Tuple ts -> t -> Tuple (ts |> t)
instance AppendElement '[] where
appendElement = flip Cons
instance (AppendElement ts) => AppendElement (t ': ts) where
appendElement (Cons y ys) x = Cons y (appendElement ys x)
class ConsTuple ts a r | ts r -> a where
consTuple :: Tuple ts -> a -> r
instance ConsTuple ts (Tuple ts -> r) r where
consTuple state f = f state
instance (AppendElement ts, ConsTuple (ts |> t) a r) => ConsTuple ts a (t -> r) where
consTuple state val x = consTuple (appendElement state x) val
type family FunctionType (ps :: [Type]) r where
FunctionType '[] r = r
FunctionType (p ': ps) r = p -> FunctionType ps r
type WithTuple ts r = ConsTuple '[] (Tuple ts -> r) (FunctionType ts r)
withTuple :: (WithTuple ts r) => (Tuple ts -> r) -> FunctionType ts r
withTuple = consTuple Empty