Use Opaleye adaptors (#190)

* Add htraverseP

* Add traverseFieldP

* Define and use fromOpaleyespec

* Use traverseFieldP

* Add htraversePWithField and use it in valuesspec

* Use aggregatorApply

* Update HTable.hs

Co-authored-by: Ollie Charles <ollie@ocharles.org.uk>
Co-authored-by: Shane <shane.obrien@circuithub.com>

rel8.cabal

@@ -27,7 +27,7 @@ library
     , comonad
     , contravariant
     , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0
-    , opaleye >= 0.9.1.0 && <= 0.9.3.2
+    , opaleye ^>= 0.9.3.3
     , pretty
     , profunctors
     , product-profunctors

src/Rel8/Expr/Opaleye.hs

@@ -10,7 +10,7 @@ module Rel8.Expr.Opaleye
   , scastExpr, sunsafeCastExpr
   , unsafeLiteral
   , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr
-  , toColumn, fromColumn
+  , toColumn, fromColumn, traverseFieldP
   )
 where
 
@@ -27,6 +27,9 @@ import Rel8.Schema.Null ( Unnullify, Sql )
 import Rel8.Type ( DBType, typeInformation )
 import Rel8.Type.Information ( TypeInformation(..) )
 
+-- profunctors
+import Data.Profunctor ( Profunctor, dimap )
+
 
 castExpr :: Sql DBType a => Expr a -> Expr a
 castExpr = scastExpr typeInformation
@@ -80,6 +83,12 @@ traversePrimExpr :: Functor f
 traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr
 
 
+traverseFieldP :: Profunctor p
+  => p (Opaleye.Field_ n x) (Opaleye.Field_ m y)
+  -> p (Expr a) (Expr b)
+traverseFieldP =  dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)
+
+
 toColumn :: Opaleye.PrimExpr -> Opaleye.Field_ n b
 toColumn = Opaleye.Column
 

src/Rel8/Schema/HTable.hs

@@ -16,7 +16,7 @@
 module Rel8.Schema.HTable
   ( HTable (HField, HConstrainTable)
   , hfield, htabulate, htraverse, hdicts, hspecs
-  , hmap, htabulateA
+  , hmap, htabulateA, htraverseP, htraversePWithField
   )
 where
 
@@ -32,6 +32,12 @@ import GHC.Generics
   )
 import Prelude
 
+-- profunctors
+import Data.Profunctor ( rmap, Profunctor (lmap) )
+
+-- product-profunctors
+import Data.Profunctor.Product ( ProductProfunctor ((****)) )
+
 -- rel8
 import Rel8.Schema.Dict ( Dict )
 import Rel8.Schema.Spec ( Spec )
@@ -41,7 +47,6 @@ import qualified Rel8.Schema.Kind as K
 -- semigroupoids
 import Data.Functor.Apply ( Apply, (<.>) )
 
-
 -- | A @HTable@ is a functor-indexed/higher-kinded data type that is
 -- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and
 -- specified ('hspecs').
@@ -124,6 +129,22 @@ htabulateA :: (HTable t, Apply m)
 htabulateA f = htraverse getCompose $ htabulate $ Compose . f
 {-# INLINABLE htabulateA #-}
 
+newtype ApplyP p a b = ApplyP { unApplyP :: p a b }
+
+instance Profunctor p => Functor (ApplyP p a) where
+  fmap f = ApplyP . rmap f . unApplyP
+
+instance ProductProfunctor p => Apply (ApplyP p a) where
+  ApplyP f <.> ApplyP x = ApplyP (rmap id f **** x)
+
+htraverseP :: (HTable t, ProductProfunctor p)
+  => (forall a. p (f a) (g a)) -> p (t f) (t g)
+htraverseP f = htraversePWithField (const f)
+
+htraversePWithField :: (HTable t, ProductProfunctor p)
+  => (forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)
+htraversePWithField f = unApplyP $ htabulateA $ \field -> ApplyP $
+  lmap (flip hfield field) (f field)
 
 type GHField :: K.HTable -> Type -> Type
 newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)

src/Rel8/Table/Opaleye.hs

@@ -28,15 +28,14 @@ where
 -- base
 import Data.Functor.Const ( Const( Const ), getConst )
 import Data.List.NonEmpty ( NonEmpty )
