@@ -28,15 +28,14 @@ where
2828-- base
2929import Data.Functor.Const ( Const( Const ), getConst )
3030import Data.List.NonEmpty ( NonEmpty )
31−import Prelude hiding ( undefined )
31+import Prelude
3232
3333-- opaleye
34+import qualified Opaleye.Adaptors as Opaleye
35+import qualified Opaleye.Field as Opaleye ( Field_ )
3436import qualified Opaleye.Internal.Aggregate as Opaleye
35−import qualified Opaleye.Internal.Binary as Opaleye
36−import qualified Opaleye.Internal.Distinct as Opaleye
3737import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
3838import qualified Opaleye.Internal.PackMap as Opaleye
39−import qualified Opaleye.Internal.Unpackspec as Opaleye
4039import qualified Opaleye.Internal.Values as Opaleye
4140import qualified Opaleye.Table as Opaleye
4241
@@ -48,27 +47,25 @@ import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )
4847import Rel8.Expr ( Expr )
4948import Rel8.Expr.Opaleye
5049 ( fromPrimExpr, toPrimExpr
51− , traversePrimExpr
52− , fromColumn, toColumn
53− , scastExpr
50+ , scastExpr, traverseFieldP
5451 )
55−import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )
52+import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,
53+ htraverseP, htraversePWithField )
5654import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )
5755import Rel8.Schema.Spec ( Spec(..) )
5856import Rel8.Schema.Table ( TableSchema(..), ppTable )
5957import Rel8.Table ( Table, fromColumns, toColumns )
60−import Rel8.Table.Undefined ( undefined )
58+import Rel8.Type.Information ( typeName )
6159
6260-- semigroupoids
6361import Data.Functor.Apply ( WrappedApplicative(..) )
62+import Data.Profunctor.Product ( ProductProfunctor )
6463
6564
6665aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs
67−aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->
68− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
69− WrapApplicative $ case hfield (toColumns aggregates) field of
70− Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner)) ->
71− inner f ()
66+aggregator = dimap toColumns fromColumns $
67+ htraverseP $
68+ lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply
7269
7370
7471attributes :: Selects names exprs => TableSchema names -> exprs
@@ -79,22 +76,19 @@ attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->
7976 show (ppTable schema) <> "." <> show (ppColumn column)
8077
8178
79+fromOpaleyespec :: (ProductProfunctor p, Table Expr a)
80+ => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)
81+ -> p a a
82+fromOpaleyespec x =
83+ dimap toColumns fromColumns (htraverseP (traverseFieldP x))
84+
85+
8286binaryspec :: Table Expr a => Opaleye.Binaryspec a a
83−binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->
84− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
85− WrapApplicative $
86− case (hfield (toColumns as) field, hfield (toColumns bs) field) of
87− (a, b) -> fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)
87+binaryspec = fromOpaleyespec Opaleye.binaryspecField
8888
8989
9090distinctspec :: Table Expr a => Opaleye.Distinctspec a a
91−distinctspec =
92− Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->
93− fmap fromColumns .
94− unwrapApplicative .
95− htraverse
96− (\a -> WrapApplicative $ fromPrimExpr <$> f (Nothing, toPrimExpr a)) .
97− toColumns
91+distinctspec = fromOpaleyespec Opaleye.distinctspecField
9892
9993
10094exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr
@@ -126,21 +120,19 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $
126120 where
127121 go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)
128122 go (Name name) =
129− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
123+ traverseFieldP $
130124 Opaleye.requiredTableField name
131125
132126
133127unpackspec :: Table Expr a => Opaleye.Unpackspec a a
134−unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
135− fmap fromColumns .
136− unwrapApplicative .
137− htraverse (WrapApplicative . traversePrimExpr f) .
138− toColumns
128+unpackspec = fromOpaleyespec Opaleye.unpackspecField
139129{-# INLINABLE unpackspec #-}
140130
141131
142132valuesspec :: Table Expr a => Opaleye.Valuesspec a a
143−valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
133+valuesspec = dimap toColumns fromColumns $
134+ htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)
135+ where typeName = Rel8.Type.Information.typeName . info . hfield hspecs
144136
145137
146138view :: Selects names exprs => names -> exprs
@@ -149,15 +141,6 @@ view columns = fromColumns $ htabulate $ \field ->
149141 Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column
150142
151143
152−toPackMap :: Table Expr a
153− => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
154−toPackMap as = Opaleye.PackMap $ \f () ->
155− fmap fromColumns $
156− unwrapApplicative .
157− htraverse (WrapApplicative . traversePrimExpr f) $
158− toColumns as
159−
160−
161144-- | Transform a table by adding 'CAST' to all columns. This is most useful for
162145-- finalising a SELECT or RETURNING statement, guaranteed that the output
163146-- matches what is encoded in each columns TypeInformation.