haskell/esqueleto
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into matt/sub-select-bug

Browse Source
This commit is contained in:
Chris Allen 2019-09-24 10:27:58 -05:00
commit 966ab2ff98
8 changed files with 79 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
examples/.gitignore vendored Normal file
View File

@ -0,0 +1 @@
*.cabal

19
examples/Blog.hs
View File

@ -9,8 +9,8 @@ module Blog
( runBlogT ( runBlogT
) where ) where
-------------------------------------------------------------------------------
import Control.Monad.Base (MonadBase (..)) import Control.Monad.Base (MonadBase (..))
import Control.Monad.IO.Unlift (MonadUnliftIO(..), wrappedWithRunInIO)
import Control.Monad.Logger (MonadLogger, NoLoggingT (..)) import Control.Monad.Logger (MonadLogger, NoLoggingT (..))
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
@ -18,30 +18,32 @@ import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
defaultLiftBaseWith, defaultLiftBaseWith,
defaultRestoreM) defaultRestoreM)
import Database.Persist.Postgresql (ConnectionString) import Database.Persist.Postgresql (ConnectionString)
-------------------------------------------------------------------------------
newtype BlogT m a = BlogT { unBlogT :: NoLoggingT (ReaderT ConnectionString m) a } newtype BlogT m a = BlogT { unBlogT :: NoLoggingT (ReaderT ConnectionString m) a }
deriving (Functor, Applicative, Monad, MonadLogger, MonadReader ConnectionString, MonadIO) deriving ( Functor
, Applicative
, Monad
, MonadLogger
, MonadReader ConnectionString
, MonadIO
)
instance MonadUnliftIO m => MonadUnliftIO (BlogT m) where
withRunInIO = wrappedWithRunInIO BlogT unBlogT
-------------------------------------------------------------------------------
instance MonadTrans BlogT where instance MonadTrans BlogT where
lift = BlogT . lift . lift lift = BlogT . lift . lift
-------------------------------------------------------------------------------
deriving instance (MonadBase b m) => MonadBase b (BlogT m) deriving instance (MonadBase b m) => MonadBase b (BlogT m)
-------------------------------------------------------------------------------
instance MonadBaseControl b m => MonadBaseControl b (BlogT m) where instance MonadBaseControl b m => MonadBaseControl b (BlogT m) where
type StM (BlogT m) a = ComposeSt BlogT m a type StM (BlogT m) a = ComposeSt BlogT m a
liftBaseWith = defaultLiftBaseWith liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM restoreM = defaultRestoreM
-------------------------------------------------------------------------------
instance MonadTransControl BlogT where instance MonadTransControl BlogT where
type StT BlogT a = StT NoLoggingT (StT (ReaderT ConnectionString) a) type StT BlogT a = StT NoLoggingT (StT (ReaderT ConnectionString) a)
liftWith f = BlogT $ liftWith $ \run -> liftWith f = BlogT $ liftWith $ \run ->
@ -50,7 +52,6 @@ instance MonadTransControl BlogT where
restoreT = BlogT . restoreT . restoreT restoreT = BlogT . restoreT . restoreT
-------------------------------------------------------------------------------
runBlogT :: ConnectionString -> BlogT m a -> m a runBlogT :: ConnectionString -> BlogT m a -> m a
runBlogT backend (BlogT m) = runBlogT backend (BlogT m) =
runReaderT (runNoLoggingT m) backend runReaderT (runNoLoggingT m) backend

31
examples/Main.hs
View File

