{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE Rank2Types #-}
module Opaleye.Internal.Table where
import Opaleye.Internal.Column (Field_(Column), unColumn)
import qualified Opaleye.Internal.Tag as Tag
import qualified Opaleye.Internal.Unpackspec as U
import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Internal.PackMap as PM
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import qualified Data.Functor.Identity as I
import Data.Profunctor (Profunctor, dimap, lmap)
import Data.Profunctor.Product (ProductProfunctor)
import qualified Data.Profunctor.Product as PP
import qualified Data.List.NonEmpty as NEL
import Data.Monoid (Monoid, mempty, mappend)
import Data.Semigroup (Semigroup, (<>))
import Control.Applicative (Applicative, pure, (<*>), liftA2)
import qualified Control.Arrow as Arr
data Table writeFields viewFields
= Table String (TableFields writeFields viewFields)
| TableWithSchema String String (TableFields writeFields viewFields)
tableIdentifier :: Table writeColumns viewColumns -> PQ.TableIdentifier
tableIdentifier :: forall writeColumns viewColumns.
Table writeColumns viewColumns -> TableIdentifier
tableIdentifier (Table String
t TableFields writeColumns viewColumns
_) = Maybe String -> String -> TableIdentifier
PQ.TableIdentifier forall a. Maybe a
Nothing String
t
tableIdentifier (TableWithSchema String
s String
t TableFields writeColumns viewColumns
_) = Maybe String -> String -> TableIdentifier
PQ.TableIdentifier (forall a. a -> Maybe a
Just String
s) String
t
tableColumns :: Table writeColumns viewColumns -> TableFields writeColumns viewColumns
tableColumns :: forall writeColumns viewColumns.
Table writeColumns viewColumns
-> TableFields writeColumns viewColumns
tableColumns (Table String
_ TableFields writeColumns viewColumns
p) = TableFields writeColumns viewColumns
p
tableColumns (TableWithSchema String
_ String
_ TableFields writeColumns viewColumns
p) = TableFields writeColumns viewColumns
p
tableProperties :: Table writeColumns viewColumns -> TableFields writeColumns viewColumns
tableProperties :: forall writeColumns viewColumns.
Table writeColumns viewColumns
-> TableFields writeColumns viewColumns
tableProperties = forall writeColumns viewColumns.
Table writeColumns viewColumns
-> TableFields writeColumns viewColumns
tableColumns
data TableFields writeColumns viewColumns = TableFields
{ forall writeColumns viewColumns.
TableFields writeColumns viewColumns
-> Writer writeColumns viewColumns
tablePropertiesWriter :: Writer writeColumns viewColumns
, forall writeColumns viewColumns.
TableFields writeColumns viewColumns -> View viewColumns
tablePropertiesView :: View viewColumns }
tableColumnsWriter :: TableFields writeColumns viewColumns
-> Writer writeColumns viewColumns
tableColumnsWriter :: forall writeColumns viewColumns.
TableFields writeColumns viewColumns
-> Writer writeColumns viewColumns
tableColumnsWriter = forall writeColumns viewColumns.
TableFields writeColumns viewColumns
-> Writer writeColumns viewColumns
tablePropertiesWriter
tableColumnsView :: TableFields writeColumns viewColumns
-> View viewColumns
tableColumnsView :: forall writeColumns viewColumns.
TableFields writeColumns viewColumns -> View viewColumns
tableColumnsView = forall writeColumns viewColumns.
TableFields writeColumns viewColumns -> View viewColumns
tablePropertiesView
newtype View columns = View columns
newtype Writer columns dummy =
Writer (forall f. Functor f =>
PM.PackMap (f HPQ.PrimExpr, String) () (f columns) ())
requiredTableField :: String -> TableFields (Field_ n a) (Field_ n a)
requiredTableField :: forall (n :: Nullability) a.
String -> TableFields (Field_ n a) (Field_ n a)
requiredTableField String
columnName = forall writeColumns viewColumns.
Writer writeColumns viewColumns
-> View viewColumns -> TableFields writeColumns viewColumns
TableFields
(forall (n :: Nullability) a.
String -> Writer (Field_ n a) (Field_ n a)
requiredW String
columnName)
(forall columns. columns -> View columns
View (forall (n :: Nullability) sqlType. PrimExpr -> Field_ n sqlType
Column (String -> PrimExpr
HPQ.BaseTableAttrExpr String
columnName)))
optionalTableField :: String -> TableFields (Maybe (Field_ n a)) (Field_ n a)
optionalTableField :: forall (n :: Nullability) a.
String -> TableFields (Maybe (Field_ n a)) (Field_ n a)
optionalTableField String
columnName = forall writeColumns viewColumns.
Writer writeColumns viewColumns
-> View viewColumns -> TableFields writeColumns viewColumns
TableFields
(forall (n :: Nullability) a.
String -> Writer (Maybe (Field_ n a)) (Field_ n a)
optionalW String
columnName)
(forall columns. columns -> View columns
View (forall (n :: Nullability) sqlType. PrimExpr -> Field_ n sqlType
Column (String -> PrimExpr
HPQ.BaseTableAttrExpr String
columnName)))
readOnlyTableField :: String -> TableFields () (Field_ n a)
readOnlyTableField :: forall (n :: Nullability) a. String -> TableFields () (Field_ n a)
readOnlyTableField = forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nullability) a.
String -> TableFields (Maybe (Field_ n a)) (Field_ n a)
optionalTableField
class InferrableTableField w n r
| w -> n, w -> r where
tableField :: String -> TableFields w (Field_ n r)
instance InferrableTableField (Field_ n r) n r where
tableField :: String -> TableFields (Field_ n r) (Field_ n r)
tableField = forall (n :: Nullability) a.
String -> TableFields (Field_ n a) (Field_ n a)
requiredTableField
instance InferrableTableField (Maybe (Field_ n r)) n r where
tableField :: String -> TableFields (Maybe (Field_ n r)) (Field_ n r)
tableField = forall (n :: Nullability) a.
String -> TableFields (Maybe (Field_ n a)) (Field_ n a)
optionalTableField
queryTable :: U.Unpackspec viewColumns columns
-> Table writeColumns viewColumns
-> Tag.Tag
-> (columns, PQ.PrimQuery)
queryTable :: forall viewColumns columns writeColumns.
Unpackspec viewColumns columns
-> Table writeColumns viewColumns -> Tag -> (columns, PrimQuery)
queryTable Unpackspec viewColumns columns
cm Table writeColumns viewColumns
table Tag
tag = (columns
primExprs, PrimQuery
primQ) where
View viewColumns
tableCols = forall writeColumns viewColumns.
TableFields writeColumns viewColumns -> View viewColumns
tableColumnsView (forall writeColumns viewColumns.
Table writeColumns viewColumns
-> TableFields writeColumns viewColumns
tableColumns Table writeColumns viewColumns
table)
(columns
primExprs, [(Symbol, PrimExpr)]
projcols) = forall tablecolumns columns.
Unpackspec tablecolumns columns
-> Tag -> tablecolumns -> (columns, [(Symbol, PrimExpr)])
runColumnMaker Unpackspec viewColumns columns
cm Tag
tag viewColumns
tableCols
primQ :: PQ.PrimQuery
primQ :: PrimQuery
primQ = forall a. TableIdentifier -> [(Symbol, PrimExpr)] -> PrimQuery' a
PQ.BaseTable (forall writeColumns viewColumns.
Table writeColumns viewColumns -> TableIdentifier
tableIdentifier Table writeColumns viewColumns
table) [(Symbol, PrimExpr)]
projcols
runColumnMaker :: U.Unpackspec tablecolumns columns
-> Tag.Tag
-> tablecolumns
-> (columns, [(HPQ.Symbol, HPQ.PrimExpr)])
runColumnMaker :: forall tablecolumns columns.
Unpackspec tablecolumns columns
-> Tag -> tablecolumns -> (columns, [(Symbol, PrimExpr)])
runColumnMaker Unpackspec tablecolumns columns
cm Tag
tag tablecolumns
tableCols = forall a r. PM [a] r -> (r, [a])
PM.run (forall (f :: * -> *) columns b.
Applicative f =>
Unpackspec columns b -> (PrimExpr -> f PrimExpr) -> columns -> f b
U.runUnpackspec Unpackspec tablecolumns columns
cm PrimExpr -> PM [(Symbol, PrimExpr)] PrimExpr
f tablecolumns
tableCols) where
f :: PrimExpr -> PM [(Symbol, PrimExpr)] PrimExpr
f = 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 = (forall a. [a] -> [a] -> [a]
++ String
i) forall a b. (a -> b) -> a -> b
$ case PrimExpr
pe of
HPQ.BaseTableAttrExpr String
columnName -> String
columnName
HPQ.CompositeExpr PrimExpr
columnExpr String
fieldName -> PrimExpr -> String -> String
mkName PrimExpr
columnExpr String
i forall a. [a] -> [a] -> [a]
++ String
fieldName
PrimExpr
_ -> String
"tablecolumn"
runWriter :: Writer columns columns' -> columns -> [(HPQ.PrimExpr, String)]
runWriter :: forall columns columns'.
Writer columns columns' -> columns -> [(PrimExpr, String)]
runWriter (Writer (PM.PackMap forall (f :: * -> *).
Applicative f =>
((Identity PrimExpr, String) -> f ()) -> Identity columns -> f ()
f)) columns
columns = [(PrimExpr, String)]
outColumns
where ([(PrimExpr, String)]
outColumns, ()) = forall (f :: * -> *).
Applicative f =>
((Identity PrimExpr, String) -> f ()) -> Identity columns -> f ()
f forall {a} {b}. (Identity a, b) -> ([(a, b)], ())
extract (forall a. a -> Identity a
I.Identity columns
columns)
extract :: (Identity a, b) -> ([(a, b)], ())
extract (Identity a
pes, b
s) = ([(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' :: forall columns columns'.
Writer columns columns'
-> NonEmpty columns -> (NonEmpty [PrimExpr], [String])
runWriter' (Writer (PM.PackMap forall (f :: * -> *).
Applicative f =>
((NonEmpty PrimExpr, String) -> f ()) -> NonEmpty columns -> f ()
f)) NonEmpty columns
columns = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Arr.first forall a. Zip a -> NonEmpty [a]
unZip (Zip PrimExpr, [String])
outColumns
where ((Zip PrimExpr, [String])
outColumns, ()) = forall (f :: * -> *).
Applicative f =>
((NonEmpty PrimExpr, String) -> f ()) -> NonEmpty columns -> f ()
f 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) = ((forall a. NonEmpty [a] -> Zip a
Zip (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => a -> m a
return NonEmpty a
pes), [a
s]), ())
newtype Zip a = Zip { forall a. 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 = forall a. NonEmpty [a] -> Zip a
Zip (forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NEL.zipWith forall a. [a] -> [a] -> [a]
(++) NonEmpty [a]
xs NonEmpty [a]
ys)
instance Monoid (Zip a) where
mempty :: Zip a
mempty = forall a. NonEmpty [a] -> Zip a
Zip forall {a}. NonEmpty [a]
mempty'
where mempty' :: NonEmpty [a]
mempty' = [] forall a. a -> NonEmpty a -> NonEmpty a
`NEL.cons` NonEmpty [a]
mempty'
mappend :: Zip a -> Zip a -> Zip a
mappend = forall a. Semigroup a => a -> a -> a
(<>)
requiredW :: String -> Writer (Field_ n a) (Field_ n a)
requiredW :: forall (n :: Nullability) a.
String -> Writer (Field_ n a) (Field_ n a)
requiredW String
columnName =
forall columns dummy.
(forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer (forall s a b t. (s -> a) -> (b -> t) -> PackMap a b s t
PM.iso (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) String
columnName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (n :: Nullability) a. Field_ n a -> PrimExpr
unColumn) forall a. a -> a
id)
optionalW :: String -> Writer (Maybe (Field_ n a)) (Field_ n a)
optionalW :: forall (n :: Nullability) a.
String -> Writer (Maybe (Field_ n a)) (Field_ n a)
optionalW String
columnName =
forall columns dummy.
(forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer (forall s a b t. (s -> a) -> (b -> t) -> PackMap a b s t
PM.iso (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) String
columnName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {n :: Nullability} {a}. Maybe (Field_ n a) -> PrimExpr
maybeUnColumn) forall a. a -> a
id)
where maybeUnColumn :: Maybe (Field_ n a) -> PrimExpr
maybeUnColumn = forall b a. b -> (a -> b) -> Maybe a -> b
maybe PrimExpr
HPQ.DefaultInsertExpr forall (n :: Nullability) a. Field_ n a -> PrimExpr
unColumn
instance Functor (Writer a) where
fmap :: forall a b. (a -> b) -> Writer a a -> Writer a b
fmap a -> b
_ (Writer forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
g) = 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 :: forall a. a -> Writer a a
pure a
_ = forall columns dummy.
(forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
Writer forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
f <*> :: forall a b. Writer a (a -> b) -> Writer a a -> Writer a b
<*> Writer forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
x = forall columns dummy.
(forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\()
_ ()
_ -> ()) forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
f forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
x)
instance Profunctor Writer where
dimap :: forall a b c d. (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 columns dummy.
(forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer (forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f b) ()
h)
instance ProductProfunctor Writer where
purePP :: forall b a. b -> Writer a b
purePP = forall (f :: * -> *) a. Applicative f => a -> f a
pure
**** :: forall a a b. Writer a (a -> b) -> Writer a a -> Writer a b
(****) = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
instance Functor (TableFields a) where
fmap :: forall a b. (a -> b) -> TableFields a a -> TableFields a b
fmap a -> b
f (TableFields Writer a a
w (View a
v)) = forall writeColumns viewColumns.
Writer writeColumns viewColumns
-> View viewColumns -> TableFields writeColumns viewColumns
TableFields (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Writer a a
w) (forall columns. columns -> View columns
View (a -> b
f a
v))
instance Applicative (TableFields a) where
pure :: forall a. a -> TableFields a a
pure a
x = forall writeColumns viewColumns.
Writer writeColumns viewColumns
-> View viewColumns -> TableFields writeColumns viewColumns
TableFields (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x) (forall columns. columns -> View columns
View a
x)
TableFields Writer a (a -> b)
fw (View a -> b
fv) <*> :: forall a b.
TableFields a (a -> b) -> TableFields a a -> TableFields a b
<*> TableFields Writer a a
xw (View a
xv) =
forall writeColumns viewColumns.
Writer writeColumns viewColumns
-> View viewColumns -> TableFields writeColumns viewColumns
TableFields (Writer a (a -> b)
fw forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Writer a a
xw) (forall columns. columns -> View columns
View (a -> b
fv a
xv))
instance Profunctor TableFields where
dimap :: forall a b c d.
(a -> b) -> (c -> d) -> TableFields b c -> TableFields a d
dimap a -> b
f c -> d
g (TableFields Writer b c
w (View c
v)) = forall writeColumns viewColumns.
Writer writeColumns viewColumns
-> View viewColumns -> TableFields writeColumns viewColumns
TableFields (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)
(forall columns. columns -> View columns
View (c -> d
g c
v))
instance ProductProfunctor TableFields where
purePP :: forall b a. b -> TableFields a b
purePP = forall (f :: * -> *) a. Applicative f => a -> f a
pure
**** :: forall a a b.
TableFields a (a -> b) -> TableFields a a -> TableFields a b
(****) = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
instance Functor (Table a) where
fmap :: forall a b. (a -> b) -> Table a a -> Table a b
fmap a -> b
f (Table String
t TableFields a a
tp) = forall writeFields viewFields.
String
-> TableFields writeFields viewFields
-> Table writeFields viewFields
Table String
t (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f TableFields a a
tp)
fmap a -> b
f (TableWithSchema String
s String
t TableFields a a
tp) = forall writeFields viewFields.
String
-> String
-> TableFields writeFields viewFields
-> Table writeFields viewFields
TableWithSchema String
s String
t (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f TableFields a a
tp)
instance Profunctor Table where
dimap :: forall a b c d. (a -> b) -> (c -> d) -> Table b c -> Table a d
dimap a -> b
f c -> d
g (Table String
t TableFields b c
tp) = forall writeFields viewFields.
String
-> TableFields writeFields viewFields
-> Table writeFields viewFields
Table String
t (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 TableFields b c
tp)
dimap a -> b
f c -> d
g (TableWithSchema String
s String
t TableFields b c
tp) = forall writeFields viewFields.
String
-> String
-> TableFields writeFields viewFields
-> Table writeFields viewFields
TableWithSchema String
s String
t (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 TableFields b c
tp)