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

Merge pull request #145 from bitemyapp/bitemyapp/examples-cleanup

Browse Source 
Cleaning up examples, re-integrating them into the default builds
This commit is contained in:
Chris Allen 2019-09-23 17:06:07 -05:00 committed by GitHub
commit cb13a6426b
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 79 additions and 76 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
) where
-------------------------------------------------------------------------------
import Control.Monad.Base (MonadBase (..))
import Control.Monad.IO.Unlift (MonadUnliftIO(..), wrappedWithRunInIO)
import Control.Monad.Logger (MonadLogger, NoLoggingT (..))
import Control.Monad.Reader
import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
@ -18,30 +18,32 @@ import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
defaultLiftBaseWith,
defaultRestoreM)
import Database.Persist.Postgresql (ConnectionString)
-------------------------------------------------------------------------------
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
lift = BlogT . lift . lift
-------------------------------------------------------------------------------
deriving instance (MonadBase b m) => MonadBase b (BlogT m)
-------------------------------------------------------------------------------
instance MonadBaseControl b m => MonadBaseControl b (BlogT m) where
type StM (BlogT m) a = ComposeSt BlogT m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
-------------------------------------------------------------------------------
instance MonadTransControl BlogT where
type StT BlogT a = StT NoLoggingT (StT (ReaderT ConnectionString) a)
liftWith f = BlogT $ liftWith $ \run ->
@ -50,7 +52,6 @@ instance MonadTransControl BlogT where
restoreT = BlogT . restoreT . restoreT
-------------------------------------------------------------------------------
runBlogT :: ConnectionString -> BlogT m a -> m a
runBlogT backend (BlogT m) =
runReaderT (runNoLoggingT m) backend

31
examples/Main.hs
View File

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

25
examples/package.yaml
View File

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

42
stack-8.2.yaml
View File

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

22
stack-8.4.yaml
View File

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

15
stack-8.6.yaml
View File

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