Add selectOne

src/Database/Esqueleto.hs

@@ -97,6 +97,7 @@ module Database.Esqueleto {-# WARNING "This module will switch over to the Exper
   , SqlExpr
   , SqlEntity
   , select
+  , selectFirst
   , selectSource
   , delete
   , deleteCount
@@ -129,7 +130,7 @@ module Database.Esqueleto {-# WARNING "This module will switch over to the Exper
   ) where
 
 import Database.Esqueleto.Legacy
-import Database.Esqueleto.Internal.PersistentImport
+import Database.Esqueleto.Internal.PersistentImport hiding (selectFirst)
 
 
 -- $setup

src/Database/Esqueleto/Experimental.hs

@@ -190,6 +190,7 @@ module Database.Esqueleto.Experimental
     , SqlExpr
     , SqlEntity
     , select
+    , selectFirst
     , selectSource
     , delete
     , deleteCount
@@ -219,7 +220,7 @@ module Database.Esqueleto.Experimental
     ) where
 
 import Database.Esqueleto.Internal.Internal hiding (From, from, on)
-import Database.Esqueleto.Internal.PersistentImport
+import Database.Esqueleto.Internal.PersistentImport hiding (selectFirst)
 
 import Database.Esqueleto.Experimental.From
 import Database.Esqueleto.Experimental.From.CommonTableExpression

src/Database/Esqueleto/Internal/Internal.hs

@@ -2539,6 +2539,34 @@ select query = do
     conn <- R.ask
     liftIO $ with res $ flip R.runReaderT conn . runSource
 
+-- | Execute an @esqueleto@ @SELECT@ query inside @persistent@'s
+-- 'SqlPersistT' monad and return the first entry wrapped in a @Maybe@.
+--
+-- === __Example usage__
+--
+-- @
+-- firstPerson :: MonadIO m => SqlPersistT m (Maybe Person)
+-- firstPerson =
+--  'selectFirst' $
+--      'from' $ \person ->
+--          return person
+-- @
+--
+-- The above query is equivalent to a 'select' combined with 'limit' but you
+-- would still have to transform the results from a list:
+--
+-- @
+-- firstPerson :: MonadIO m => SqlPersistT m [Person]
+-- firstPerson =
+--  'select' $
+--      'from' $ \person -> do
+--          'limit' 1
+--          return person
+-- @
+
+selectFirst :: (SqlSelect a r, MonadIO m) => SqlQuery a -> SqlReadT m (Maybe r)
+selectFirst query = fmap Maybe.listToMaybe $ select $ limit 1 >> query
+
 -- | (Internal) Run a 'C.Source' of rows.
 runSource
     :: Monad m

src/Database/Esqueleto/Legacy.hs

@@ -98,6 +98,7 @@ module Database.Esqueleto.Legacy
   , SqlExpr
   , SqlEntity
   , select
+  , selectFirst
   , selectSource
   , delete
   , deleteCount
@@ -130,7 +131,7 @@ module Database.Esqueleto.Legacy
   ) where
 
 import Database.Esqueleto.Internal.Internal
-import Database.Esqueleto.Internal.PersistentImport
+import Database.Esqueleto.Internal.PersistentImport hiding (selectFirst)
 
 
 -- $setup

test/Common/Test.hs

@@ -297,6 +297,27 @@ testSubSelect = do
                 Right xs ->
                     xs `shouldBe` []
 
+testSelectFirst :: SpecDb
+testSelectFirst =
+    describe "selectFirst" $ do
+        let personQuery =
+                selectFirst $
+                    from $ \person -> do
+                        where_ $ person ^. PersonFavNum >=. val 1
+                        orderBy [asc (person ^. PersonId)]
+                        return $ person ^. PersonId
+        itDb "returns Just" $ do
+            person <- insert' p1
+            _ <- insert' p2
+            res <- personQuery
+            asserting $
+                res `shouldBe` Just (Value $ entityKey person)
+
+        itDb "returns Nothing" $ do
+            res <- personQuery
+            asserting $
+                res `shouldBe` (Nothing :: Maybe (Value PersonId))
+
 testSelectSource :: SpecDb
 testSelectSource = do
     describe "selectSource" $ do
@@ -2271,10 +2292,11 @@ listsEqualOn :: (HasCallStack, Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) ->
 listsEqualOn a b f = map f a `shouldBe` map f b
 
 tests :: SpecDb
-tests = do
+tests =
     describe "Esqueleto" $ do
         testSelect
         testSubSelect
+        testSelectFirst
         testSelectSource
         testSelectFrom
         testSelectJoin
@@ -2389,4 +2411,3 @@ shouldBeOnClauseWithoutMatchingJoinException ea =
             pure ()
         _ ->
             expectationFailure $ "Expected OnClauseWithMatchingJoinException, got: " <> show ea
-