Skip to content

Commit

Permalink
Revamp doctest
Browse files Browse the repository at this point in the history
  • Loading branch information
@tchoutri
tchoutri committed Jan 19, 2024
1 parent e596b4c commit 7a3100f
Show file tree
Hide file tree
Showing 5 changed files with 143 additions and 52 deletions.
5 changes: 4 additions & 1 deletion .github/workflows/ci.yml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -72,7 +72,6 @@ jobs:
touch ~/.pgpass
chmod 0600 ~/.pgpass
echo "${FLORA_DB_HOST}:${FLORA_DB_PORT}:${FLORA_DB_DATABASE}:${FLORA_DB_USER}:${FLORA_DB_PASSWORD}" > .pgpass
cabal freeze
- name: Cache
uses: actions/cache@v3
Expand All @@ -85,8 +84,12 @@ jobs:
run: |
echo "$HOME/.local/bin" >> $GITHUB_PATH
make build
cabal install doctest
cabal install postgresql-migration
- name: Doctests
run: |
make doctest
- name: Test
run: |
source environment.sh
Expand Down
3 changes: 3 additions & 0 deletions Makefile
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,6 +30,9 @@ docs-build: ## Generate the documentation
docs-serve: ## Start a web server to serve the documentation
@cd docs; mdbook serve --open

doctest: ## Run the doctests
@cabal repl --with-ghc=doctest

db-create: ## Create the database
@createdb -h $(DB_HOST) -p $(DB_PORT) -U $(DB_USER) $(DB_DATABASE)

Expand Down
99 changes: 64 additions & 35 deletions src/Database/PostgreSQL/Entity.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -98,18 +98,47 @@ import Database.PostgreSQL.Entity.Internal
import Database.PostgreSQL.Entity.Types

