From aec46d88a577cd245644865b2a9f191f07e96b1c Mon Sep 17 00:00:00 2001
From: Kei Hibino <ex8k.hibino@gmail.com>
Date: Thu, 26 Dec 2013 02:55:11 +0900
Subject: [PATCH] Add weaken applicative functor to compose record type on
 projection.

---
 .../src/Database/Relational/Query/Expr.hs     |  2 +-
 .../Database/Relational/Query/Pi/Unsafe.hs    | 11 +++-
 .../Database/Relational/Query/Projectable.hs  | 53 ++++++++++++++++++-
 .../Database/Relational/Query/Projection.hs   |  6 ++-
 4 files changed, 67 insertions(+), 5 deletions(-)

diff --git a/relational-query/src/Database/Relational/Query/Expr.hs b/relational-query/src/Database/Relational/Query/Expr.hs
index 7616ee36..10bf90b8 100644
--- a/relational-query/src/Database/Relational/Query/Expr.hs
+++ b/relational-query/src/Database/Relational/Query/Expr.hs
@@ -21,7 +21,7 @@ module Database.Relational.Query.Expr (
   valueExpr,
 
   -- * Type conversion
-  just, fromJust,
+  just, fromJust, unsafeCastExpr,
 
   exprAnd
   ) where
diff --git a/relational-query/src/Database/Relational/Query/Pi/Unsafe.hs b/relational-query/src/Database/Relational/Query/Pi/Unsafe.hs
index b72798b3..bc2db984 100644
--- a/relational-query/src/Database/Relational/Query/Pi/Unsafe.hs
+++ b/relational-query/src/Database/Relational/Query/Pi/Unsafe.hs
@@ -15,7 +15,7 @@ module Database.Relational.Query.Pi.Unsafe (
   -- * Projection path
   Pi,
 
-  piZip,
+  piZip, unsafeCastPi,
 
   width',
 
@@ -32,7 +32,7 @@ import Prelude hiding (pi)
 import Data.Array (listArray, (!))
 
 import Database.Record.Persistable
-  (PersistableRecordWidth, runPersistableRecordWidth, (<&>),
+  (PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth, (<&>),
    PersistableWidth (persistableWidth), maybeWidth)
 
 -- | Projection path primary structure type.
@@ -63,6 +63,13 @@ 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
+  d (Leftest i) = Leftest i
+  d (Map m)     = Map m
+  c (Pi p w)    = Pi (d p) (unsafePersistableRecordWidth . runPersistableRecordWidth $ w)
+
 -- | Zipping two projection path.
 piZip :: Pi a b -> Pi a c -> Pi a (b, c)
 piZip b@(Pi _ wb) c@(Pi _ wc) =
diff --git a/relational-query/src/Database/Relational/Query/Projectable.hs b/relational-query/src/Database/Relational/Query/Projectable.hs
index 8b2ac60f..f6e4ff95 100644
--- a/relational-query/src/Database/Relational/Query/Projectable.hs
+++ b/relational-query/src/Database/Relational/Query/Projectable.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
 -- |
 -- Module      : Database.Relational.Query.Projectable
 -- Copyright   : 2013 Kei Hibino
@@ -55,7 +57,12 @@ module Database.Relational.Query.Projectable (
   ProjectableIdZip (..),
 
   -- * 'Maybe' type projecitoins
-  ProjectableMaybe (just, flattenMaybe)
+  ProjectableMaybe (just, flattenMaybe),
+
+  -- * ProjectableFunctor and ProjectableApplicative
+  RecordConstructor (recordConstructor),
+
+  ProjectableFunctor (..), ProjectableApplicative (..), ipfmap
   ) where
 
 import Prelude hiding (pi)
@@ -77,6 +84,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 Database.Relational.Query.Pi.Unsafe (unsafeCastPi)
 
 import Database.Relational.Query.Projection
   (Projection, unsafeFromColumns, columns,
@@ -499,10 +507,53 @@ instance ProjectableIdZip PlaceHolders where
   leftId  = unsafeCastPlaceHolders
   rightId = unsafeCastPlaceHolders
 
+-- | Specify record constructors which are allowed to define 'ProjectableFunctor'.
+class RecordConstructor r where
+  recordConstructor :: r
+
+-- | Weaken functor on projections.
+class ProjectableFunctor p where
+  -- | Method like 'fmap'.
+  (|$|) :: RecordConstructor (a -> b) => (a -> b) -> p a -> p b
+
+-- | Same as '|$|' other than using infered record constructor.
+ipfmap :: (ProjectableFunctor p, RecordConstructor (a -> b))
+       => p a -> p b
+ipfmap =  (|$|) recordConstructor
+
+-- | Weaken applicative functor on projections.
+class ProjectableFunctor p => ProjectableApplicative p where
+  -- | Method like '<*>'.
+  (|*|) :: p (a -> b) -> p a -> p b
+
+-- | Compose seed of record type 'PlaceHolders'.
+instance ProjectableFunctor PlaceHolders where
+  _ |$| PlaceHolders = PlaceHolders
+
+-- | Compose record type 'PlaceHolders' using applicative style.
+instance ProjectableApplicative PlaceHolders where
+  pf |*| pa = unsafeCastPlaceHolders (pf >< pa)
+
+-- | Compose seed of record type 'Projection'.
+instance ProjectableFunctor (Projection c) where
+  _ |$| p = Projection.unsafeCastProjection p
+
+-- | Compose record type 'Projection' using applicative style.
+instance ProjectableApplicative (Projection c) where
+  pf |*| pa = Projection.unsafeCastProjection $ pf >< pa
+
+-- | Compose seed of projection path 'Pi' which has record result type.
+instance ProjectableFunctor (Pi a) where
+  _ |$| p = unsafeCastPi p
+
+-- | Compose projection path 'Pi' which has record result type using applicative style.
+instance ProjectableApplicative (Pi a) where
+  pf |*| pa = unsafeCastPi $ pf >< pa
 
 infixl 7 .*., ./., ?*?, ?/?
 infixl 6 .+., .-., ?+?, ?-?
 infixl 5 .||., ?||?
+infixl 4 |$|, |*|
 infix  4 .=., .<>., .>., .>=., .<., .<=., `in'`
 infixr 3 `and'`
 infixr 2 `or'`
diff --git a/relational-query/src/Database/Relational/Query/Projection.hs b/relational-query/src/Database/Relational/Query/Projection.hs
index da546d24..3db520f7 100644
--- a/relational-query/src/Database/Relational/Query/Projection.hs
+++ b/relational-query/src/Database/Relational/Query/Projection.hs
@@ -26,7 +26,7 @@ module Database.Relational.Query.Projection (
 
   pi, piMaybe, piMaybe',
 
-  flattenMaybe, just,
+  flattenMaybe, just, unsafeCastProjection,
 
   unsafeToAggregated, unsafeToFlat,
 
@@ -133,6 +133,10 @@ flattenMaybe =  unsafeCast
 just :: Projection c r -> Projection c (Maybe r)
 just =  unsafeCast
 
+-- | Unsafely cast projection result type.
+unsafeCastProjection :: Projection c r -> Projection c r'
+unsafeCastProjection =  unsafeCast
+
 unsafeChangeContext :: Projection c r -> Projection c' r
 unsafeChangeContext =  typedProjection . untypeProjection