{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
module Opaleye.SQLite.Internal.RunQuery where
import Control.Applicative (Applicative, pure, (<$>), (<*>), liftA2)
import Database.SQLite.Simple.Internal (RowParser)
import Database.SQLite.Simple.FromField (FieldParser, FromField,
fromField)
import qualified Database.SQLite.Simple.Internal as SSI
import Database.SQLite.Simple.FromRow (fieldWith)
import qualified Database.SQLite3 as SQLiteBase
import Opaleye.SQLite.Column (Column)
import Opaleye.SQLite.Internal.Column (Nullable)
import qualified Opaleye.SQLite.Internal.PackMap as PackMap
import qualified Opaleye.SQLite.Column as C
import qualified Opaleye.SQLite.Internal.Unpackspec as U
import qualified Opaleye.SQLite.PGTypes as T
import qualified Data.Profunctor as P
import Data.Profunctor (dimap)
import qualified Data.Profunctor.Product as PP
import Data.Profunctor.Product (empty, (***!))
import qualified Data.Profunctor.Product.Default as D
import qualified Data.Text as ST
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as SBS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Time as Time
import GHC.Int (Int64)
data QueryRunnerColumn sqlType haskellType =
QueryRunnerColumn (U.Unpackspec (Column sqlType) ()) (FieldParser haskellType)
data QueryRunner columns haskells =
QueryRunner (U.Unpackspec columns ())
(columns -> RowParser haskells)
(columns -> Bool)
fieldQueryRunnerColumn :: FromField haskell => QueryRunnerColumn coltype haskell
fieldQueryRunnerColumn :: QueryRunnerColumn coltype haskell
fieldQueryRunnerColumn =
Unpackspec (Column coltype) ()
-> FieldParser haskell -> QueryRunnerColumn coltype haskell
forall sqlType haskellType.
Unpackspec (Column sqlType) ()
-> FieldParser haskellType -> QueryRunnerColumn sqlType haskellType
QueryRunnerColumn ((Column coltype -> ())
-> Unpackspec (Column coltype) (Column coltype)
-> Unpackspec (Column coltype) ()
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
P.rmap (() -> Column coltype -> ()
forall a b. a -> b -> a
const ()) Unpackspec (Column coltype) (Column coltype)
forall a. Unpackspec (Column a) (Column a)
U.unpackspecColumn) FieldParser haskell
forall a. FromField a => FieldParser a
fromField
queryRunner :: QueryRunnerColumn a b -> QueryRunner (Column a) b
queryRunner :: QueryRunnerColumn a b -> QueryRunner (Column a) b
queryRunner QueryRunnerColumn a b
qrc = Unpackspec (Column a) ()
-> (Column a -> RowParser b)
-> (Column a -> Bool)
-> QueryRunner (Column a) b
forall columns haskells.
Unpackspec columns ()
-> (columns -> RowParser haskells)
-> (columns -> Bool)
-> QueryRunner columns haskells
QueryRunner Unpackspec (Column a) ()
u (RowParser b -> Column a -> RowParser b
forall a b. a -> b -> a
const (FieldParser b -> RowParser b
forall a. FieldParser a -> RowParser a
fieldWith FieldParser b
fp)) (Bool -> Column a -> Bool
forall a b. a -> b -> a
const Bool
True)
where QueryRunnerColumn Unpackspec (Column a) ()
u FieldParser b
fp = QueryRunnerColumn a b
qrc
queryRunnerColumnNullable :: QueryRunnerColumn a b
-> QueryRunnerColumn (Nullable a) (Maybe b)
queryRunnerColumnNullable :: QueryRunnerColumn a b -> QueryRunnerColumn (Nullable a) (Maybe b)
queryRunnerColumnNullable QueryRunnerColumn a b
qr =
Unpackspec (Column (Nullable a)) ()
-> FieldParser (Maybe b)
-> QueryRunnerColumn (Nullable a) (Maybe b)
forall sqlType haskellType.
Unpackspec (Column sqlType) ()
-> FieldParser haskellType -> QueryRunnerColumn sqlType haskellType
QueryRunnerColumn ((Column (Nullable a) -> Column a)
-> Unpackspec (Column a) () -> Unpackspec (Column (Nullable a)) ()
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap Column (Nullable a) -> Column a
forall a b. Column a -> Column b
C.unsafeCoerceColumn Unpackspec (Column a) ()
u) (FieldParser b -> FieldParser (Maybe b)
forall a. FieldParser a -> FieldParser (Maybe a)
fromField' FieldParser b
fp)
where QueryRunnerColumn Unpackspec (Column a) ()
u FieldParser b
fp = QueryRunnerColumn a b
qr
fromField' :: FieldParser a -> FieldParser (Maybe a)
fromField' :: FieldParser a -> FieldParser (Maybe a)
fromField' FieldParser a
_ (SSI.Field SQLData
SQLiteBase.SQLNull Int
_) = Maybe a -> Ok (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
fromField' FieldParser a
fp' Field
f = (a -> Maybe a) -> Ok a -> Ok (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (FieldParser a
fp' Field
f)
instance QueryRunnerColumnDefault a b =>
QueryRunnerColumnDefault (Nullable a) (Maybe b) where
queryRunnerColumnDefault :: QueryRunnerColumn (Nullable a) (Maybe b)
queryRunnerColumnDefault = QueryRunnerColumn a b -> QueryRunnerColumn (Nullable a) (Maybe b)
forall a b.
QueryRunnerColumn a b -> QueryRunnerColumn (Nullable a) (Maybe b)
queryRunnerColumnNullable QueryRunnerColumn a b
forall pgType haskellType.
QueryRunnerColumnDefault pgType haskellType =>
QueryRunnerColumn pgType haskellType
queryRunnerColumnDefault
instance QueryRunnerColumnDefault a b =>
D.Default QueryRunner (Column a) b where
def :: QueryRunner (Column a) b
def = QueryRunnerColumn a b -> QueryRunner (Column a) b
forall a b. QueryRunnerColumn a b -> QueryRunner (Column a) b
queryRunner QueryRunnerColumn a b
forall pgType haskellType.
QueryRunnerColumnDefault pgType haskellType =>
QueryRunnerColumn pgType haskellType
queryRunnerColumnDefault
class QueryRunnerColumnDefault pgType haskellType where
queryRunnerColumnDefault :: QueryRunnerColumn pgType haskellType
instance QueryRunnerColumnDefault T.PGInt4 Int where
queryRunnerColumnDefault :: QueryRunnerColumn PGInt4 Int
queryRunnerColumnDefault = QueryRunnerColumn PGInt4 Int
forall haskell coltype.
FromField haskell =>
QueryRunnerColumn coltype haskell
fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGInt8 Int64 where
queryRunnerColumnDefault :: QueryRunnerColumn PGInt8 Int64
queryRunnerColumnDefault = QueryRunnerColumn PGInt8 Int64
forall haskell coltype.
FromField haskell =>
QueryRunnerColumn coltype haskell
fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGText String where
queryRunnerColumnDefault :: QueryRunnerColumn PGText String
queryRunnerColumnDefault = QueryRunnerColumn PGText String
forall haskell coltype.
FromField haskell =>
QueryRunnerColumn coltype haskell
fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGFloat8 Double where
queryRunnerColumnDefault :: QueryRunnerColumn PGFloat8 Double
queryRunnerColumnDefault = QueryRunnerColumn PGFloat8 Double
forall haskell coltype.
FromField haskell =>
QueryRunnerColumn coltype haskell
fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGBool Bool where
queryRunnerColumnDefault :: QueryRunnerColumn PGBool Bool
queryRunnerColumnDefault = QueryRunnerColumn PGBool Bool
forall haskell coltype.
FromField haskell =>
QueryRunnerColumn coltype haskell
fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGBytea SBS.ByteString where
queryRunnerColumnDefault :: QueryRunnerColumn PGBytea ByteString
queryRunnerColumnDefault = QueryRunnerColumn PGBytea ByteString
forall haskell coltype.
FromField haskell =>
QueryRunnerColumn coltype haskell
fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGBytea LBS.ByteString where
queryRunnerColumnDefault :: QueryRunnerColumn PGBytea ByteString
queryRunnerColumnDefault = QueryRunnerColumn PGBytea ByteString
forall haskell coltype.
FromField haskell =>
QueryRunnerColumn coltype haskell
fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGText ST.Text where
queryRunnerColumnDefault :: QueryRunnerColumn PGText Text
queryRunnerColumnDefault = QueryRunnerColumn PGText Text
forall haskell coltype.
FromField haskell =>
QueryRunnerColumn coltype haskell
fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGText LT.Text where
queryRunnerColumnDefault :: QueryRunnerColumn PGText Text
queryRunnerColumnDefault = QueryRunnerColumn PGText Text
forall haskell coltype.
FromField haskell =>
QueryRunnerColumn coltype haskell
fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGDate Time.Day where
queryRunnerColumnDefault :: QueryRunnerColumn PGDate Day
queryRunnerColumnDefault = QueryRunnerColumn PGDate Day
forall haskell coltype.
FromField haskell =>
QueryRunnerColumn coltype haskell
fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGTimestamptz Time.UTCTime where
queryRunnerColumnDefault :: QueryRunnerColumn PGTimestamptz UTCTime
queryRunnerColumnDefault = QueryRunnerColumn PGTimestamptz UTCTime
forall haskell coltype.
FromField haskell =>
QueryRunnerColumn coltype haskell
fieldQueryRunnerColumn
instance Functor (QueryRunner c) where
fmap :: (a -> b) -> QueryRunner c a -> QueryRunner c b
fmap a -> b
f (QueryRunner Unpackspec c ()
u c -> RowParser a
r c -> Bool
b) = Unpackspec c ()
-> (c -> RowParser b) -> (c -> Bool) -> QueryRunner c b
forall columns haskells.
Unpackspec columns ()
-> (columns -> RowParser haskells)
-> (columns -> Bool)
-> QueryRunner columns haskells
QueryRunner Unpackspec c ()
u (((RowParser a -> RowParser b)
-> (c -> RowParser a) -> c -> RowParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RowParser a -> RowParser b)
-> (c -> RowParser a) -> c -> RowParser b)
-> ((a -> b) -> RowParser a -> RowParser b)
-> (a -> b)
-> (c -> RowParser a)
-> c
-> RowParser b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f c -> RowParser a
r) c -> Bool
b
instance Applicative (QueryRunner c) where
pure :: a -> QueryRunner c a
pure = ((c -> RowParser a) -> (c -> Bool) -> QueryRunner c a)
-> (c -> Bool) -> (c -> RowParser a) -> QueryRunner c a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Unpackspec c ()
-> (c -> RowParser a) -> (c -> Bool) -> QueryRunner c a
forall columns haskells.
Unpackspec columns ()
-> (columns -> RowParser haskells)
-> (columns -> Bool)
-> QueryRunner columns haskells
QueryRunner ((c -> ()) -> Unpackspec () () -> Unpackspec c ()
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap (() -> c -> ()
forall a b. a -> b -> a
const ()) Unpackspec () ()
forall (p :: * -> * -> *). ProductProfunctor p => p () ()
PP.empty)) (Bool -> c -> Bool
forall a b. a -> b -> a
const Bool
False)
((c -> RowParser a) -> QueryRunner c a)
-> (a -> c -> RowParser a) -> a -> QueryRunner c a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RowParser a -> c -> RowParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(RowParser a -> c -> RowParser a)
-> (a -> RowParser a) -> a -> c -> RowParser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> RowParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
QueryRunner Unpackspec c ()
uf c -> RowParser (a -> b)
rf c -> Bool
bf <*> :: QueryRunner c (a -> b) -> QueryRunner c a -> QueryRunner c b
<*> QueryRunner Unpackspec c ()
ux c -> RowParser a
rx c -> Bool
bx =
Unpackspec c ()
-> (c -> RowParser b) -> (c -> Bool) -> QueryRunner c b
forall columns haskells.
Unpackspec columns ()
-> (columns -> RowParser haskells)
-> (columns -> Bool)
-> QueryRunner columns haskells
QueryRunner ((c -> (c, c))
-> (((), ()) -> ())
-> Unpackspec (c, c) ((), ())
-> Unpackspec c ()
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
P.dimap (\c
x -> (c
x,c
x)) (() -> ((), ()) -> ()
forall a b. a -> b -> a
const ()) (Unpackspec c ()
uf Unpackspec c () -> Unpackspec c () -> Unpackspec (c, c) ((), ())
forall (p :: * -> * -> *) a b a' b'.
ProductProfunctor p =>
p a b -> p a' b' -> p (a, a') (b, b')
PP.***! Unpackspec c ()
ux)) (RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (RowParser (a -> b) -> RowParser a -> RowParser b)
-> (c -> RowParser (a -> b)) -> c -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c -> RowParser (a -> b)
rf (c -> RowParser a -> RowParser b)
-> (c -> RowParser a) -> c -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> c -> RowParser a
rx) ((Bool -> Bool -> Bool) -> (c -> Bool) -> (c -> Bool) -> c -> Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||) c -> Bool
bf c -> Bool
bx)
instance P.Profunctor QueryRunner where
dimap :: (a -> b) -> (c -> d) -> QueryRunner b c -> QueryRunner a d
dimap a -> b
f c -> d
g (QueryRunner Unpackspec b ()
u b -> RowParser c
r b -> Bool
b) =
Unpackspec a ()
-> (a -> RowParser d) -> (a -> Bool) -> QueryRunner a d
forall columns haskells.
Unpackspec columns ()
-> (columns -> RowParser haskells)
-> (columns -> Bool)
-> QueryRunner columns haskells
QueryRunner ((a -> b) -> Unpackspec b () -> Unpackspec a ()
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap a -> b
f Unpackspec b ()
u) ((a -> b)
-> (RowParser c -> RowParser d)
-> (b -> RowParser c)
-> a
-> RowParser d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
P.dimap a -> b
f ((c -> d) -> RowParser c -> RowParser d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g) b -> RowParser c
r) ((a -> b) -> (b -> Bool) -> a -> Bool
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap a -> b
f b -> Bool
b)
instance PP.ProductProfunctor QueryRunner where
empty :: QueryRunner () ()
empty = QueryRunner () ()
forall (p :: * -> * -> *). Applicative (p ()) => p () ()
PP.defaultEmpty
***! :: QueryRunner a b -> QueryRunner a' b' -> QueryRunner (a, a') (b, b')
(***!) = QueryRunner a b -> QueryRunner a' b' -> QueryRunner (a, a') (b, b')
forall (p :: * -> * -> *) a a' b b'.
(Applicative (p (a, a')), Profunctor p) =>
p a b -> p a' b' -> p (a, a') (b, b')
PP.defaultProfunctorProduct
instance PP.SumProfunctor QueryRunner where
QueryRunner a b
f +++! :: QueryRunner a b
-> QueryRunner a' b' -> QueryRunner (Either a a') (Either b b')
+++! QueryRunner a' b'
g = Unpackspec (Either a a') ()
-> (Either a a' -> RowParser (Either b b'))
-> (Either a a' -> Bool)
-> QueryRunner (Either a a') (Either b b')
forall columns haskells.
Unpackspec columns ()
-> (columns -> RowParser haskells)
-> (columns -> Bool)
-> QueryRunner columns haskells
QueryRunner ((Either () () -> ())
-> Unpackspec (Either a a') (Either () ())
-> Unpackspec (Either a a') ()
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
P.rmap (() -> Either () () -> ()
forall a b. a -> b -> a
const ()) (Unpackspec a ()
fu Unpackspec a ()
-> Unpackspec a' () -> Unpackspec (Either a a') (Either () ())
forall (p :: * -> * -> *) a b a' b'.
SumProfunctor p =>
p a b -> p a' b' -> p (Either a a') (Either b b')
PP.+++! Unpackspec a' ()
gu))
((a -> RowParser b)
-> (a' -> RowParser b') -> Either a a' -> RowParser (Either b b')
forall (f :: * -> *) a b a' b'.
Functor f =>
(a -> f b) -> (a' -> f b') -> Either a a' -> f (Either b b')
PackMap.eitherFunction a -> RowParser b
fr a' -> RowParser b'
gr)
((a -> Bool) -> (a' -> Bool) -> Either a a' -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Bool
fb a' -> Bool
gb)
where QueryRunner Unpackspec a ()
fu a -> RowParser b
fr a -> Bool
fb = QueryRunner a b
f
QueryRunner Unpackspec a' ()
gu a' -> RowParser b'
gr a' -> Bool
gb = QueryRunner a' b'
g