{- $setup
>>> :set -XQuasiQuotes
>>> :set -XOverloadedStrings
>>> :set -XOverloadedLists
>>> :set -XTypeApplications
>>> import Database.PostgreSQL.Entity
>>> import Database.PostgreSQL.Entity.Types
>>> import Database.PostgreSQL.Entity.Internal
>>> import Database.PostgreSQL.Entity.Internal.BlogPost
>>> import Database.PostgreSQL.Entity.Internal.QQ
>>> import Database.PostgreSQL.Simple.Types (Query (..))
>>> import Data.Vector (Vector)
>>> import qualified Data.Vector as V
>>> :set -XQuasiQuotes
>>> :set -XOverloadedStrings
>>> :set -XOverloadedLists
>>> :set -XTypeApplications
>>> import Database.PostgreSQL.Entity
>>> import Database.PostgreSQL.Entity.Types
>>> import Database.PostgreSQL.Entity.Internal
>>> import Database.PostgreSQL.Entity.Internal.QQ
>>> import Database.PostgreSQL.Simple.Types (Query (..))
>>> import Data.Vector (Vector)
>>> import qualified Data.Vector as V
>>> import Data.Time (UTCTime)
>>> import GHC.Generics (Generic)
>>> :{
>>> data Author = Author
>>> { authorId :: Int
>>> , name :: Text
>>> , createdAt :: UTCTime
>>> }
>>> deriving stock (Eq, Generic, Ord, Show)
>>> deriving anyclass (FromRow, ToRow)
>>> deriving
>>> (Entity)
>>> via (GenericEntity '[PrimaryKey "author_id", TableName "authors"] Author)
>>>
>>> data BlogPost = BlogPost
>>> { blogPostId :: Int
>>> -- ^ Primary key
>>> , authorId :: Int
>>> -- ^ Foreign keys, for which we need an explicit type annotation
>>> , intList :: Vector Int
>>> , title :: Text
>>> , content :: Text
>>> , createdAt :: UTCTime
>>> }
>>> deriving stock (Eq, Generic, Ord, Show)
>>> deriving anyclass (FromRow, ToRow)
>>> deriving
>>> (Entity)
>>> via (GenericEntity '[PrimaryKey "blog_post_id", TableName "blogposts"] BlogPost)
>>> :}
-}

{- $highlevel
Expand Down Expand Up @@ -348,7 +377,7 @@ deleteByField fs values = void $ execute Delete (_deleteWhere @e fs) values
__Examples__
>>> _select @BlogPost
"SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\""
"SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\""
@since 0.0.1.0
-}
Expand All @@ -359,8 +388,8 @@ _select = textToQuery $ "SELECT " <> expandQualifiedFields @e <> " FROM " <> get
__Examples__
>>> _selectWithFields @BlogPost [ [field| blogpost_id |], [field| created_at |] ]
"SELECT \"blogposts\".\"blogpost_id\", \"blogposts\".\"created_at\" FROM \"\"blogposts\"\""
>>> _selectWithFields @BlogPost [ [field| blog_post_id |], [field| created_at |] ]
"SELECT \"blogposts\".\"blog_post_id\", \"blogposts\".\"created_at\" FROM \"blogposts\""
@since 0.0.1.0
-}
Expand All @@ -379,11 +408,11 @@ _selectWithFields fs = textToQuery $ "SELECT " <> expandQualifiedFields' fs tn <
__Examples__
>>> _select @BlogPost <> _where [[field| blogpost_id |]]
"SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"blogpost_id\" = ?"
>>> _select @BlogPost <> _where [[field| blog_post_id |]]
"SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"blog_post_id\" = ?"
>>> _select @BlogPost <> _where [ [field| uuid_list |] ]
"SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"uuid_list\" = ?"
>>> _select @BlogPost <> _where [ [field| int_list |] ]
"SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"int_list\" = ?"
@since 0.0.1.0
-}
Expand All @@ -397,10 +426,10 @@ _where fs' = textToQuery $ " WHERE " <> clauseFields
__Examples__
>>> _selectWhere @BlogPost [ [field| author_id |] ]
"SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" = ?"
"SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" = ?"
>>> _selectWhere @BlogPost [ [field| author_id |], [field| title |]]
"SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" = ? AND \"title\" = ?"
"SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" = ? AND \"title\" = ?"
@since 0.0.1.0
-}
Expand All @@ -411,7 +440,7 @@ _selectWhere fs = _select @e <> _where fs
r
>>> _selectWhereNotNull @BlogPost [ [field| author_id |] ]
"SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" IS NOT NULL"
"SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" IS NOT NULL"
@since 0.0.1.0
-}
Expand All @@ -421,7 +450,7 @@ _selectWhereNotNull fs = _select @e <> textToQuery (" WHERE " <> isNotNull fs)
{-| Produce a SELECT statement where the provided fields are checked for being null.
>>> _selectWhereNull @BlogPost [ [field| author_id |] ]
"SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" IS NULL"
"SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" IS NULL"
@since 0.0.1.0
-}
Expand All @@ -431,7 +460,7 @@ _selectWhereNull fs = _select @e <> textToQuery (" WHERE " <> isNull fs)
{-| Produce a SELECT statement where the given field is checked aginst the provided array of values .
>>> _selectWhereIn @BlogPost [field| title |] [ "Unnamed", "Mordred's Song" ]
"SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"title\" IN ('Unnamed', 'Mordred''s Song')"
"SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"title\" IN ('Unnamed', 'Mordred''s Song')"
@since 0.0.2.0
-}
Expand All @@ -443,7 +472,7 @@ _selectWhereIn f values = _select @e <> textToQuery (" WHERE " <> isIn f values)
__Examples__
>>> _joinSelect @BlogPost @Author
"SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\", authors.\"author_id\", authors.\"name\", authors.\"created_at\" FROM \"blogposts\" INNER JOIN \"authors\" USING(author_id)"
"SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\", authors.\"author_id\", authors.\"name\", authors.\"created_at\" FROM \"blogposts\" INNER JOIN \"authors\" USING(author_id)"
@since 0.0.1.0
-}
Expand Down Expand Up @@ -510,7 +539,7 @@ _joinSelectWithFields fs1 fs2 =
__Examples__
>>> _joinSelectOneByField @BlogPost @Author [field| author_id |] [field| name |] :: Query
"SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" INNER JOIN \"authors\" ON \"blogposts\".\"author_id\" = \"authors\".\"author_id\" WHERE authors.\"name\" = ?"
"SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" INNER JOIN \"authors\" ON \"blogposts\".\"author_id\" = \"authors\".\"author_id\" WHERE authors.\"name\" = ?"
@since 0.0.2.0
-}
Expand Down Expand Up @@ -544,7 +573,7 @@ _joinSelectOneByField pivotField whereField =
__Examples__
>>> _insert @BlogPost
"INSERT INTO \"blogposts\" (\"blogpost_id\", \"author_id\", \"uuid_list\", \"title\", \"content\", \"created_at\") VALUES (?, ?, ?, ?, ?, ?)"
"INSERT INTO \"blogposts\" (\"blog_post_id\", \"author_id\", \"int_list\", \"title\", \"content\", \"created_at\") VALUES (?, ?, ?, ?, ?, ?)"
@since 0.0.1.0
-}
Expand All @@ -558,14 +587,14 @@ _insert = textToQuery $ "INSERT INTO " <> getTableName @e <> " " <> fs <> " VALU
__Examples__
>>> _onConflictDoUpdate [[field| blogpost_id |]] [ [field| title |], [field| content |]]
" ON CONFLICT (blogpost_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content"
>>> _onConflictDoUpdate [[field| blog_post_id |]] [ [field| title |], [field| content |]]
" ON CONFLICT (blog_post_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content"
>>> _onConflictDoUpdate [[field| blogpost_id |], [field| author_id |]] [ [field| title |], [field| content |]]
" ON CONFLICT (blogpost_id, author_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content"
>>> _onConflictDoUpdate [[field| blog_post_id |], [field| author_id |]] [ [field| title |], [field| content |]]
" ON CONFLICT (blog_post_id, author_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content"
>>> _insert @BlogPost <> _onConflictDoUpdate [[field| blogpost_id |]] [ [field| title |], [field| content |]]
"INSERT INTO \"blogposts\" (\"blogpost_id\", \"author_id\", \"uuid_list\", \"title\", \"content\", \"created_at\") VALUES (?, ?, ?, ?, ?, ?) ON CONFLICT (blogpost_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content"
>>> _insert @BlogPost <> _onConflictDoUpdate [[field| blog_post_id |]] [ [field| title |], [field| content |]]
"INSERT INTO \"blogposts\" (\"blog_post_id\", \"author_id\", \"int_list\", \"title\", \"content\", \"created_at\") VALUES (?, ?, ?, ?, ?, ?) ON CONFLICT (blog_post_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content"
@since 0.0.2.0
-}
Expand All @@ -586,7 +615,7 @@ _onConflictDoUpdate conflictTarget fieldsToReplace =
"UPDATE \"authors\" SET (\"name\", \"created_at\") = ROW(?, ?) WHERE \"author_id\" = ?"
>>> _update @BlogPost
"UPDATE \"blogposts\" SET (\"author_id\", \"uuid_list\", \"title\", \"content\", \"created_at\") = ROW(?, ?, ?, ?, ?) WHERE \"blogpost_id\" = ?"
"UPDATE \"blogposts\" SET (\"author_id\", \"int_list\", \"title\", \"content\", \"created_at\") = ROW(?, ?, ?, ?, ?) WHERE \"blog_post_id\" = ?"
@since 0.0.1.0
-}
Expand Down Expand Up @@ -655,7 +684,7 @@ _updateFieldsBy fs' f =
__Examples__
>>> _delete @BlogPost
"DELETE FROM \"blogposts\" WHERE \"blogpost_id\" = ?"
"DELETE FROM \"blogposts\" WHERE \"blog_post_id\" = ?"
@since 0.0.1.0
-}
Expand Down
84 changes: 70 additions & 14 deletions src/Database/PostgreSQL/Entity/Internal.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -53,14 +53,63 @@ import Database.PostgreSQL.Entity.Internal.Unsafe (Field (Field))
import Database.PostgreSQL.Entity.Types

