Export pfmap instead of unsafeCastPi.

relational-query/src/Database/Relational/Query/Pi.hs

@@ -11,7 +11,7 @@
 -- Contains normal interfaces.
 module Database.Relational.Query.Pi (
   -- * Projection path
-  Pi, piZip, (<.>), (<?.>), (<??.>),
+  Pi, pfmap, piZip, (<.>), (<?.>), (<??.>),
 
   id', fst', snd'
   ) where
@@ -22,7 +22,7 @@ import Database.Record.Persistable
   (runPersistableRecordWidth)
 
 import Database.Relational.Query.Pi.Unsafe
-  (Pi, piZip, (<.>), (<?.>), (<??.>), definePi)
+  (Pi, pfmap, piZip, (<.>), (<?.>), (<??.>), definePi)
 
 -- | Identity projection path.
 id' :: PersistableWidth a => Pi a a

relational-query/src/Database/Relational/Query/Pi/Unsafe.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 -- |
 -- Module      : Database.Relational.Query.Pi.Unsafe
@@ -15,6 +16,7 @@ module Database.Relational.Query.Pi.Unsafe (
   -- * Projection path
   Pi,
 
+  pfmap,
   piZip, unsafeCastPi,
 
   width',
@@ -35,6 +37,8 @@ import Database.Record.Persistable
   (PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth, (<&>),
    PersistableWidth (persistableWidth), maybeWidth)
 
+import Database.Relational.Query.Pure (ProductConstructor (..))
+
 -- | Projection path primary structure type.
 data Pi' r0 r1 = Leftest Int
                | Map [Int]
@@ -63,13 +67,21 @@ unsafeExpandIndexes = d  where
   d (Pi (Leftest i) w) = [ i .. i + width - 1 ]  where
     width = runPersistableRecordWidth w
 
--- | Unsafely cast result type of Pi.
-unsafeCastPi :: Pi a b' -> Pi a b
-unsafeCastPi =  c  where
+unsafeCast :: Pi a b' -> Pi a b
+unsafeCast =  c  where
   d (Leftest i) = Leftest i
   d (Map m)     = Map m
   c (Pi p w)    = Pi (d p) (unsafePersistableRecordWidth . runPersistableRecordWidth $ w)
 
+-- | Unsafely cast result type of Pi.
+unsafeCastPi :: Pi a b' -> Pi a b
+unsafeCastPi =  unsafeCast
+
+-- | Projectable fmap of 'Pi' type.
+pfmap :: ProductConstructor (a -> b)
+      => (a -> b) -> Pi r a -> Pi r b
+_ `pfmap` p = unsafeCast p
+
 -- | Zipping two projection path.
 piZip :: Pi a b -> Pi a c -> Pi a (b, c)
 piZip b@(Pi _ wb) c@(Pi _ wc) =

relational-query/src/Database/Relational/Query/Projectable.hs

@@ -82,6 +82,7 @@ import qualified Database.Relational.Query.Expr as Expr
 import qualified Database.Relational.Query.Expr.Unsafe as UnsafeExpr
 
 import Database.Relational.Query.Pi (Pi, piZip)
+import qualified Database.Relational.Query.Pi as Pi
 import Database.Relational.Query.Pi.Unsafe (unsafeCastPi)
 
 import Database.Relational.Query.Pure (ProductConstructor (..))
@@ -539,7 +540,7 @@ instance ProjectableApplicative (Projection c) where
 
 -- | Compose seed of projection path 'Pi' which has record result type.
 instance ProjectableFunctor (Pi a) where
-  _ |$| p = unsafeCastPi p
+  (|$|) = Pi.pfmap
 
 -- | Compose projection path 'Pi' which has record result type using applicative style.
 instance ProjectableApplicative (Pi a) where