@ -9,17 +9,18 @@
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Main module Main
( main ( main
) where ) where
-------------------------------------------------------------------------------
import Blog import Blog
import Control.Monad (void) import Control.Monad (void)
import Control.Monad (forM_) import Control.Monad (forM_)
import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Logger (MonadLogger) import Control.Monad.Logger (MonadLogger)
import Control.Monad.Reader (MonadReader (..), runReaderT) import Control.Monad.Reader (MonadReader (..), runReaderT)
import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Control (MonadBaseControl)
@ -27,10 +28,15 @@ import Data.Monoid ((<>))
import Database.Esqueleto import Database.Esqueleto
import Database.Persist.Postgresql (ConnectionString, import Database.Persist.Postgresql (ConnectionString,
withPostgresqlConn) withPostgresqlConn)
import Database.Persist.TH (mkDeleteCascade, mkMigrate, import Database.Persist.TH ( AtLeastOneUniqueKey(..)
mkPersist, persistLowerCase, , OnlyOneUniqueKey(..)
share, sqlSettings) , mkDeleteCascade
------------------------------------------------------------------------------- , mkMigrate
, mkPersist
, persistLowerCase
, share
, sqlSettings
)
share [ mkPersist sqlSettings share [ mkPersist sqlSettings
@ -50,8 +56,6 @@ share [ mkPersist sqlSettings
deriving Eq Show deriving Eq Show
|] |]
-------------------------------------------------------------------------------
putPersons :: (MonadIO m, MonadLogger m) putPersons :: (MonadIO m, MonadLogger m)
=> SqlPersistT m () => SqlPersistT m ()
putPersons = do putPersons = do
@ -65,7 +69,6 @@ putPersons = do
liftIO $ mapM_ (putStrLn . ("Name: " ++) . personName . entityVal) people liftIO $ mapM_ (putStrLn . ("Name: " ++) . personName . entityVal) people
-------------------------------------------------------------------------------
getJohns :: (MonadIO m, MonadLogger m) getJohns :: (MonadIO m, MonadLogger m)
=> SqlReadT m [Entity Person] => SqlReadT m [Entity Person]
getJohns = getJohns =
@ -76,7 +79,6 @@ getJohns =
return p return p
-------------------------------------------------------------------------------
getAdults :: (MonadIO m, MonadLogger m) getAdults :: (MonadIO m, MonadLogger m)
=> SqlReadT m [Entity Person] => SqlReadT m [Entity Person]
getAdults = getAdults =
@ -87,7 +89,6 @@ getAdults =
return p return p
-------------------------------------------------------------------------------
getBlogPostsByAuthors :: (MonadIO m, MonadLogger m) getBlogPostsByAuthors :: (MonadIO m, MonadLogger m)
=> SqlReadT m [(Entity BlogPost, Entity Person)] => SqlReadT m [(Entity BlogPost, Entity Person)]
getBlogPostsByAuthors = getBlogPostsByAuthors =
@ -99,7 +100,6 @@ getBlogPostsByAuthors =
return (b, p) return (b, p)
-------------------------------------------------------------------------------
getAuthorMaybePosts :: (MonadIO m, MonadLogger m) getAuthorMaybePosts :: (MonadIO m, MonadLogger m)
=> SqlReadT m [(Entity Person, Maybe (Entity BlogPost))] => SqlReadT m [(Entity Person, Maybe (Entity BlogPost))]
getAuthorMaybePosts = getAuthorMaybePosts =
@ -113,7 +113,6 @@ getAuthorMaybePosts =
return (p, mb) return (p, mb)
-------------------------------------------------------------------------------
followers :: (MonadIO m, MonadLogger m) followers :: (MonadIO m, MonadLogger m)
=> SqlReadT m [(Entity Person, Entity Follow, Entity Person)] => SqlReadT m [(Entity Person, Entity Follow, Entity Person)]
followers = followers =
@ -128,7 +127,6 @@ followers =
return (p1, f, p2) return (p1, f, p2)
-------------------------------------------------------------------------------
updateJoao :: (MonadIO m, MonadLogger m) updateJoao :: (MonadIO m, MonadLogger m)
=> SqlWriteT m () => SqlWriteT m ()
updateJoao = updateJoao =
@ -138,7 +136,6 @@ updateJoao =
where_ (p ^. PersonName ==. val "Joao") where_ (p ^. PersonName ==. val "Joao")
-------------------------------------------------------------------------------
deleteYoungsters :: (MonadIO m, MonadLogger m) deleteYoungsters :: (MonadIO m, MonadLogger m)
=> SqlPersistT m () => SqlPersistT m ()
deleteYoungsters = do deleteYoungsters = do
@ -154,7 +151,6 @@ deleteYoungsters = do
forM_ youngsters (deleteCascade . entityKey) forM_ youngsters (deleteCascade . entityKey)
-------------------------------------------------------------------------------
insertBlogPosts :: (MonadIO m, MonadLogger m) insertBlogPosts :: (MonadIO m, MonadLogger m)
=> SqlWriteT m () => SqlWriteT m ()
insertBlogPosts = insertBlogPosts =
@ -163,10 +159,10 @@ insertBlogPosts =
return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId) return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId)
-------------------------------------------------------------------------------
runDB :: (MonadReader ConnectionString m, runDB :: (MonadReader ConnectionString m,
MonadIO m, MonadIO m,
MonadBaseControl IO m, MonadBaseControl IO m,
MonadUnliftIO m,
MonadLogger m) MonadLogger m)
=> SqlPersistT m a -> m a => SqlPersistT m a -> m a
runDB query = do runDB query = do
@ -175,7 +171,6 @@ runDB query = do
withPostgresqlConn conn $ \backend -> runReaderT query backend withPostgresqlConn conn $ \backend -> runReaderT query backend
-------------------------------------------------------------------------------
setupDb :: (MonadIO m, MonadLogger m) setupDb :: (MonadIO m, MonadLogger m)
=> SqlPersistT m () => SqlPersistT m ()
setupDb = do setupDb = do
@ -197,7 +192,6 @@ setupDb = do
void $ insert $ Follow joao sean void $ insert $ Follow joao sean
-------------------------------------------------------------------------------
cleanDb :: (MonadIO m, MonadLogger m) cleanDb :: (MonadIO m, MonadLogger m)
=> SqlPersistT m () => SqlPersistT m ()
cleanDb = do cleanDb = do
@ -208,7 +202,6 @@ cleanDb = do
where where
dropTable tableName = rawExecute ("DROP TABLE " <> tableName) [] dropTable tableName = rawExecute ("DROP TABLE " <> tableName) []
-------------------------------------------------------------------------------
main :: IO () main :: IO ()
main = do main = do
-- Connection string for the postrgesql database -- Connection string for the postrgesql database