{- $setup
>>> :set -XQuasiQuotes
>>> :set -XOverloadedLists
>>> :set -XTypeApplications
>>> import Database.PostgreSQL.Entity
>>> import Database.PostgreSQL.Entity.Types
>>> import Database.PostgreSQL.Entity.Internal.BlogPost
>>> import Database.PostgreSQL.Entity.Internal.QQ
>>> import Database.PostgreSQL.Entity.Internal.Unsafe
>>> :set -XQuasiQuotes
>>> :set -XOverloadedStrings
>>> :set -XOverloadedLists
>>> :set -XTypeApplications
>>> import Database.PostgreSQL.Entity
>>> import Database.PostgreSQL.Simple.FromRow (FromRow(..))
>>> import Database.PostgreSQL.Simple.ToRow
>>> import Database.PostgreSQL.Entity.Types
>>> import Database.PostgreSQL.Entity.Internal
>>> import Database.PostgreSQL.Entity.Internal.QQ
>>> import Database.PostgreSQL.Simple.Types (Query (..))
>>> import Data.Vector (Vector)
>>> import qualified Data.Vector as V
>>> import Data.Time (UTCTime)
>>> import GHC.Generics (Generic)
>>> :{
>>> data Author = Author
>>> { authorId :: Int
>>> , name :: Text
>>> , createdAt :: UTCTime
>>> }
>>> deriving stock (Eq, Generic, Ord, Show)
>>> deriving anyclass (FromRow, ToRow)
>>> deriving
>>> (Entity)
>>> via (GenericEntity '[PrimaryKey "author_id", TableName "authors"] Author)
>>>
>>> data BlogPost = BlogPost
>>> { blogPostId :: Int
>>> -- ^ Primary key
>>> , authorId :: Int
>>> -- ^ Foreign keys, for which we need an explicit type annotation
>>> , intList :: Vector Int
>>> , title :: Text
>>> , content :: Text
>>> , createdAt :: UTCTime
>>> }
>>> deriving stock (Eq, Generic, Ord, Show)
>>> deriving anyclass (FromRow, ToRow)
>>> deriving
>>> (Entity)
>>> via (GenericEntity '[PrimaryKey "blog_post_id", TableName "blogposts"] BlogPost)
>>>
>>> data Tags = Tags
>>> { category :: Text
>>> , labels :: [Text]
>>> }
>>>
>>> instance Entity Tags where
>>> tableName = "tags"
>>> schema = Just "public"
>>> primaryKey = [field| category |]
>>> fields =
>>> [ [field| category |]
>>> , [field| labels |]
>>> ]
>>> :}
-}

{-| Wrap the given text between parentheses
Expand Down Expand Up @@ -147,7 +196,7 @@ getFieldName = quoteName . fieldName
__Examples__
>>> expandFields @BlogPost
"\"blogpost_id\", \"author_id\", \"uuid_list\", \"title\", \"content\", \"created_at\""
"\"blog_post_id\", \"author_id\", \"int_list\", \"title\", \"content\", \"created_at\""
@since 0.0.1.0
-}
Expand All @@ -159,7 +208,7 @@ expandFields = V.foldl1' (\element acc -> element <> ", " <> acc) (getFieldName
__Examples__
>>> expandQualifiedFields @BlogPost
"blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\""
"blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\""
@since 0.0.1.0
-}
Expand All @@ -173,7 +222,7 @@ expandQualifiedFields = expandQualifiedFields' (fields @e) prefixName
__Examples__
>>> expandQualifiedFields' (fields @BlogPost) "legacy"
"legacy.\"blogpost_id\", legacy.\"author_id\", legacy.\"uuid_list\", legacy.\"title\", legacy.\"content\", legacy.\"created_at\""
"legacy.\"blog_post_id\", legacy.\"author_id\", legacy.\"int_list\", legacy.\"title\", legacy.\"content\", legacy.\"created_at\""
@since 0.0.1.0
-}
Expand Down Expand Up @@ -203,7 +252,7 @@ qualifyField f = (\(Field fName _) -> p <> "." <> quoteName fName) f
__Examples__
>>> qualifyFields "legacy" (fields @BlogPost)
[Field "legacy.\"blogpost_id\"" Nothing,Field "legacy.\"author_id\"" Nothing,Field "legacy.\"uuid_list\"" Nothing,Field "legacy.\"title\"" Nothing,Field "legacy.\"content\"" Nothing,Field "legacy.\"created_at\"" Nothing]
[Field "legacy.\"blog_post_id\"" Nothing,Field "legacy.\"author_id\"" Nothing,Field "legacy.\"int_list\"" Nothing,Field "legacy.\"title\"" Nothing,Field "legacy.\"content\"" Nothing,Field "legacy.\"created_at\"" Nothing]
@since 0.0.1.0
-}
Expand All @@ -221,7 +270,7 @@ qualifyFields p fs = fmap (\(Field f t) -> Field (p <> "." <> quoteName f) t) fs
"\"ids\" = ?"
>>> fmap placeholder $ fields @BlogPost
["\"blogpost_id\" = ?","\"author_id\" = ?","\"uuid_list\" = ?","\"title\" = ?","\"content\" = ?","\"created_at\" = ?"]
["\"blog_post_id\" = ?","\"author_id\" = ?","\"int_list\" = ?","\"title\" = ?","\"content\" = ?","\"created_at\" = ?"]
@since 0.0.1.0
-}
Expand Down Expand Up @@ -293,13 +342,20 @@ isNull fs' = fold $ intercalateVector " AND " (fmap process fieldNames)
fieldNames = fmap fieldName fs'
process f = quoteName f <> " IS NULL"

