Add htraversePWithField and use it in valuesspec

rel8.cabal

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

src/Rel8/Schema/HTable.hs

@@ -16,7 +16,8 @@
 module Rel8.Schema.HTable
   ( HTable (HField, HConstrainTable)
   , hfield, htabulate, htraverse, hdicts, hspecs
-  , hmap, htabulateA, htraverseP
+  , hmap, htabulateA, htraverseP, htraversePWithField
+  , ApplyP (ApplyP, unApplyP)
   )
 where
 
@@ -138,8 +139,12 @@ instance ProductProfunctor p => Apply (ApplyP p a) where
 
 htraverseP :: (HTable t, ProductProfunctor p)
   => (forall a. p (f a) (g a)) -> p (t f) (t g)
-htraverseP f = unApplyP $ htabulateA $ \field -> ApplyP $
-  lmap (flip hfield field) f
+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,7 +28,7 @@ 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
@@ -47,16 +47,15 @@ import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Opaleye
   ( fromPrimExpr, toPrimExpr
-  , traversePrimExpr
   , scastExpr, traverseFieldP
   )
-import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate,
-                            htraverseP )
+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(..) )
@@ -133,7 +132,9 @@ unpackspec = fromOpaleyespec Opaleye.unpackspecField
 
 
 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
@@ -142,15 +143,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.