-import Prelude hiding ( undefined )
+import Prelude
 
 -- opaleye
+import qualified Opaleye.Adaptors as Opaleye
+import qualified Opaleye.Field as Opaleye ( Field_ )
 import qualified Opaleye.Internal.Aggregate as Opaleye
-import qualified Opaleye.Internal.Binary as Opaleye
-import qualified Opaleye.Internal.Distinct as Opaleye
 import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 import qualified Opaleye.Internal.PackMap as Opaleye
-import qualified Opaleye.Internal.Unpackspec as Opaleye
 import qualified Opaleye.Internal.Values as Opaleye
 import qualified Opaleye.Table as Opaleye
 
@@ -48,27 +47,25 @@ import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Opaleye
   ( fromPrimExpr, toPrimExpr
-  , traversePrimExpr
-  , fromColumn, toColumn
-  , scastExpr
+  , scastExpr, traverseFieldP
   )
-import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )
+import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,
+                            htraverseP, htraversePWithField )
 import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )
 import Rel8.Schema.Spec ( Spec(..) )
 import Rel8.Schema.Table ( TableSchema(..), ppTable )
 import Rel8.Table ( Table, fromColumns, toColumns )
-import Rel8.Table.Undefined ( undefined )
+import Rel8.Type.Information ( typeName )
 
 -- semigroupoids
 import Data.Functor.Apply ( WrappedApplicative(..) )
+import Data.Profunctor.Product ( ProductProfunctor )
 
 
 aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs
-aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->
-  fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
-    WrapApplicative $ case hfield (toColumns aggregates) field of
-      Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner)) ->
-        inner f ()
+aggregator = dimap toColumns fromColumns $
+             htraverseP $
+             lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply
 
 
 attributes :: Selects names exprs => TableSchema names -> exprs
@@ -79,22 +76,19 @@ attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->
         show (ppTable schema) <> "." <> show (ppColumn column)
 
 
+fromOpaleyespec :: (ProductProfunctor p, Table Expr a)
+  => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)
+  -> p a a
+fromOpaleyespec x =
+  dimap toColumns fromColumns (htraverseP (traverseFieldP x))
+
+
 binaryspec :: Table Expr a => Opaleye.Binaryspec a a
-binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->
-  fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
-    WrapApplicative $
-      case (hfield (toColumns as) field, hfield (toColumns bs) field) of
-        (a, b) -> fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)
+binaryspec = fromOpaleyespec Opaleye.binaryspecField
 
 
 distinctspec :: Table Expr a => Opaleye.Distinctspec a a
-distinctspec =
-  Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->
-    fmap fromColumns .
-    unwrapApplicative .
-    htraverse
-      (\a -> WrapApplicative $ fromPrimExpr <$> f (Nothing, toPrimExpr a)) .
-    toColumns
+distinctspec = fromOpaleyespec Opaleye.distinctspecField
 
 
 exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr
@@ -126,21 +120,19 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $
   where
     go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)
     go (Name name) =
-      dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
+      traverseFieldP $
         Opaleye.requiredTableField name
 
 
 unpackspec :: Table Expr a => Opaleye.Unpackspec a a
-unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
-  fmap fromColumns .
-  unwrapApplicative .
-  htraverse (WrapApplicative . traversePrimExpr f) .
-  toColumns
+unpackspec = fromOpaleyespec Opaleye.unpackspecField
 {-# INLINABLE unpackspec #-}
 
 
 valuesspec :: Table Expr a => Opaleye.Valuesspec a a
-valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
+valuesspec = dimap toColumns fromColumns $
+  htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)
+  where typeName = Rel8.Type.Information.typeName . info . hfield hspecs
 
 
 view :: Selects names exprs => names -> exprs
@@ -149,15 +141,6 @@ view columns = fromColumns $ htabulate $ \field ->
     Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column
 
 
-toPackMap :: Table Expr a
-  => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
-toPackMap as = Opaleye.PackMap $ \f () ->
-  fmap fromColumns $
-  unwrapApplicative .
-  htraverse (WrapApplicative . traversePrimExpr f) $
-  toColumns as
-
-
 -- | Transform a table by adding 'CAST' to all columns. This is most useful for
 -- finalising a SELECT or RETURNING statement, guaranteed that the output
 -- matches what is encoded in each columns TypeInformation.