{-| Produce an "IS (<value1>, <value2>, …, <valueN>)" clause
>>> isIn [field| colour |] [ "yellow", "blue", "magenta" ]
"\"colour\" IN ('yellow', 'blue', 'magenta')"
@since 0.0.2.0
-}
isIn :: Field -> Vector Text -> Text
isIn f values = process f <> " IN (" <> fold (intercalateVector ", " vals) <> ")"
where
vals = fmap literal values
process f' = quoteName $ fieldName f'

{-| Since the 'Query' type has an 'IsString' instance, the process of converting from 'Text' to 'String' to 'Query' is
{-| Since the 'Query' type has an 'Data.String.IsString' instance, the process of converting from 'Text' to 'String' to 'Query' is
factored into this function
⚠ This may be dangerous and an unregulated usage of this function may expose to you SQL injection attacks
Expand Down
4 changes: 2 additions & 2 deletions src/Database/PostgreSQL/Entity/Internal/QQ.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -27,8 +27,8 @@ import Text.Parsec (Parsec, anyChar, manyTill, parse, space, spaces, string, try
> instance Entity BlogPost where
> tableName = "blogposts"
> primaryKey = [field| blogpost_id |]
> fields = [ [field| blogpost_id |]
> primaryKey = [field| blog_post_id |]
> fields = [ [field| blog_post_id |]
> , [field| author_id |]
> , [field| uuid_list :: uuid[] |] -- ← This is where we specify an optional PostgreSQL type annotation
> , [field| title |]
Expand Down

0 comments on commit 7a3100f

Please sign in to comment.