{-# LANGUAGE ScopedTypeVariables, TypeFamilies, MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators, UndecidableInstances, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts, RankNTypes, AllowAmbiguousTypes, GADTs #-}
{-# LANGUAGE DeriveGeneric, CPP #-}
module Database.Selda.Selectors
( Assignment ((:=)), Selected, Selector, Source, Selectors, GSelectors
, (!), with, ($=)
, selectorsFor, selectorIndex, unsafeSelector
) where
import Control.Monad.State.Strict
import Database.Selda.SqlRow (SqlRow)
import Database.Selda.SqlType
import Database.Selda.Types
import Database.Selda.Column
import Data.List (foldl')
import Data.Proxy
import GHC.Generics hiding (Selector, (:*:))
import qualified GHC.Generics as G
import Unsafe.Coerce
type family Selected a b where
Selected (Maybe a) (Maybe b) = Maybe b
Selected (Maybe a) b = Maybe b
Selected a b = b
type family Source a where
Source (Maybe a) = a
Source a = a
unsafeSelector :: SqlRow a => Int -> Selector a b
unsafeSelector = Selector
(!) :: SqlType b => Row s a -> Selector (Source a) b -> Col s (Selected a b)
(Many xs) ! (Selector i) = case xs !! i of Untyped x -> One (unsafeCoerce x)
upd :: Row s a -> Assignment s a -> Row s a
upd (Many xs) (Selector i := (One x')) =
case splitAt i xs of
(left, _:right) -> Many (left ++ Untyped x' : right)
_ -> error "BUG: too few columns in row!"
upd (Many xs) (Modify (Selector i) f) =
case splitAt i xs of
(left, Untyped x:right) -> Many (left ++ f' (unsafeCoerce x) : right)
_ -> error "BUG: too few columns in row!"
where
f' x = case f (One x) of
One y -> Untyped y
data Assignment s a where
#if MIN_VERSION_base(4, 9, 0)
#endif
(:=) :: Selector t a -> Col s a -> Assignment s t
#if MIN_VERSION_base(4, 9, 0)
#endif
Modify :: Selector t a -> (Col s a -> Col s a) -> Assignment s t
infixl 2 :=
($=) :: Selector t a -> (Col s a -> Col s a) -> Assignment s t
($=) = Modify
infixl 2 $=
with :: Row s a -> [Assignment s a] -> Row s a
with = foldl' upd
newtype Selector t a = Selector {selectorIndex :: Int}
selectorsFor :: forall r. GSelectors r (Rep r) => Proxy r -> Selectors r
selectorsFor = flip evalState 0 . mkSel (Proxy :: Proxy (Rep r))
type Selectors r = Sels r (Rep r)
type family Sels t f where
Sels t ((a G.:*: b) G.:*: c) = Sels t (a G.:*: (b G.:*: c))
Sels t (a G.:*: b) = Sels t a :*: Sels t b
Sels t (M1 x y f) = Sels t f
Sels t (K1 i a) = Selector t a
class GSelectors t (f :: * -> *) where
mkSel :: Proxy f -> Proxy t -> State Int (Sels t f)
instance SqlType a => GSelectors t (K1 i a) where
mkSel _ _ = Selector <$> state (\n -> (n, n+1))
instance (GSelectors t f, Sels t f ~ Sels t (M1 x y f)) =>
GSelectors t (M1 x y f) where
mkSel _ = mkSel (Proxy :: Proxy f)
instance GSelectors t (a G.:*: (b G.:*: c)) =>
GSelectors t ((a G.:*: b) G.:*: c) where
mkSel _ = mkSel (Proxy :: Proxy (a G.:*: (b G.:*: c)))
instance {-# OVERLAPPABLE #-}
( GSelectors t a
, GSelectors t b
, Sels t (a G.:*: b) ~ (Sels t a :*: Sels t b)
) => GSelectors t (a G.:*: b) where
mkSel _ p = do
x <- mkSel (Proxy :: Proxy a) p
xs <- mkSel (Proxy :: Proxy b) p
return (x :*: xs)