{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
module Database.Record.FromSql (
RecordFromSql, runTakeRecord, runToRecord,
createRecordFromSql,
(<&>),
maybeRecord,
FromSql (recordFromSql),
takeRecord, toRecord,
valueRecordFromSql,
) where
import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), to)
import Control.Applicative ((<$>), Applicative (pure, (<*>)))
import Control.Monad (liftM, ap)
import Database.Record.Persistable (PersistableType)
import qualified Database.Record.Persistable as Persistable
import Database.Record.KeyConstraint
(HasColumnConstraint(columnConstraint), ColumnConstraint, NotNull, index)
newtype RecordFromSql q a = RecordFromSql ([q] -> (a, [q]))
runTakeRecord :: RecordFromSql q a
-> [q]
-> (a, [q])
runTakeRecord :: RecordFromSql q a -> [q] -> (a, [q])
runTakeRecord (RecordFromSql f :: [q] -> (a, [q])
f) = [q] -> (a, [q])
f
createRecordFromSql :: ([q] -> (a, [q]))
-> RecordFromSql q a
createRecordFromSql :: ([q] -> (a, [q])) -> RecordFromSql q a
createRecordFromSql = ([q] -> (a, [q])) -> RecordFromSql q a
forall q a. ([q] -> (a, [q])) -> RecordFromSql q a
RecordFromSql
runToRecord :: RecordFromSql q a
-> [q]
-> a
runToRecord :: RecordFromSql q a -> [q] -> a
runToRecord r :: RecordFromSql q a
r = (a, [q]) -> a
forall a b. (a, b) -> a
fst ((a, [q]) -> a) -> ([q] -> (a, [q])) -> [q] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordFromSql q a -> [q] -> (a, [q])
forall q a. RecordFromSql q a -> [q] -> (a, [q])
runTakeRecord RecordFromSql q a
r
instance Monad (RecordFromSql q) where
return :: a -> RecordFromSql q a
return a :: a
a = ([q] -> (a, [q])) -> RecordFromSql q a
forall q a. ([q] -> (a, [q])) -> RecordFromSql q a
createRecordFromSql ((,) a
a)
ma :: RecordFromSql q a
ma >>= :: RecordFromSql q a -> (a -> RecordFromSql q b) -> RecordFromSql q b
>>= fmb :: a -> RecordFromSql q b
fmb =
([q] -> (b, [q])) -> RecordFromSql q b
forall q a. ([q] -> (a, [q])) -> RecordFromSql q a
createRecordFromSql
(\vals :: [q]
vals -> let (a :: a
a, vals' :: [q]
vals') = RecordFromSql q a -> [q] -> (a, [q])
forall q a. RecordFromSql q a -> [q] -> (a, [q])
runTakeRecord RecordFromSql q a
ma [q]
vals
in RecordFromSql q b -> [q] -> (b, [q])
forall q a. RecordFromSql q a -> [q] -> (a, [q])
runTakeRecord (a -> RecordFromSql q b
fmb a
a) [q]
vals')
instance Functor (RecordFromSql q) where
fmap :: (a -> b) -> RecordFromSql q a -> RecordFromSql q b
fmap = (a -> b) -> RecordFromSql q a -> RecordFromSql q b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative (RecordFromSql q) where
pure :: a -> RecordFromSql q a
pure = a -> RecordFromSql q a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: RecordFromSql q (a -> b) -> RecordFromSql q a -> RecordFromSql q b
(<*>) = RecordFromSql q (a -> b) -> RecordFromSql q a -> RecordFromSql q b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
(<&>) :: RecordFromSql q a -> RecordFromSql q b -> RecordFromSql q (a, b)
a :: RecordFromSql q a
a <&> :: RecordFromSql q a -> RecordFromSql q b -> RecordFromSql q (a, b)
<&> b :: RecordFromSql q b
b = (,) (a -> b -> (a, b))
-> RecordFromSql q a -> RecordFromSql q (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecordFromSql q a
a RecordFromSql q (b -> (a, b))
-> RecordFromSql q b -> RecordFromSql q (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RecordFromSql q b
b
infixl 4 <&>
maybeRecord :: PersistableType q
=> RecordFromSql q a
-> ColumnConstraint NotNull a
-> RecordFromSql q (Maybe a)
maybeRecord :: RecordFromSql q a
-> ColumnConstraint NotNull a -> RecordFromSql q (Maybe a)
maybeRecord rec :: RecordFromSql q a
rec pkey :: ColumnConstraint NotNull a
pkey = ([q] -> (Maybe a, [q])) -> RecordFromSql q (Maybe a)
forall q a. ([q] -> (a, [q])) -> RecordFromSql q a
createRecordFromSql [q] -> (Maybe a, [q])
mayToRec where
mayToRec :: [q] -> (Maybe a, [q])
mayToRec vals :: [q]
vals
| [q]
vals [q] -> Int -> q
forall a. [a] -> Int -> a
!! ColumnConstraint NotNull a -> Int
forall c r. ColumnConstraint c r -> Int
index ColumnConstraint NotNull a
pkey q -> q -> Bool
forall a. Eq a => a -> a -> Bool
/= q
forall q. PersistableType q => q
Persistable.sqlNullValue = (a -> Maybe a
forall a. a -> Maybe a
Just a
a, [q]
vals')
| Bool
otherwise = (Maybe a
forall a. Maybe a
Nothing, [q]
vals') where
(a :: a
a, vals' :: [q]
vals') = RecordFromSql q a -> [q] -> (a, [q])
forall q a. RecordFromSql q a -> [q] -> (a, [q])
runTakeRecord RecordFromSql q a
rec [q]
vals
class FromSql q a where
recordFromSql :: RecordFromSql q a
default recordFromSql :: (Generic a, GFromSql q (Rep a)) => RecordFromSql q a
recordFromSql = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a)
-> RecordFromSql q (Rep a Any) -> RecordFromSql q a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecordFromSql q (Rep a Any)
forall q (f :: * -> *) a. GFromSql q f => RecordFromSql q (f a)
gFromSql
class GFromSql q f where
gFromSql :: RecordFromSql q (f a)
instance GFromSql q U1 where
gFromSql :: RecordFromSql q (U1 a)
gFromSql = ([q] -> (U1 a, [q])) -> RecordFromSql q (U1 a)
forall q a. ([q] -> (a, [q])) -> RecordFromSql q a
createRecordFromSql (([q] -> (U1 a, [q])) -> RecordFromSql q (U1 a))
-> ([q] -> (U1 a, [q])) -> RecordFromSql q (U1 a)
forall a b. (a -> b) -> a -> b
$ (,) U1 a
forall k (p :: k). U1 p
U1
instance (GFromSql q a, GFromSql q b) => GFromSql q (a :*: b) where
gFromSql :: RecordFromSql q ((:*:) a b a)
gFromSql = a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a a -> b a -> (:*:) a b a)
-> RecordFromSql q (a a) -> RecordFromSql q (b a -> (:*:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecordFromSql q (a a)
forall q (f :: * -> *) a. GFromSql q f => RecordFromSql q (f a)
gFromSql RecordFromSql q (b a -> (:*:) a b a)
-> RecordFromSql q (b a) -> RecordFromSql q ((:*:) a b a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RecordFromSql q (b a)
forall q (f :: * -> *) a. GFromSql q f => RecordFromSql q (f a)
gFromSql
instance GFromSql q a => GFromSql q (M1 i c a) where
gFromSql :: RecordFromSql q (M1 i c a a)
gFromSql = a a -> M1 i c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 i c a a)
-> RecordFromSql q (a a) -> RecordFromSql q (M1 i c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecordFromSql q (a a)
forall q (f :: * -> *) a. GFromSql q f => RecordFromSql q (f a)
gFromSql
instance FromSql q a => GFromSql q (K1 i a) where
gFromSql :: RecordFromSql q (K1 i a a)
gFromSql = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a a) -> RecordFromSql q a -> RecordFromSql q (K1 i a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecordFromSql q a
forall q a. FromSql q a => RecordFromSql q a
recordFromSql
instance (HasColumnConstraint NotNull a, FromSql q a, PersistableType q)
=> FromSql q (Maybe a) where
recordFromSql :: RecordFromSql q (Maybe a)
recordFromSql = RecordFromSql q a
-> ColumnConstraint NotNull a -> RecordFromSql q (Maybe a)
forall q a.
PersistableType q =>
RecordFromSql q a
-> ColumnConstraint NotNull a -> RecordFromSql q (Maybe a)
maybeRecord RecordFromSql q a
forall q a. FromSql q a => RecordFromSql q a
recordFromSql ColumnConstraint NotNull a
forall c a. HasColumnConstraint c a => ColumnConstraint c a
columnConstraint
instance FromSql q ()
takeRecord :: FromSql q a => [q] -> (a, [q])
takeRecord :: [q] -> (a, [q])
takeRecord = RecordFromSql q a -> [q] -> (a, [q])
forall q a. RecordFromSql q a -> [q] -> (a, [q])
runTakeRecord RecordFromSql q a
forall q a. FromSql q a => RecordFromSql q a
recordFromSql
toRecord :: FromSql q a => [q] -> a
toRecord :: [q] -> a
toRecord = RecordFromSql q a -> [q] -> a
forall q a. RecordFromSql q a -> [q] -> a
runToRecord RecordFromSql q a
forall q a. FromSql q a => RecordFromSql q a
recordFromSql
valueRecordFromSql :: (q -> a) -> RecordFromSql q a
valueRecordFromSql :: (q -> a) -> RecordFromSql q a
valueRecordFromSql d :: q -> a
d = ([q] -> (a, [q])) -> RecordFromSql q a
forall q a. ([q] -> (a, [q])) -> RecordFromSql q a
createRecordFromSql (([q] -> (a, [q])) -> RecordFromSql q a)
-> ([q] -> (a, [q])) -> RecordFromSql q a
forall a b. (a -> b) -> a -> b
$ \qs :: [q]
qs -> (q -> a
d (q -> a) -> q -> a
forall a b. (a -> b) -> a -> b
$ [q] -> q
forall a. [a] -> a
head [q]
qs, [q] -> [q]
forall a. [a] -> [a]
tail [q]
qs)