Merge pull request #130 from pseudonom/master

Add `ToBaseId`

src/Database/Esqueleto.hs

@@ -52,7 +52,8 @@ module Database.Esqueleto
              , subList_select, subList_selectDistinct, valList, justList
              , in_, notIn, exists, notExists
              , set, (=.), (+=.), (-=.), (*=.), (/=.)
-             , case_ )
+             , case_, toBaseId)
+  , ToBaseId(..)
   , when_
   , then_
   , else_

src/Database/Esqueleto/Internal/Language.hs

@@ -32,6 +32,7 @@ module Database.Esqueleto.Internal.Language
   , Insertion
   , LockingKind(..)
   , SqlString
+  , ToBaseId(..)
     -- * The guts
   , JoinKind(..)
   , IsJoinKind(..)
@@ -43,7 +44,6 @@ module Database.Esqueleto.Internal.Language
   , else_
   ) where
 
-import Control.Applicative (Applicative(..), (<$>))
 import Control.Exception (Exception)
 import Data.Int (Int64)
 import Data.Typeable (Typeable)
@@ -51,7 +51,6 @@ import Database.Esqueleto.Internal.PersistentImport
 import Text.Blaze.Html (Html)
 
 import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as BL
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 
@@ -555,6 +554,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 +872,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.
 --

src/Database/Esqueleto/Internal/Sql.hs

@@ -50,7 +50,6 @@ module Database.Esqueleto.Internal.Sql
   , veryUnsafeCoerceSqlExprValueList
   ) where
 
-import Control.Applicative (Applicative(..), (<$>), (<$))
 import Control.Arrow ((***), first)
 import Control.Exception (throw, throwIO)
 import Control.Monad (ap, MonadPlus(..), liftM)
@@ -60,7 +59,7 @@ import Control.Monad.Trans.Resource (MonadResource)
 import Data.Acquire (with, allocateAcquire, Acquire)
 import Data.Int (Int64)
 import Data.List (intersperse)
-import Data.Monoid (Last(..), Monoid(..), (<>))
+import Data.Monoid (Last(..), (<>))
 import Data.Proxy (Proxy(..))
 import Database.Esqueleto.Internal.PersistentImport
 import Database.Persist.Sql.Util (entityColumnNames, entityColumnCount, parseEntityValues, isIdField, hasCompositeKey)
@@ -417,6 +416,7 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
     where
       toDistinctOn :: SqlExpr OrderBy -> SqlExpr DistinctOn
       toDistinctOn (EOrderBy _ f) = EDistinctOn f
+      toDistinctOn EOrderRandom = error "toDistinctOn get an EOrderRandom but expect an EOrderBy"
 
   sub_select         = sub SELECT
   sub_selectDistinct = sub_select . distinct
@@ -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]
@@ -645,7 +647,7 @@ unsafeSqlBinOpComposite op sep a b = ERaw Parens $ compose (listify a) (listify
 
     deconstruct :: (TLB.Builder, [PersistValue]) -> ([TLB.Builder], [PersistValue])
     deconstruct ("?", [PersistList vals]) = (replicate (length vals) "?", vals)
-    deconstruct (b, []) = (TLB.fromLazyText <$> TL.splitOn "," (TLB.toLazyText b), [])
+    deconstruct (b', []) = (TLB.fromLazyText <$> TL.splitOn "," (TLB.toLazyText b'), [])
     deconstruct x = err $ "cannot deconstruct " ++ show x ++ "."
 
     compose f1 f2 info

test/Test.hs

@@ -18,21 +18,17 @@
  #-}
 module Main (main) where
 
-import Control.Applicative ((<$>))
-import Control.Arrow ((&&&))
-import Control.Exception (IOException)
 import Control.Monad (forM_, replicateM, replicateM_, void)
 import Control.Monad.IO.Class (MonadIO(liftIO))
 import Control.Monad.Logger (MonadLogger(..), runStderrLoggingT, runNoLoggingT)
 import Control.Monad.Trans.Control (MonadBaseControl(..))
 import Control.Monad.Trans.Reader (ReaderT)
 import Data.Char (toLower, toUpper)
-import Data.List (sortBy)
 import Data.Monoid ((<>))
-import Data.Ord (comparing)
 import Database.Esqueleto
 #if   defined (WITH_POSTGRESQL)
 import Database.Persist.Postgresql (withPostgresqlConn)
+import qualified Database.Esqueleto.PostgreSQL as EP
 #elif defined (WITH_MYSQL)
 import Database.Persist.MySQL ( withMySQLConn
                               , connectHost
@@ -53,7 +49,6 @@ import qualified Control.Monad.Trans.Resource as R
 import qualified Data.List as L
 import qualified Data.Set as S
 import qualified Data.Text.Lazy.Builder as TLB
-import qualified Database.Esqueleto.PostgreSQL as EP
 import qualified Database.Esqueleto.Internal.Sql as EI
 
 
@@ -808,8 +803,6 @@ main = do
                      orderBy [asc title]
                      return title
               liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ]
-      it "works on a simple example (selectDistinct)" $
-        selDistTest selectDistinct
 
       it "works on a simple example (select . distinct)" $
         selDistTest (select . distinct)
@@ -1307,15 +1300,15 @@ main = do
       -- reaction to the clause.
       let sanityCheck kind syntax = do
             let complexQuery =
-                  from $ \(p1 `InnerJoin` p2) -> do
+                  from $ \(pl `InnerJoin` pr) -> do
-                  on (p1 ^. PersonName ==. p2 ^. PersonName)
+                  on (pl ^. PersonName ==. pr ^. PersonName)
-                  where_ (p1 ^. PersonFavNum >. val 2)
+                  where_ (pl ^. PersonFavNum >. val 2)
-                  orderBy [desc (p2 ^. PersonAge)]
+                  orderBy [desc (pr ^. PersonAge)]
                   limit 3
                   offset 9
-                  groupBy (p1 ^. PersonId)
+                  groupBy (pl ^. PersonId)
                   having (countRows <. val (0 :: Int))
-                  return (p1, p2)
+                  return (pl, pr)
                 queryWithClause1 = do
                   r <- complexQuery
                   locking kind