diff --git a/examples/Blog.hs b/examples/Blog.hs new file mode 100644 index 0000000..68ba026 --- /dev/null +++ b/examples/Blog.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + + +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Text (Text) +import Database.Esqueleto +import Database.Persist.Sqlite (runMigration, runSqlite) +import Database.Persist.TH (mkMigrate, mkPersist, + persistLowerCase, share, sqlSettings) + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| + Person + name String + age Int Maybe + deriving Eq Show + BlogPost + title String + authorId PersonId + deriving Eq Show + Follow + follower PersonId + followed PersonId + deriving Eq Show +|] + +putPersons :: (MonadIO m) + => SqlPersistT m () +putPersons = do + people <- select $ + from $ \person -> do + return person + liftIO $ mapM_ (putStrLn . personName . entityVal) people + +getJohns :: (MonadIO m) + => SqlReadT m [Entity Person] +getJohns = + select $ + from $ \p -> do + where_ (p ^. PersonName ==. val "John") + return p + +getJaoas :: (MonadIO m) + => SqlReadT m [Entity Person] +getJaoas = + select $ + from $ \p -> do + where_ (p ^. PersonName ==. val "João" ||. p ^. PersonName ==. val "Joao") + return p + +getAdults :: (MonadIO m) + => SqlReadT m [Entity Person] +getAdults = + select $ + from $ \p -> do + where_ (p ^. PersonAge >=. just (val 18)) + return p + +getBlogPostsByAuthors :: (MonadIO m) + => SqlReadT m [(Entity BlogPost, Entity Person)] +getBlogPostsByAuthors = + select $ + from $ \(b, p) -> do + where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) + orderBy [asc (b ^. BlogPostTitle)] + return (b, p) + +getAuthorMaybePosts :: (MonadIO m) + => SqlReadT m [(Entity Person, Maybe (Entity BlogPost))] +getAuthorMaybePosts = + select $ + from $ \(p `LeftOuterJoin` mb) -> do + on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) + orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)] + return (p, mb) + +followers :: (MonadIO m) + => SqlReadT m [(Entity Person, Entity Follow, Entity Person)] +followers = + select $ + from $ \(p1 `InnerJoin` f `InnerJoin` p2) -> do + on (p2 ^. PersonId ==. f ^. FollowFollowed) + on (p1 ^. PersonId ==. f ^. FollowFollower) + return (p1, f, p2) + +updateJoao :: (MonadIO m) + => SqlWriteT m () +updateJoao = + update $ \p -> do + set p [ PersonName =. val "João" ] + where_ (p ^. PersonName ==. val "Joao") + +deleteYoungsters :: (MonadIO m) + => SqlWriteT m () +deleteYoungsters = + delete $ + from $ \p -> do + where_ (p ^. PersonAge <. just (val 14)) + +insertBlogPosts :: (MonadIO m) + => SqlWriteT m () +insertBlogPosts = + insertSelect $ from $ \p -> + return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId) + +testDb :: (MonadIO m) + => SqlWriteT m () +testDb = do + john <- insert $ Person "John" (Just 24) + sean <- insert $ Person "Seán" (Just 70) + joao <- insert $ Person "Joao" (Just 13) + void $ insertMany [ BlogPost "How to play a bodhrán" sean + , BlogPost "Haskell for the working class hero" john + ] + void $ insert $ Follow john sean + void $ insert $ Follow sean john + void $ insert $ Follow joao sean + +arith :: Num b => (a -> b) -> Integer -> a -> b +arith f i a = (f a) + fromInteger i + +main :: IO () +main = runSqlite ":memory:" $ do + runMigration migrateAll + testDb + + printMessage "Listing all names of the people in the database" + printMessage "===============================================" + putPersons + printMessage "===============================================" + + printMessage "Listing all the people with the name John:" + printMessage "===============================================" + getJohns >>= printVals + printMessage "===============================================" + + printMessage "Listing all people of the age 18 or over" + printMessage "===============================================" + getAdults >>= printVals + printMessage "===============================================" + + printMessage "Listing all Blog Posts and their Authors" + printMessage "===============================================" + getBlogPostsByAuthors >>= printVals2 + printMessage "===============================================" + + printMessage "Listing all Authors and their possible Blog Posts" + printMessage "===============================================" + getAuthorMaybePosts >>= mapM_ print' + printMessage "===============================================" + + printMessage "Listing all mutual Followers" + printMessage "===============================================" + followers >>= mapM_ print' + printMessage "===============================================" + + printMessage "Updating Jaoa and checking the update" + printMessage "===============================================" + updateJoao + getJaoas >>= printVals + printMessage "===============================================" + + printMessage "Deleting poor Jaoa because he is too young" + printMessage "===============================================" + deleteYoungsters + getJaoas >>= printVals + printMessage "===============================================" + where + -- | Helper for print Text and getting rid of pesky warnings to default + -- | literals to [Char] + printMessage :: (MonadIO m) => Text -> m () + printMessage = liftIO . print + + -- | Helper function for printing in our DB environment + print' :: (MonadIO m, Show a) => a -> m () + print' = liftIO . print + + -- | Helper to extract the entity values and print each one + printVals = liftIO . mapM_ (print . entityVal) + + -- | TODO: Scrap this for something better + printVals2 = liftIO . mapM_ (print . both entityVal entityVal) + both f g (a, b) = (f a, g b) diff --git a/examples/LICENSE b/examples/LICENSE new file mode 100644 index 0000000..0cac1c1 --- /dev/null +++ b/examples/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Felipe Lessa + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Felipe Lessa nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/examples/README.md b/examples/README.md new file mode 100644 index 0000000..8a05c6d --- /dev/null +++ b/examples/README.md @@ -0,0 +1,3 @@ +# Esqueleto Examples + +These examples can be build via `stack build`. diff --git a/examples/Setup.hs b/examples/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/examples/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/package.yaml b/examples/package.yaml new file mode 100644 index 0000000..c48f515 --- /dev/null +++ b/examples/package.yaml @@ -0,0 +1,35 @@ +name: esqueleto-examples +version: '0.0.0.0' +category: Database +author: Fintan Halpenny +maintainer: fintan.halpenny@gmail.com +copyright: 2017, Chris Allen +license: BSD3 +github: FintanH/esqueleto +extra-source-files: +- README.md +dependencies: +- base +- esqueleto +- persistent +- persistent-template +- persistent-sqlite +- text +ghc-options: +- -Wall +- -threaded +- -rtsopts +- -with-rtsopts=-N +when: +- condition: flag(werror) + ghc-options: -Werror + +executables: + blog-example: + main: Blog.hs + +flags: + werror: + description: "Treat warnings as errors" + manual: true + default: false