{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
module Opaleye.SQLite.Internal.Table where
import Opaleye.SQLite.Internal.Column (Column, unColumn)
import qualified Opaleye.SQLite.Internal.TableMaker as TM
import qualified Opaleye.SQLite.Internal.Tag as Tag
import qualified Opaleye.SQLite.Internal.PrimQuery as PQ
import qualified Opaleye.SQLite.Internal.PackMap as PM
import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ
import qualified Data.Functor.Identity as I
import Data.Profunctor (Profunctor, dimap, lmap)
import Data.Profunctor.Product (ProductProfunctor, empty, (***!))
import qualified Data.Profunctor.Product as PP
import qualified Data.List.NonEmpty as NEL
import Data.Semigroup (Semigroup, (<>))
import Data.Monoid (Monoid, mempty)
import Control.Applicative (Applicative, pure, (<*>), liftA2)
import qualified Control.Arrow as Arr
data Table writerColumns viewColumns =
Table String (TableProperties writerColumns viewColumns)
data TableProperties writerColumns viewColumns =
TableProperties (Writer writerColumns viewColumns) (View viewColumns)
data View columns = View columns
newtype Writer columns dummy =
Writer (forall f. Functor f =>
PM.PackMap (f HPQ.PrimExpr, String) () (f columns) ())
queryTable :: TM.ColumnMaker viewColumns columns
-> Table writerColumns viewColumns
-> Tag.Tag
-> (columns, PQ.PrimQuery)
queryTable :: ColumnMaker viewColumns columns
-> Table writerColumns viewColumns -> Tag -> (columns, PrimQuery)
queryTable ColumnMaker viewColumns columns
cm Table writerColumns viewColumns
table Tag
tag = (columns
primExprs, PrimQuery
primQ) where
(Table String
tableName (TableProperties Writer writerColumns viewColumns
_ (View viewColumns
tableCols))) = Table writerColumns viewColumns
table
(columns
primExprs, [(Symbol, PrimExpr)]
projcols) = ColumnMaker viewColumns columns
-> Tag -> viewColumns -> (columns, [(Symbol, PrimExpr)])
forall tablecolumns columns.
ColumnMaker tablecolumns columns
-> Tag -> tablecolumns -> (columns, [(Symbol, PrimExpr)])
runColumnMaker ColumnMaker viewColumns columns
cm Tag
tag viewColumns
tableCols
primQ :: PQ.PrimQuery
primQ :: PrimQuery
primQ = String -> [(Symbol, PrimExpr)] -> PrimQuery
PQ.BaseTable String
tableName [(Symbol, PrimExpr)]
projcols
runColumnMaker :: TM.ColumnMaker tablecolumns columns
-> Tag.Tag
-> tablecolumns
-> (columns, [(HPQ.Symbol, HPQ.PrimExpr)])
runColumnMaker :: ColumnMaker tablecolumns columns
-> Tag -> tablecolumns -> (columns, [(Symbol, PrimExpr)])
runColumnMaker ColumnMaker tablecolumns columns
cm Tag
tag tablecolumns
tableCols = PM [(Symbol, PrimExpr)] columns -> (columns, [(Symbol, PrimExpr)])
forall a r. PM [a] r -> (r, [a])
PM.run (ColumnMaker tablecolumns columns
-> (PrimExpr
-> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr)
-> tablecolumns
-> PM [(Symbol, PrimExpr)] columns
forall (f :: * -> *) tablecolumns columns.
Applicative f =>
ColumnMaker tablecolumns columns
-> (PrimExpr -> f PrimExpr) -> tablecolumns -> f columns
TM.runColumnMaker ColumnMaker tablecolumns columns
cm PrimExpr -> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
f tablecolumns
tableCols) where
f :: PrimExpr -> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
f = (PrimExpr -> String -> String)
-> Tag
-> PrimExpr
-> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
forall primExpr.
(primExpr -> String -> String)
-> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
PM.extractAttrPE PrimExpr -> String -> String
mkName Tag
tag
mkName :: PrimExpr -> String -> String
mkName PrimExpr
pe String
i = (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
i) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ case PrimExpr
pe of
HPQ.BaseTableAttrExpr String
columnName -> String
columnName
PrimExpr
_ -> String
"tablecolumn"
runWriter :: Writer columns columns' -> columns -> [(HPQ.PrimExpr, String)]
runWriter :: Writer columns columns' -> columns -> [(PrimExpr, String)]
runWriter (Writer (PM.PackMap f)) columns
columns = [(PrimExpr, String)]
outColumns
where ([(PrimExpr, String)]
outColumns, ()) = ((Identity PrimExpr, String) -> ([(PrimExpr, String)], ()))
-> Identity columns -> ([(PrimExpr, String)], ())
forall (f :: * -> *).
Applicative f =>
((Identity PrimExpr, String) -> f ()) -> Identity columns -> f ()
f (Identity PrimExpr, String) -> ([(PrimExpr, String)], ())
forall a b. (Identity a, b) -> ([(a, b)], ())
extract (columns -> Identity columns
forall a. a -> Identity a
I.Identity columns
columns)
extract :: (Identity a, b) -> ([(a, b)], ())
extract (Identity a
pes, b
s) = ([(Identity a -> a
forall a. Identity a -> a
I.runIdentity Identity a
pes, b
s)], ())
runWriter' :: Writer columns columns' -> NEL.NonEmpty columns -> (NEL.NonEmpty [HPQ.PrimExpr], [String])
runWriter' :: Writer columns columns'
-> NonEmpty columns -> (NonEmpty [PrimExpr], [String])
runWriter' (Writer (PM.PackMap f)) NonEmpty columns
columns = (Zip PrimExpr -> NonEmpty [PrimExpr])
-> (Zip PrimExpr, [String]) -> (NonEmpty [PrimExpr], [String])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Arr.first Zip PrimExpr -> NonEmpty [PrimExpr]
forall a. Zip a -> NonEmpty [a]
unZip (Zip PrimExpr, [String])
outColumns
where ((Zip PrimExpr, [String])
outColumns, ()) = ((NonEmpty PrimExpr, String) -> ((Zip PrimExpr, [String]), ()))
-> NonEmpty columns -> ((Zip PrimExpr, [String]), ())
forall (f :: * -> *).
Applicative f =>
((NonEmpty PrimExpr, String) -> f ()) -> NonEmpty columns -> f ()
f (NonEmpty PrimExpr, String) -> ((Zip PrimExpr, [String]), ())
forall a a. (NonEmpty a, a) -> ((Zip a, [a]), ())
extract NonEmpty columns
columns
extract :: (NonEmpty a, a) -> ((Zip a, [a]), ())
extract (NonEmpty a
pes, a
s) = ((NonEmpty [a] -> Zip a
forall a. NonEmpty [a] -> Zip a
Zip ((a -> [a]) -> NonEmpty a -> NonEmpty [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return NonEmpty a
pes), [a
s]), ())
data Zip a = Zip { Zip a -> NonEmpty [a]
unZip :: NEL.NonEmpty [a] }
instance Semigroup (Zip a) where
Zip NonEmpty [a]
xs <> :: Zip a -> Zip a -> Zip a
<> Zip NonEmpty [a]
ys = NonEmpty [a] -> Zip a
forall a. NonEmpty [a] -> Zip a
Zip (([a] -> [a] -> [a]) -> NonEmpty [a] -> NonEmpty [a] -> NonEmpty [a]
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NEL.zipWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) NonEmpty [a]
xs NonEmpty [a]
ys)
instance Monoid (Zip a) where
mempty :: Zip a
mempty = NonEmpty [a] -> Zip a
forall a. NonEmpty [a] -> Zip a
Zip NonEmpty [a]
forall a. NonEmpty [a]
mempty'
where mempty' :: NonEmpty [a]
mempty' = [] [a] -> NonEmpty [a] -> NonEmpty [a]
forall a. a -> NonEmpty a -> NonEmpty a
`NEL.cons` NonEmpty [a]
mempty'
required :: String -> Writer (Column a) (Column a)
required :: String -> Writer (Column a) (Column a)
required String
columnName =
(forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f (Column a)) ())
-> Writer (Column a) (Column a)
forall columns dummy.
(forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer ((forall (f :: * -> *).
Applicative f =>
((f PrimExpr, String) -> f ()) -> f (Column a) -> f ())
-> PackMap (f PrimExpr, String) () (f (Column a)) ()
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PM.PackMap (\(f PrimExpr, String) -> f ()
f f (Column a)
columns -> (f PrimExpr, String) -> f ()
f ((Column a -> PrimExpr) -> f (Column a) -> f PrimExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Column a -> PrimExpr
forall a. Column a -> PrimExpr
unColumn f (Column a)
columns, String
columnName)))
optional :: String -> Writer (Maybe (Column a)) (Column a)
optional :: String -> Writer (Maybe (Column a)) (Column a)
optional String
columnName =
(forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f (Maybe (Column a))) ())
-> Writer (Maybe (Column a)) (Column a)
forall columns dummy.
(forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer ((forall (f :: * -> *).
Applicative f =>
((f PrimExpr, String) -> f ()) -> f (Maybe (Column a)) -> f ())
-> PackMap (f PrimExpr, String) () (f (Maybe (Column a))) ()
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PM.PackMap (\(f PrimExpr, String) -> f ()
f f (Maybe (Column a))
columns -> (f PrimExpr, String) -> f ()
f ((Maybe (Column a) -> PrimExpr)
-> f (Maybe (Column a)) -> f PrimExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Column a) -> PrimExpr
forall a. Maybe (Column a) -> PrimExpr
maybeUnColumn f (Maybe (Column a))
columns, String
columnName)))
where maybeUnColumn :: Maybe (Column a) -> PrimExpr
maybeUnColumn Maybe (Column a)
Nothing = PrimExpr
HPQ.DefaultInsertExpr
maybeUnColumn (Just Column a
column) = Column a -> PrimExpr
forall a. Column a -> PrimExpr
unColumn Column a
column
instance Functor (Writer a) where
fmap :: (a -> b) -> Writer a a -> Writer a b
fmap a -> b
_ (Writer forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
g) = (forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ())
-> Writer a b
forall columns dummy.
(forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
g
instance Applicative (Writer a) where
pure :: a -> Writer a a
pure a
x = (forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ())
-> Writer a a
forall columns dummy.
(forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer ((a -> ())
-> PackMap (f PrimExpr, String) () (f a) a
-> PackMap (f PrimExpr, String) () (f a) ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> a -> ()
forall a b. a -> b -> a
const ()) (a -> PackMap (f PrimExpr, String) () (f a) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x))
Writer forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
f <*> :: Writer a (a -> b) -> Writer a a -> Writer a b
<*> Writer forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
x = (forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ())
-> Writer a b
forall columns dummy.
(forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer ((() -> () -> ())
-> PackMap (f PrimExpr, String) () (f a) ()
-> PackMap (f PrimExpr, String) () (f a) ()
-> PackMap (f PrimExpr, String) () (f a) ()
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\()
_ ()
_ -> ()) PackMap (f PrimExpr, String) () (f a) ()
forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
f PackMap (f PrimExpr, String) () (f a) ()
forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
x)
instance Profunctor Writer where
dimap :: (a -> b) -> (c -> d) -> Writer b c -> Writer a d
dimap a -> b
f c -> d
_ (Writer forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f b) ()
h) = (forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ())
-> Writer a d
forall columns dummy.
(forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer ((f a -> f b)
-> PackMap (f PrimExpr, String) () (f b) ()
-> PackMap (f PrimExpr, String) () (f a) ()
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap ((a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) PackMap (f PrimExpr, String) () (f b) ()
forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f b) ()
h)
instance ProductProfunctor Writer where
empty :: Writer () ()
empty = Writer () ()
forall (p :: * -> * -> *). Applicative (p ()) => p () ()
PP.defaultEmpty
***! :: Writer a b -> Writer a' b' -> Writer (a, a') (b, b')
(***!) = Writer a b -> Writer a' b' -> Writer (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 Functor (TableProperties a) where
fmap :: (a -> b) -> TableProperties a a -> TableProperties a b
fmap a -> b
f (TableProperties Writer a a
w (View a
v)) = Writer a b -> View b -> TableProperties a b
forall writerColumns viewColumns.
Writer writerColumns viewColumns
-> View viewColumns -> TableProperties writerColumns viewColumns
TableProperties ((a -> b) -> Writer a a -> Writer a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Writer a a
w) (b -> View b
forall columns. columns -> View columns
View (a -> b
f a
v))
instance Applicative (TableProperties a) where
pure :: a -> TableProperties a a
pure a
x = Writer a a -> View a -> TableProperties a a
forall writerColumns viewColumns.
Writer writerColumns viewColumns
-> View viewColumns -> TableProperties writerColumns viewColumns
TableProperties (a -> Writer a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x) (a -> View a
forall columns. columns -> View columns
View a
x)
TableProperties Writer a (a -> b)
fw (View a -> b
fv) <*> :: TableProperties a (a -> b)
-> TableProperties a a -> TableProperties a b
<*> TableProperties Writer a a
xw (View a
xv) =
Writer a b -> View b -> TableProperties a b
forall writerColumns viewColumns.
Writer writerColumns viewColumns
-> View viewColumns -> TableProperties writerColumns viewColumns
TableProperties (Writer a (a -> b)
fw Writer a (a -> b) -> Writer a a -> Writer a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Writer a a
xw) (b -> View b
forall columns. columns -> View columns
View (a -> b
fv a
xv))
instance Profunctor TableProperties where
dimap :: (a -> b) -> (c -> d) -> TableProperties b c -> TableProperties a d
dimap a -> b
f c -> d
g (TableProperties Writer b c
w (View c
v)) = Writer a d -> View d -> TableProperties a d
forall writerColumns viewColumns.
Writer writerColumns viewColumns
-> View viewColumns -> TableProperties writerColumns viewColumns
TableProperties ((a -> b) -> (c -> d) -> Writer b c -> Writer a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a -> b
f c -> d
g Writer b c
w)
(d -> View d
forall columns. columns -> View columns
View (c -> d
g c
v))
instance ProductProfunctor TableProperties where
empty :: TableProperties () ()
empty = TableProperties () ()
forall (p :: * -> * -> *). Applicative (p ()) => p () ()
PP.defaultEmpty
***! :: TableProperties a b
-> TableProperties a' b' -> TableProperties (a, a') (b, b')
(***!) = TableProperties a b
-> TableProperties a' b' -> TableProperties (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 Functor (Table a) where
fmap :: (a -> b) -> Table a a -> Table a b
fmap a -> b
f (Table String
s TableProperties a a
tp) = String -> TableProperties a b -> Table a b
forall writerColumns viewColumns.
String
-> TableProperties writerColumns viewColumns
-> Table writerColumns viewColumns
Table String
s ((a -> b) -> TableProperties a a -> TableProperties a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f TableProperties a a
tp)