25
examples/package.yaml
View File

@ -2,12 +2,14 @@ name: esqueleto-examples
version: '0.0.0.0' version: '0.0.0.0'
category: Database category: Database
author: Fintan Halpenny author: Fintan Halpenny
maintainer: fintan.halpenny@gmail.com maintainer: cma@bitemyapp.com
copyright: 2017, Chris Allen copyright: 2019, Chris Allen
license: BSD3 license: BSD3
github: FintanH/esqueleto github: bitemyapp/esqueleto
extra-source-files: extra-source-files:
- README.md - README.md
dependencies: dependencies:
- base - base
- esqueleto - esqueleto
@ -18,17 +20,22 @@ dependencies:
- monad-logger - monad-logger
- monad-control - monad-control
- transformers-base - transformers-base
- unliftio-core
ghc-options: ghc-options:
- -Wall - '-Wall'
- -threaded - '-threaded'
- -rtsopts - '-rtsopts'
- -with-rtsopts=-N - '-with-rtsopts=-N'
when: when:
- condition: flag(werror) - condition: flag(werror)
ghc-options: -Werror ghc-options: '-Werror'
executables: executables:
blog-example: blog-example:
other-modules:
- Blog
main: Main.hs main: Main.hs
flags: flags:

3
src/Database/Esqueleto/Internal/Internal.hs
View File

@ -730,8 +730,9 @@ case_ = unsafeSqlCase
-- Bar -- Bar
-- barNum Int -- barNum Int
-- Foo -- Foo
-- Id BarId -- bar BarId
-- fooNum Int -- fooNum Int
-- Primary bar
-- @ -- @
-- --
-- For this example, declare: -- For this example, declare:

41
stack-8.2.yaml
View File

@ -1,26 +1,25 @@
resolver: lts-10.6 resolver: lts-10.6
packages: packages:
- '.' - '.'
# - examples
extra-deps: extra-deps:
- aeson-1.4.1.0 - aeson-1.4.1.0
- aeson-compat-0.3.8 - aeson-compat-0.3.8
- attoparsec-0.13.2.2 - attoparsec-0.13.2.2
- case-insensitive-1.2.0.11 - case-insensitive-1.2.0.11
- conduit-1.3.0 - conduit-1.3.0
- conduit-extra-1.3.0 - conduit-extra-1.3.0
- hashable-1.2.7.0 - hashable-1.2.7.0
- monad-logger-0.3.28.1 - monad-logger-0.3.28.1
- persistent-2.10.0 - persistent-2.10.0
- persistent-mysql-2.10.0 - persistent-mysql-2.10.0
- persistent-postgresql-2.10.0 - persistent-postgresql-2.10.0
- persistent-sqlite-2.10.0 - persistent-sqlite-2.10.0
- persistent-template-2.7.0 - persistent-template-2.7.0
- postgresql-libpq-0.9.4.2 - postgresql-libpq-0.9.4.2
- postgresql-simple-0.6.1 - postgresql-simple-0.6.1
- resourcet-1.2.0 - resourcet-1.2.0
- scientific-0.3.6.2 - scientific-0.3.6.2
- text-1.2.3.0 - text-1.2.3.0
- unliftio-0.2.0.0 - unliftio-0.2.0.0

21
stack-8.4.yaml
View File

@ -1,16 +1,15 @@
resolver: lts-12.2 resolver: lts-12.2
packages: packages:
- '.' - '.'
extra-deps: extra-deps:
- aeson-1.4.1.0 - aeson-1.4.1.0
- persistent-2.10.0 - persistent-2.10.0
- persistent-postgresql-2.10.0 - persistent-postgresql-2.10.0
- persistent-sqlite-2.10.0 - persistent-sqlite-2.10.0
- persistent-mysql-2.10.0 - persistent-mysql-2.10.0
- persistent-template-2.7.0 - persistent-template-2.7.0
- postgresql-libpq-0.9.4.2 - postgresql-libpq-0.9.4.2
- postgresql-simple-0.6.1 - postgresql-simple-0.6.1
- transformers-0.5.5.2 - transformers-0.5.5.2
allow-newer: true

15
stack-8.6.yaml
View File

@ -1,12 +1,13 @@
resolver: lts-13.6 resolver: lts-13.6
packages: packages:
- '.' - '.'
- 'examples'
extra-deps: extra-deps:
- persistent-2.10.0 - persistent-2.10.0
- persistent-template-2.7.0 - persistent-template-2.7.0
- persistent-mysql-2.10.0 - persistent-mysql-2.10.0
- persistent-postgresql-2.10.0 - persistent-postgresql-2.10.0
- postgresql-simple-0.6.1 - persistent-sqlite-2.10.0
- persistent-sqlite-2.10.0 - postgresql-simple-0.6.1