From 970deabfc2fb192fb3c0657b39ee5eca8d818f90 Mon Sep 17 00:00:00 2001
From: Eric Easley <eric@frontrowed.com>
Date: Fri, 5 Feb 2016 15:32:19 -0800
Subject: [PATCH] Add `ToBaseId`

---
 src/Database/Esqueleto.hs                   |  2 +-
 src/Database/Esqueleto/Internal/Language.hs | 43 +++++++++++++++++++++
 src/Database/Esqueleto/Internal/Sql.hs      |  2 +
 3 files changed, 46 insertions(+), 1 deletion(-)

diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs
index 33085ec..413c76c 100644
--- a/src/Database/Esqueleto.hs
+++ b/src/Database/Esqueleto.hs
@@ -52,7 +52,7 @@ module Database.Esqueleto
              , subList_select, subList_selectDistinct, valList, justList
              , in_, notIn, exists, notExists
              , set, (=.), (+=.), (-=.), (*=.), (/=.)
-             , case_ )
+             , case_, toBaseId)
   , when_
   , then_
   , else_
diff --git a/src/Database/Esqueleto/Internal/Language.hs b/src/Database/Esqueleto/Internal/Language.hs
index 9b8a56c..ff42e3d 100644
--- a/src/Database/Esqueleto/Internal/Language.hs
+++ b/src/Database/Esqueleto/Internal/Language.hs
@@ -32,6 +32,7 @@ module Database.Esqueleto.Internal.Language
   , Insertion
   , LockingKind(..)
   , SqlString
+  , ToBaseId(..)
     -- * The guts
   , JoinKind(..)
   , IsJoinKind(..)
@@ -555,6 +556,42 @@ class (Functor query, Applicative query, Monad query) =>
   -- /Since: 2.1.2/
   case_ :: PersistField a => [(expr (Value Bool), expr (Value a))] -> expr (Value a) -> expr (Value a)
 
+  -- | Convert an entity's key into another entity's.
+  --
+  -- This function is to be used when you change an entity's @Id@ to be
+  -- that of another entity.  For example:
+  --
+  -- @
+  -- Bar
+  --   barNum Int
+  -- Foo
+  --   Id BarId
+  --   fooNum Int
+  -- @
+  --
+  -- For this example, declare:
+  --
+  -- @
+  -- instance ToBaseId Foo where
+  --   type BaseEnt Foo = Bar
+  --   toBaseIdWitness = FooKey
+  -- @
+  --
+  -- Now you're able to write queries such as:
+  --
+  -- @
+  -- 'select' $
+  -- 'from' $ \(bar `'InnerJoin`` foo) -> do
+  -- 'on' ('toBaseId' (foo '^.' FooId) '==.' bar '^.' BarId)
+  -- return (bar, foo)
+  -- @
+  --
+  -- Note: this function may be unsafe to use in conditions not like the
+  -- one of the example above.
+  --
+  -- /Since: 2.4.3/
+  toBaseId :: ToBaseId ent => expr (Value (Key ent)) -> expr (Value (Key (BaseEnt ent)))
+
 {-# DEPRECATED sub_selectDistinct "Since 2.2.4: use 'sub_select' and 'distinct'." #-}
 {-# DEPRECATED subList_selectDistinct "Since 2.2.4: use 'subList_select' and 'distinct'." #-}
 
@@ -837,6 +874,12 @@ instance SqlString Html where
 -- | /Since: 2.4.0/
 instance SqlString a => SqlString (Maybe a) where
 
+-- | Class that enables one to use 'toBaseId' to convert an entity's
+-- key on a query into another (cf. 'toBaseId').
+class ToBaseId ent where
+  type BaseEnt ent :: *
+  toBaseIdWitness :: Key (BaseEnt ent) -> Key ent
+
 
 -- | @FROM@ clause: bring entities into scope.
 --
diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs
index 04867a0..aa1f793 100644
--- a/src/Database/Esqueleto/Internal/Sql.hs
+++ b/src/Database/Esqueleto/Internal/Sql.hs
@@ -524,6 +524,8 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
   (EInsert _ _) <&> (ECompositeKey _) = unexpectedCompositeKeyError "(<&>)"
 
   case_ = unsafeSqlCase
+  toBaseId = veryUnsafeCoerceSqlExprValue
+
 
 instance ToSomeValues SqlExpr (SqlExpr (Value a)) where
   toSomeValues a = [SomeValue a]