persistent-relational-record 0.1.2.0 → 0.3.0

raw patch · 27 files changed

+603/−646 lines, 27 filesdep +arraydep +names-thdep +transformersdep −transformers-basedep ~basedep ~conduitdep ~persistable-recordPVP ok

version bump matches the API change (PVP)

Dependencies added: array, names-th, transformers

Dependencies removed: transformers-base

Dependency ranges changed: base, conduit, persistable-record, persistent, relational-query, template-haskell

API changes (from Hackage documentation)

Files

• .travis.yml +105/−39
• .travis/check-sdist.sh +0/−25
• .travis/stack-lts-2.yaml +0/−12
• .travis/stack-lts-6.yaml +0/−6
• .travis/stack-lts-9-hrrhead.yaml +0/−21
• .travis/stack-lts-9.yaml +0/−8
• ChangeLog.md +10/−0
• README.md +97/−79
• examples/Image.hs +0/−16
• examples/ImageTag.hs +0/−13
• examples/Model.hs +31/−22
• examples/Query.hs +59/−0
• examples/Tag.hs +0/−14
• examples/Types.hs +13/−16
• examples/main.hs +42/−102
• persistent-relational-record.cabal +15/−18
• src/Database/Persist/Relational.hs +12/−22
• src/Database/Persist/Relational/Config.hs +29/−0
• src/Database/Persist/Relational/TH.hs +157/−118
• src/Database/Persist/Relational/ToPersistEntity.hs +0/−18
• stack.yaml +1/−1
• tests/Fixtures/BlogSample/Model.hs +11/−7
• tests/Fixtures/BlogSample/Post.hs +0/−16
• tests/Fixtures/BlogSample/PostTag.hs +0/−14
• tests/Fixtures/BlogSample/Tag.hs +0/−15
• tests/Fixtures/BlogSample/User.hs +0/−15
• tests/unit.hs +21/−29

@@ -1,54 +1,120 @@-sudo: false+# This Travis job script has been generated by a script via+#+#   runghc make_travis_yml_2.hs 'persistent-relational-record.cabal'+#+# For more information, see https://github.com/haskell-CI/haskell-ci+# language: c+sudo: false +git:+  submodules: false  # whether to recursively clone submodules++cache:+  directories:+    - $HOME/.cabal/packages+    - $HOME/.cabal/store++before_cache:+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log+  # remove files that are regenerated by 'cabal update'+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx++  - rm -rfv $HOME/.cabal/packages/head.hackage+ matrix:   include:-    - env: GHCVER=7.8.4 STACK_LTS=lts-2 STACK_TEMPLATE=stack-lts-2.yaml-      addons:-        apt:-          sources: [ hvr-ghc ]-          packages: [ ghc-7.8.4 ]-    - env: GHCVER=7.10.3 STACK_LTS=lts-6 STACK_TEMPLATE=stack-lts-6.yaml-      addons:-        apt:-          sources: [ hvr-ghc ]-          packages: [ ghc-7.10.3 ]-    - env: GHCVER=8.0.2 STACK_LTS=lts-9 STACK_TEMPLATE=stack-lts-9.yaml-      addons:-        apt:-          sources: [ hvr-ghc ]-          packages: [ ghc-8.0.2 ]-    - env: GHCVER=8.0.2 STACK_LTS=lts-9 STACK_TEMPLATE=stack-lts-9-hrrhead.yaml-      addons:-        apt:-          sources: [ hvr-ghc ]-          packages: [ ghc-8.0.2 ]-  allow_failures:-    - env: GHCVER=8.0.2 STACK_LTS=lts-9 STACK_TEMPLATE=stack-lts-9-hrrhead.yaml+    - compiler: "ghc-8.6.3"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.3], sources: [hvr-ghc]}}+    - compiler: "ghc-8.4.4"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}}+    - compiler: "ghc-8.2.2"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2], sources: [hvr-ghc]}}+    - compiler: "ghc-8.0.2"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2], sources: [hvr-ghc]}}  before_install:-  # Download and unpack the stack executable-  - mkdir -p ~/.local/bin-  - export PATH=$HOME/.local/bin:/opt:/opt/ghc/$GHCVER/bin:$PATH-  - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'-  - m4 -D__RESOLVER__=$(curl -sL https://www.stackage.org/download/snapshots.json | jq '."'$STACK_LTS'"' -r) .travis/$STACK_TEMPLATE > stack.yaml+  - HC=${CC}+  - HCPKG=${HC/ghc/ghc-pkg}+  - unset CC+  - ROOTDIR=$(pwd)+  - mkdir -p $HOME/.local/bin+  - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"+  - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))+  - echo $HCNUMVER  install:-  - travis_wait stack --no-terminal --skip-ghc-check setup-  - travis_wait stack --no-terminal --skip-ghc-check test --only-snapshot+  - cabal --version+  - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"+  - BENCH=${BENCH---enable-benchmarks}+  - TEST=${TEST---enable-tests}+  - HADDOCK=${HADDOCK-true}+  - UNCONSTRAINED=${UNCONSTRAINED-true}+  - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}+  - GHCHEAD=${GHCHEAD-false}+  - travis_retry cabal update -v+  - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"+  - rm -fv cabal.project cabal.project.local+  - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'+  - "printf 'packages: \".\"\\n' > cabal.project"+  - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"+  - touch cabal.project.local+  - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg  | grep -vw -- persistent-relational-record | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"+  - cat cabal.project || true+  - cat cabal.project.local || true+  - if [ -f "./configure.ac" ]; then+      (cd "." && autoreconf -i);+    fi+  - rm -f cabal.project.freeze+  - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all+  - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all+  - rm -rf .ghc.environment.* "."/dist+  - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) +# Here starts the actual work to be performed for the package under test;+# any command which exits with a non-zero exit code causes the build to fail.+script:+  # test that source-distributions can be generated+  - cabal new-sdist all+  - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/+  - cd ${DISTDIR} || false+  - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;+  - "printf 'packages: persistent-relational-record-*/*.cabal\\n' > cabal.project"+  - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"+  - touch cabal.project.local+  - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg  | grep -vw -- persistent-relational-record | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"+  - cat cabal.project || true+  - cat cabal.project.local || true+  # this builds all libraries and executables (without tests/benchmarks)+  - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all++  # build & run tests, build benchmarks+  - cabal new-build -w ${HC} ${TEST} ${BENCH} all+  - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi++  # cabal check+  - (cd persistent-relational-record-* && cabal check)++  # haddock+  - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi++  # Build without installed constraints for packages in global-db+  - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi++# REGENDATA ["persistent-relational-record.cabal"]+# EOF+ before_script:   - mysql -u root -e 'CREATE DATABASE test DEFAULT CHARACTER SET utf8;'   - mysql -u root -e 'GRANT ALL PRIVILEGES ON `test`.* TO travis@localhost;'--script:-  - travis_wait stack --no-terminal --skip-ghc-check test --flag persistent-relational-record:test-examples--  # tests source distribution package-  - .travis/check-sdist.sh persistent-relational-record-cache:-  directories:-    - ~/.stack  notifications:   slack:

@@ -1,25 +0,0 @@-#!/bin/bash--BASEDIR="$PWD"-TARGET="$1"-DIST="$(stack path | awk '/^dist-dir/ {print $2}')"--stack sdist--if [ ! -f ${DIST%/}/${TARGET}-*.tar.gz ]; then-    echo "NG: missing archive"-    exit 1-fi--cd "$DIST"-srctgz=(${TARGET}*.tar.gz)-srctgz="${srctgz[0]}"-pkgname="${srctgz%.tar.gz}"-tar xvzf "${srctgz}"-cd "$BASEDIR"-NG=$(git ls-tree -r HEAD | while read perm blob hash name; do [ -e "$DIST/$pkgname/$name" ] || echo "$name"; done)-if [ -n "$NG" ]; then-    echo "Missing files:"-    echo $NG-    exit 1-fi

@@ -1,12 +0,0 @@-resolver: __RESOLVER__-packages:-- '.'-extra-deps:-- names-th-0.2.0.2-- persistable-record-0.5.0.1-- relational-query-0.9.1.0-- sql-words-0.1.4.1-- th-data-compat-0.0.2.2-- th-reify-compat-0.0.1.1-flags: {}-extra-package-dbs: []

@@ -1,6 +0,0 @@-resolver: __RESOLVER__-packages:-- '.'-extra-deps: []-flags: {}-extra-package-dbs: []

@@ -1,21 +0,0 @@-resolver: __RESOLVER__-packages:-- '.'-- location:-    git: https://github.com/khibino/haskell-relational-record.git-    commit: master-  subdirs:-    - names-th-    - persistable-record-    - relational-query-    - sql-words-  extra-dep: true-- location:-    git: https://github.com/khibino/haskell-product-isomorphic.git-    commit: master-  extra-dep: true-extra-deps: []-flags:-  persistent-relational-record:-    test-examples: True-extra-package-dbs: []

@@ -1,8 +0,0 @@-resolver: __RESOLVER__-packages:-- '.'-extra-deps: []-flags:-  persistent-relational-record:-    test-examples: True-extra-package-dbs: []

@@ -1,3 +1,13 @@+## 0.3.0++- Switched to Generics & OverloadedLabels based implementation.+- Remove defineTableFromPersistent. The table data types and Pi Projection variables generated by HRR are no longer supported.+- Drop support: GHC < 8, relational-query < 0.12, persistent < 2.5++## 0.2.0++- Support relational-query >= 0.12.0.0 and conduit-1.3.0+ ## 0.1.2.0  - Support relational-query >= 0.10.0

@@ -17,130 +17,148 @@  Model.hs: -~~~~ {.haskell}+```Haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE FlexibleInstances #-} +module Model where+ import Data.Text (Text)-import Database.Persist.Relational (mkHrrInstances)+import Database.Persist.Relational import Database.Persist.TH--share [mkPersist sqlSettings, mkMigrate "migrateAll", mkSave "db", mkHrrInstances] [persistLowerCase|-Image-    title      Text-    deriving Eq Show-Tag-    name       Text-    deriving Eq Show-ImageTag-    imageId    ImageId-    tagId      TagId-|]-~~~~+import GHC.Generics -The main difference from the persistent version is that `mkSave "db"` and `mkHrrInstances` are added to the 1st argument of the `share` function.-`mkSave "db"` saves the definition of tables to "db" variable for later use.-`mkHrrInstances` generates various instances from the entities definition to cooperate with HRR.+share [mkPersist sqlSettings, mkMigrate "migrateAll", mkHrr, deriveGenericForEntityId] [persistLowerCase|+User+    email       Text+    name        Text -Next, you should define HRR record types and their instances,-this package provides "defineTableFromPersistent" function to generate those types and auxiliary functnions.-To avoid the conflict of record field names, we recommend making one module per table.+    UniqueUserEmail email+    deriving Show Eq Generic -Here is the content of "Image.hs":+UserGroup+    name        Text+    pageUrl     Text Maybe -~~~~ {.haskell}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+    UniqueUserGroupName  name+    deriving Show Eq Generic -module Image where+Membership+    userId      UserId+    userGroupId UserGroupId -import Data.Text (Text)-import Database.Persist.Relational-import Model hiding (Image) -- Both of HRR and persistent generates `Image` type, so you should hide Image type generated by persistent.-import qualified Model+    UniqueImageTag userId userGroupId+    deriving Show Eq Generic+|]+``` -defineTableFromPersistent ''Model.Image db-~~~~+The main difference from the persistent version is that `mkHrr` are added to the 1st argument of the `share` function.+`mkHrr` generates various instances and helper functions from the entities definition to cooperate with HRR. -You should create "Tag.hs" and "ImageTag.hs" in the same manner.+NOTE: `deriveGenericForEntityId` is also appended to the list in above example.+Currently, persistent does not generate `Generic` instances for EntityID types (`UserId`, `UserGroupId`, and `MembershipId` in above example).+Haskell Relational Record rely on the Generic instance of record types, so persistent-relational-record provides `deriveGenericForEntityId` for convenience to derive `Generic` instance via `StandaloneDeriving`  Now, you can build queries in manner of HRR: -~~~~ {.haskell}+```Haskell+{-# LANGUAGE OverloadedLabels #-}+ module Query where  import Data.Text (Text)-import Database.Relational.Query+import Database.Persist (Entity)+import Database.Relational  import Model-import qualified Image-import qualified ImageTag-import qualified Tag -imageIdFromTagNameList-    :: [Text] -- ^ list of tag name-    -> Relation () ImageId-imageIdFromTagNameList tagNames = aggregateRelation $ do-   imgtag <- query $ ImageTag.imageTag-   tag <- query $ Tag.tag-   on $ tag ! Tag.id' .=. imgtag ! ImageTag.tagId'-   wheres $ tag ! Tag.name' `in'` values tagNames-   g <- groupBy $ imgtag ! ImageTag.imageId'-   let c = count $ imgtag ! ImageTag.imageId'-   having $ c .=. value (length $ tagNames)-   return g+-- ^ query users by UserGroup name list+--+-- @+-- SELECT+--   user.*+-- FROM user+-- INNER JOIN (+--   -- built by userIdFromUserGroupNameList+--   SELECT+--     user_id+--   FROM membership+--   INNER JOIN userGroup ON userGroup.id = membership.userGroup_id+--   WHERE userGroup.name IN (<<userGroupNames>>)+--   GROUP BY membership.user_id+--   HAVING COUNT(membership.user_id) = <<length userGroupNames>>+-- ) uid+-- ON user.id = uid.user_id+-- @+selectUserByUserGroupNameList+    -> [Text] -- ^ list of UserGroup name+    -> Relation () (Entity User)+selectUserByUserGroupNameList userGroupNames =+    relation $ do+        user <- query userTable+        userId <- query $ userIdFromUserGroupNameList userGroupNames+        on $ #id user .=. userId+        return user -selectImageByTagNameList-    :: [Text] -- ^ list of tag name-    -> Relation () Image.Image-selectImageByTagNameList tagNames = relation $ do-    img <- query Image.image-    imgids <- query $ imageIdFromTagNameList tagNames-    on $ img ! Image.id' .=. imgids-    return img-~~~~+-- ^ query user_id by UserGroup name list+--+-- @+-- SELECT+--   user_id+-- FROM membership+-- INNER JOIN userGroup ON userGroup.id = membership.userGroup_id+-- WHERE userGroup.name IN (<<userGroupNames>>)+-- GROUP BY membership.user_id+-- HAVING COUNT(membership.user_id) = <<length userGroupNames>>+-- @+userIdFromUserGroupNameList+    :: [Text] -- ^ list of userGroup name+    -> Relation () UserId+userIdFromUserGroupNameList userGroupNames =+    aggregateRelation $ do+        membership <- query membershipTable+        userGroup <- query userGroupTable+        on $ #id userGroup .=. #userGroupId membership+        wheres $ #name userGroup `in'` values userGroupNames+        g <- groupBy $ #userId membership+        let c = count $ (#userGroupId membership)+        having $ c .=. value (fromIntegral . length $ userGroupNames)+        return g+```  Finally, we can execute a query by runQuery: -~~~~ {.haskell}+```Haskell {-# LANGUAGE OverloadedStrings #-} -import Control.Monad.Base+import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Trans.Resource import Data.Conduit import qualified Data.Conduit.List as CL import Database.Persist.MySQL import Database.Persist.Relational-import Database.Relational.Query+import Database.Relational  import Model import Query -sample1 :: SqlPersistT (LoggingT IO) [ImageId]-sample1 = runResourceT $ runQuery (relationalQuery $ imageIdFromTagNameList ["tokyo", "haskell"]) () $$ CL.consume--sample2 :: SqlPersistT (LoggingT IO) [Entity Image]-sample2 = runResourceT $ runQuery (relationalQuery $ selectImageByTagNameList ["tokyo", "haskell"]) () $$ CL.consume+sample :: SqlPersistT (LoggingT IO) [Entity User]+sample = runResourceT . runConduit $ runQuery (relationalQuery $ selectUserByUserGroupNameList True ["tokyo", "haskell"]) () .| CL.consume  main :: IO () main = runStderrLoggingT $ withMySQLPool defaultConnectInfo 10 $ runSqlPool $ do-    mapM_ (liftBase . print) =<< sample1-    mapM_ (liftBase . print) =<< sample2-~~~~+    mapM_ (liftIO . print) =<< sample+```  `runQuery` run the HRR `Query` and gives the result as conduit `Source`.-In addition, it converts the result type to persistent's entity if the result type of `Query` is HRR record type.--For example, the expression `selectImageByTagNameList [...]` has type `Relation () Image.Image`,-but `runQuery (relationalQuery $ selectImageByTagNameList ["tokyo", "haskell"]) ()` has type `Source m (Entity Image)`.  For a full runnable example, see [examples](https://github.com/himura/persistent-relational-record/tree/master/examples/) directory.

@@ -1,16 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Image where--import Data.ByteString (ByteString)-import Data.Time (UTCTime)-import Database.Persist.Relational-import Model hiding (Image)-import qualified Model-import Types--defineTableFromPersistent ''Model.Image db

@@ -1,13 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module ImageTag where--import Database.Persist.Relational-import Model hiding (ImageTag)-import qualified Model--defineTableFromPersistent ''Model.ImageTag db

@@ -1,36 +1,45 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE FlexibleInstances #-}  module Model where -import Data.ByteString (ByteString) import Data.Text (Text) import Data.Time (UTCTime)-import Database.Persist.Relational (mkHrrInstances)+import Database.Persist.Relational import Database.Persist.TH+import GHC.Generics import Types -share [mkPersist sqlSettings, mkMigrate "migrateAll", mkSave "db", mkHrrInstances] [persistLowerCase|-Image-    hash       ByteString-    type       ImageType-    created_at UTCTime-    changed_at UTCTime-    UniqueImageHash hash-    deriving Show Eq-Tag-    name       Text-    description Text Maybe-    UniqueTagName name-    deriving Show Eq-ImageTag-    imageId    ImageId-    tagId      TagId-    UniqueImageTag imageId tagId-    deriving Show Eq+share [mkPersist sqlSettings, mkMigrate "migrateAll", mkHrr, deriveGenericForEntityId] [persistLowerCase|+User+    email       Text+    name        Text+    status      UserStatus+    created_at  UTCTime+    updated_at  UTCTime++    UniqueUserEmail email+    deriving Show Eq Generic++UserGroup+    name        Text+    pageUrl     Text Maybe++    UniqueUserGroupName  name+    deriving Show Eq Generic++Membership+    userId      UserId+    userGroupId UserGroupId++    UniqueImageTag userId userGroupId+    deriving Show Eq Generic |]

@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedLabels #-}++module Query where++import Data.Text (Text)+import Database.Persist (Entity)+import Database.Relational++import Model++selectUserByUserGroupNameList+    :: Bool -- ^ match any+    -> [Text] -- ^ list of userGroup name+    -> Relation () (Entity User)+selectUserByUserGroupNameList matchAny userGroupNames =+    relation $ do+        user <- query userTable+        userId <- query $ userIdFromUserGroupNameList matchAny userGroupNames+        on $ #id user .=. userId+        return user++-- ^ query user_id by userGroup name list+--+-- @+-- SELECT+--   user_id+-- FROM membership+-- INNER JOIN user_group ON user_group.id = membership.user_group_id+-- WHERE user_group.name IN (<<UserGroupNames>>)+-- GROUP BY membership.user_id+-- HAVING COUNT(membership.user_group_id) = <<length UserGroupNames>>+-- @+userIdFromUserGroupNameList+    :: Bool -- ^ match any+    -> [Text] -- ^ list of UserGroup name+    -> Relation () UserId+userIdFromUserGroupNameList matchAny userGroupNames =+    aggregateRelation $ do+        membership <- query membershipTable+        userGroup <- query userGroupTable+        on $ #id userGroup .=. #userGroupId membership+        wheres $ #name userGroup `in'` values userGroupNames+        g <- groupBy $ #userId membership+        let c = count $ (#userGroupId membership)+        having $+            if matchAny+                then c .>. value (0 :: Int)+                else c .=. value (fromIntegral . length $ userGroupNames)+        return g++userGroupListOfUser :: Relation UserId (Entity UserGroup)+userGroupListOfUser =+    relation' $+    placeholder $ \ph -> do+        userGroup <- query userGroupTable+        membership <- query membershipTable+        on $ #id userGroup .=. #userGroupId membership+        wheres $ #userId membership .=. ph+        return userGroup

@@ -1,14 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Tag where--import Data.Text (Text)-import Database.Persist.Relational-import qualified Model-import Model hiding (Tag)--defineTableFromPersistent ''Model.Tag db

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} @@ -9,30 +8,28 @@ import Database.Persist.Relational import Database.Persist.Sql import Database.Record.TH (deriveNotNullType, deriveNotNullType)-#if MIN_VERSION_relational_query(0, 10, 0) import Database.Relational import Database.Relational.TH (defineScalarDegree, defineScalarDegree)-#else-import Database.Relational.Query-import Database.Relational.Query.TH (defineScalarDegree, defineScalarDegree)-#endif -data ImageType = JPEG | PNG | BMP | GIF-               deriving (Show, Eq, Enum)+data UserStatus+    = UserActive+    | UserSuspended+    | UserWithdrawn+    deriving (Show, Eq, Enum)  -- * instances for HRR -deriveNotNullType [t|ImageType|]-defineFromToSqlPersistValue [t|ImageType|]-defineScalarDegree [t|ImageType|]-instance ShowConstantTermsSQL ImageType where-    showConstantTermsSQL' = showConstantTermsSQL' . fromEnum+deriveNotNullType [t|UserStatus|]+defineFromToSqlPersistValue [t|UserStatus|]+defineScalarDegree [t|UserStatus|]+instance LiteralSQL UserStatus where+    showLiteral' = showLiteral' . fromEnum  -- * instances for persistent -instance PersistFieldSql ImageType where+instance PersistFieldSql UserStatus where     sqlType _ = SqlInt32-instance PersistField ImageType where+instance PersistField UserStatus where     toPersistValue = PersistInt64 . fromIntegral . fromEnum     fromPersistValue (PersistInt64 v) = Right . toEnum . fromIntegral $ v-    fromPersistValue v = Left . T.pack $ "ImageType: Unkown Type, recieved: " ++ show v+    fromPersistValue v = Left . T.pack $ "UserStatus: Unkown Type, recieved: " ++ show v

@@ -1,128 +1,65 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} -import Control.Monad.Base+import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Trans.Resource-import Data.ByteString (ByteString) import Data.Conduit import qualified Data.Conduit.List as CL import Data.Maybe-import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T import Data.Time-import Database.Persist-import Database.Persist.MySQL+import Database.Persist.MySQL (ConnectInfo (..), defaultConnectInfo, withMySQLPool) import Database.Persist.Relational-#if MIN_VERSION_relational_query(0, 10, 0)-import Database.Relational as HRR hiding (fromMaybe, ($$))-#else-import Database.Relational.Query as HRR hiding (fromMaybe)-#endif+import Database.Persist.Sql+import Database.Relational (relationalQuery) import System.Environment -import qualified Image-import qualified ImageTag import Model-import qualified Tag+import Query import Types -selectImageByTagNameList-    :: Bool -- ^ match any-    -> [Text] -- ^ list of tag name-    -> Relation () Image.Image-selectImageByTagNameList matchAny tagNames = relation $ do-    img <- query Image.image-    imgids <- query $ imageIdFromTagNameList matchAny tagNames-    on $ img ! Image.id' .=. imgids-    return img---- ^ query ImageId by tag name list------ @--- SELECT image_id FROM image_tag--- INNER JOIN tag ON tag.id = image_tag.tag_id--- WHERE tag.name IN (<<tagNames>>)--- GROUP BY image_tag.image_id--- HAVING COUNT(image_tag.image_id) = <<length tagNames>>--- @-imageIdFromTagNameList-    :: Bool -- ^ match any-    -> [Text] -- ^ list of tag name-    -> Relation () ImageId-imageIdFromTagNameList matchAny tagNames = aggregateRelation $ do-    imgtag <- query $ ImageTag.imageTag-    tag <- query $ Tag.tag-    on $ tag ! Tag.id' .=. imgtag ! ImageTag.tagId'-    wheres $ tag ! Tag.name' `in'` values tagNames-    g <- groupBy $ imgtag ! ImageTag.imageId'-    let c = HRR.count $ imgtag ! ImageTag.imageId'-    having $-        if matchAny-            then c .>. value (0 :: Int)-            else c .=. value (fromIntegral . length $ tagNames)-    return g--tagListOfImage :: Relation ImageId Tag.Tag-tagListOfImage = relation' $ placeholder $ \ph -> do-    tag <- query Tag.tag-    imgtag <- query ImageTag.imageTag-    on $ tag ! Tag.id' .=. imgtag ! ImageTag.tagId'-    wheres $ imgtag ! ImageTag.imageId' .=. ph-    return tag--addImages :: TagId-          -> [Image]-          -> SqlPersistT (LoggingT IO) ()-addImages tagId images = do-    imgIds <- mapM insert images-    mapM_ (\imgId -> insert $ ImageTag imgId tagId) imgIds--printImage :: ByteString -> SqlPersistT (LoggingT IO) ()-printImage hkey =-    getBy (UniqueImageHash hkey) >>= \case-        Just (Entity k val) -> do-            liftBase $ print val-            runResourceT $-                runQuery (relationalQuery tagListOfImage) k-                $$ CL.mapM_ (liftBase . print)-        Nothing -> liftBase $ putStrLn "Image not found"+addUser :: (MonadUnliftIO m, MonadLogger m) => User -> [UserGroupId] -> SqlPersistT m UserId+addUser user userGroupIds = do+    userId <- insert user+    insertMany_ $ map (Membership userId) userGroupIds+    return userId -sample :: SqlPersistT (LoggingT IO) ()+sample :: (MonadUnliftIO m, MonadLogger m) => SqlPersistT m () sample = do     runMigration migrateAll-    now <- liftBase getCurrentTime+    now <- liftIO getCurrentTime -    tagShinkuId <- insert $ Tag "shinku" (Just "二階堂真紅")-    addImages tagShinkuId-        [ Image "4f4221435f9c5c430db2b093c91b8f1f" PNG now now-        , Image "11eb1ee2b8f9b471f15d85fb784a8fd6" PNG now now-        , Image "7e11b84e04f181179cde72a5d0a5731f" PNG now now-        , Image "e10f6af40a80a7f5794ea0bdc66d4ae3" PNG now now-        ]+    userGroupPersistentId <- insert $ UserGroup "persistent" Nothing+    userGroupHrrId <- insert $ UserGroup "haskell-relational-record" Nothing+    userGroupHaskellJpId <- insert $ UserGroup "haskell-jp" (Just "https://haskell.jp/") -    tagMareId <- insert $ Tag "mare" Nothing-    addImages tagMareId-        [ Image "fbc717314b90afe6819d4593c583109a" PNG now now-        , Image "dc593d1c551f2a1ea85c2dc5521c7fdf" PNG now now-        ]+    _ <- addUser (User "michael@example.com" "Michael" UserActive now now) [userGroupPersistentId]+    _ <- addUser (User "khibino@example.com" "Kei" UserActive now now) [userGroupHrrId, userGroupHaskellJpId]+    _ <- addUser (User "thimura@example.com" "Takahiro" UserSuspended now now) [userGroupPersistentId, userGroupHrrId, userGroupHaskellJpId] -    runResourceT $-        runQuery (relationalQuery $ selectImageByTagNameList False ["shinku"]) ()-        $$ CL.mapM_ (liftBase . print)+    liftIO $ putStrLn "## haskell-jp users:"+    runResourceT . runConduit $+        runQuery (relationalQuery $ selectUserByUserGroupNameList False ["haskell-jp"]) ()+        .| CL.mapM_ (liftIO . printUser) -    runResourceT $-        runQuery (relationalQuery $ imageIdFromTagNameList True ["shinku", "mare"]) ()-        $$ CL.mapM_ (liftBase . print)+    liftIO $ putStrLn "## persistent users:"+    runResourceT . runConduit $+        runQuery (relationalQuery $ selectUserByUserGroupNameList False ["persistent"]) ()+        .| CL.mapM_ (liftIO . printUser) -    printImage "11eb1ee2b8f9b471f15d85fb784a8fd6"-    printImage "fbc717314b90afe6819d4593c583109a"+    liftIO $ putStrLn "## both persistent and haskell-relational-record users:" -    mapM_ (liftBase . print) =<< run+    runResourceT . runConduit $+        runQuery (relationalQuery $ selectUserByUserGroupNameList False ["persistent", "haskell-relational-record"]) ()+        .| CL.mapM_ (liftIO . printUser) -run :: SqlPersistT (LoggingT IO) [Entity Image]-run = runResourceT $-    runQuery (relationalQuery $ selectImageByTagNameList False ["shinku", "mare"]) () $$ CL.consume+printUser :: Entity User -> IO ()+printUser (Entity k (User {..})) =+    T.putStrLn $ T.concat [ T.pack (show userId), ": ", userName, " <", userEmail, ">" ]+  where+    userId = fromSqlKey k  getConnectInfo :: IO ConnectInfo getConnectInfo = do@@ -139,4 +76,7 @@ main :: IO () main = do     connInfo <- getConnectInfo-    runStderrLoggingT $ withMySQLPool connInfo 10 $ runSqlPool sample+    runLoggingT $ withMySQLPool connInfo 10 $ runSqlPool sample+  where+    -- runLoggingT = runNoLoggingT+    runLoggingT = runStderrLoggingT

@@ -1,6 +1,7 @@ name:                persistent-relational-record-version:             0.1.2.0+version:             0.3.0 synopsis:            relational-record on persisten backends.+description:         Please see the README on Github at <https://github.com/himura/persistent-relational-record#readme> homepage:            http://github.com/himura/persistent-relational-record license:             BSD3 license-file:        LICENSE@@ -11,11 +12,11 @@ build-type:          Simple cabal-version:       >=1.10 +tested-with:         GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3+ extra-source-files:   .gitignore   .travis.yml-  .travis/*.sh-  .travis/*.yaml   ChangeLog.md   README.md   stack.yaml@@ -26,21 +27,23 @@  library   hs-source-dirs:      src-  build-depends:       base >= 4.7 && < 5-                     , conduit >= 1.0+  build-depends:       base >= 4.9 && < 5+                     , array+                     , conduit >= 1.3.0                      , containers                      , mtl-                     , persistable-record >= 0.4-                     , persistent >= 2.1-                     , relational-query >= 0.8.1+                     , names-th+                     , persistable-record >= 0.6+                     , persistent >= 2.5+                     , relational-query >= 0.12.0.0                      , resourcet >= 1.1-                     , template-haskell >= 2.9+                     , template-haskell >= 2.11                      , text >= 0.8   default-language:    Haskell2010   exposed-modules:     Database.Persist.Relational+                       Database.Persist.Relational.Config                        Database.Persist.Relational.Instances                        Database.Persist.Relational.TH-                       Database.Persist.Relational.ToPersistEntity   ghc-options:         -Wall  test-suite unittest@@ -60,10 +63,6 @@   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N -O2 -fsimpl-tick-factor=200   default-language:    Haskell2010   other-modules:       Fixtures.BlogSample.Model-                       Fixtures.BlogSample.User-                       Fixtures.BlogSample.Post-                       Fixtures.BlogSample.Tag-                       Fixtures.BlogSample.PostTag  test-suite hlint   type:                exitcode-stdio-1.0@@ -95,15 +94,13 @@                      , template-haskell                      , text                      , time-                     , transformers-base+                     , transformers                      , persistent-relational-record   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N -O2 -fsimpl-tick-factor=120   default-language:    Haskell2010   other-modules:       Model-                       Image-                       ImageTag-                       Tag                        Types+                       Query  source-repository head   type:     git

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -18,59 +17,50 @@ module Database.Persist.Relational        ( runQuery        , rawQuery-       , mkHrrInstances-       , defineTableFromPersistent-       , defineTableFromPersistentWithConfig+       , mkHrr+       , mkHrrWithConfig+       , deriveGenericForEntityId        , defineFromToSqlPersistValue-       , defaultConfig-       , ToPersistEntity (..)+       , module Database.Persist.Relational.Config        ) where  import Control.Monad.Reader (MonadReader) import Control.Monad.Trans.Resource (MonadResource)-import Data.Conduit (Source, ($=))+import Data.Conduit (ConduitT, (.|)) import qualified Data.Conduit.List as CL import qualified Data.Text as T import Database.Persist+import Database.Persist.Relational.Config import Database.Persist.Relational.Instances () import Database.Persist.Relational.TH-import Database.Persist.Relational.ToPersistEntity import Database.Persist.Sql (SqlBackend) import qualified Database.Persist.Sql as PersistSql+import Database.Record.FromSql (FromSql (..), runToRecord) import Database.Record.ToSql (ToSql, recordToSql, runFromRecord)-import Database.Record.FromSql (runToRecord)-import Database.Relational.Query+import Database.Relational  -- | Execute a HRR 'Query' and return the stream of its results. runQuery :: ( MonadResource m             , MonadReader env m-#if MIN_VERSION_persistent(2, 5, 0)             , HasPersistBackend env             , BaseBackend env ~ SqlBackend-#else-            , HasPersistBackend env SqlBackend-#endif+            , FromSql PersistValue a             , ToSql PersistValue p-            , ToPersistEntity a b             )          => Query p a -- ^ Query to get record type a requires parameter p          -> p         -- ^ Parameter type-         -> Source m b-runQuery q vals = rawQuery q vals $= CL.map (runToRecord recordFromSql')+         -> ConduitT () a m ()+runQuery q vals = rawQuery q vals .| CL.map (runToRecord recordFromSql)  rawQuery :: ( MonadResource m             , MonadReader env m-#if MIN_VERSION_persistent(2, 5, 0)             , HasPersistBackend env             , BaseBackend env ~ SqlBackend-#else-            , HasPersistBackend env SqlBackend-#endif             , ToSql PersistValue p             )          => Query p a          -> p-         -> Source m [PersistValue]+         -> ConduitT () [PersistValue] m () rawQuery q vals = PersistSql.rawQuery queryTxt params   where     queryTxt = T.pack . untypeQuery $ q

@@ -0,0 +1,29 @@+module Database.Persist.Relational.Config+    ( NameConfig(..)+    , defaultNameConfig+    ) where++import Data.Char++data NameConfig = NameConfig+    { tableVarNameFromTableTypeName :: String -> String+    , insertVarNameFromTableTypeName :: String -> String+    , insertQueryVarNameFromTableTypeName :: String -> String+    , columnNameToLabelName :: String -> String+    }++defaultNameConfig :: NameConfig+defaultNameConfig = NameConfig+    { tableVarNameFromTableTypeName = toLowerCamel . (++ "_table")+    , insertVarNameFromTableTypeName = toLowerCamel . ("insert_" ++)+    , insertQueryVarNameFromTableTypeName = toLowerCamel . ("insertQuery_" ++)+    , columnNameToLabelName = toLowerCamel+    }++toLowerCamel :: String -> String+toLowerCamel [] = []+toLowerCamel (x:xs) = toLower x : go xs+  where+    go [] = []+    go ('_':c:cs) = toUpper c : go cs+    go (c:cs) = c : go cs

@@ -1,45 +1,95 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TemplateHaskell #-}--module Database.Persist.Relational.TH-       where+{-# LANGUAGE StandaloneDeriving #-} -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif+module Database.Persist.Relational.TH where +import qualified Data.Array as Arr import Data.Int-import Data.List import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T import Database.Persist import Database.Persist.Quasi-import Database.Persist.Relational.ToPersistEntity+import Database.Persist.Relational.Config import qualified Database.Persist.Sql as PersistSql import Database.Record (PersistableWidth (..))-import Database.Record.FromSql-import Database.Record.TH ( deriveNotNullType-#if MIN_VERSION_persistable_record(0, 5, 0)-                          , recordTemplate-#else-                          , recordType-#endif-                          )-import Database.Record.ToSql-#if MIN_VERSION_relational_query(0, 10, 0)-import Database.Relational-import Database.Relational.TH (defineTable, defineScalarDegree)-#else-import Database.Relational.Query-import Database.Relational.Query.TH (defineTable, defineScalarDegree)-#endif+import Database.Record.FromSql (FromSql(..), valueRecordFromSql)+import Database.Record.Persistable+    ( PersistableRecordWidth+    , ProductConst+    , genericFieldOffsets+    , getProductConst+    , runPersistableRecordWidth+    )+import Database.Record.TH (deriveNotNullType)+import Database.Record.ToSql (ToSql (..), valueRecordToSql)+import Database.Relational (LiteralSQL(..))+import Database.Relational.OverloadedProjection (HasProjection(..))+import Database.Relational.Pi.Unsafe (definePi)+import Database.Relational.TH (defineTableTypes, defineScalarDegree, defineHasNotNullKeyInstance) import GHC.Generics import Language.Haskell.TH+import Language.Haskell.TH.Name.CamelCase (VarName (..), varCamelcaseName) +mkHrr :: [EntityDef] -> Q [Dec]+mkHrr = mkHrrWithConfig defaultNameConfig++mkHrrWithConfig :: NameConfig -> [EntityDef] -> Q [Dec]+mkHrrWithConfig conf = concatMapM (mkHrrForEntityDef conf)++mkHrrForEntityDef :: NameConfig -> EntityDef -> Q [Dec]+mkHrrForEntityDef conf ent = do+    pkeyInstances <- mkPersistablePrimaryKey idType+    tableTypes <- defineTableTypesForTableDef conf tableDef+    piProjections <- defineMonomorphicProjections tableDef+    pwidthInstances <- definePersistableWidthInstances tableType+    fromSqlInstances <- defineFromSqlPersistValueInstances tableType+    notNullD <- defineHasNotNullKeyInstance [t|Entity $tableType|] 0 -- Entity key is always not null and pos=0++    return $ pkeyInstances ++ tableTypes ++ piProjections ++ pwidthInstances ++ fromSqlInstances ++ notNullD+  where+    tableDef@TableDef { tableType, tableIdColumn = Column {columnType = idType} } = entityDefToTableDef conf ent++-- | standalone deriving Generic instance for entity IDs.+--+-- Persistent does not derive Generic instances for `Key a`.+-- see https://github.com/yesodweb/persistent/pull/734#issuecomment-346696921+--     https://github.com/yesodweb/persistent/issues/578+deriveGenericForEntityId :: [EntityDef] -> Q [Dec]+deriveGenericForEntityId entityDefs =+    concatMapM mkDerivingGeneric $ map (mkFieldType . entityId) entityDefs+  where+    mkDerivingGeneric typ = [d| deriving instance Generic $typ |]++data TableDef = TableDef+    { tableType :: TypeQ+    , tableTypeName :: String+    , tableDatabaseName :: String+    , tableIdColumn :: Column+    , tableColumns :: [Column]+    }++data Column = Column+    { columnDBName :: String+    , columnLabelName :: String+    , columnType :: TypeQ+    }++entityDefToTableDef :: NameConfig -> EntityDef -> TableDef+entityDefToTableDef conf@NameConfig {..} ent =+    TableDef+    { tableType = conT $ mkName typeName+    , tableTypeName = typeName+    , tableDatabaseName = T.unpack . unDBName . entityDB $ ent+    , tableIdColumn = makeColumn conf $ entityId ent+    , tableColumns = map (makeColumn conf) $ entityFields ent+    }+  where+    typeName = T.unpack . unHaskellName . entityHaskell $ ent+ ftToType :: FieldType -> TypeQ ftToType (FTTypeCon Nothing t) = conT $ mkName $ T.unpack t -- This type is generated from the Quasi-Quoter.@@ -49,92 +99,104 @@ ftToType (FTApp x y) = ftToType x `appT` ftToType y ftToType (FTList x) = listT `appT` ftToType x -makeColumns :: EntityDef-            -> [(String, TypeQ)]-makeColumns t =-    mkCol (entityId t) : map mkCol (entityFields t)+makeColumn :: NameConfig -> FieldDef -> Column+makeColumn NameConfig{columnNameToLabelName} fd@FieldDef { fieldDB = DBName dbName } =+    Column+    { columnDBName = columnName+    , columnLabelName = columnNameToLabelName columnName+    , columnType = mkFieldType fd+    }   where-    mkCol fd = (toS $ fieldDB fd, mkFieldType fd)-    toS = T.unpack . unDBName+    columnName = T.unpack dbName --- | Generate all templates about table from persistent table definition.-defineTableFromPersistentWithConfig-    :: Config                   -- ^ Configration for haskell relational record-    -> String                   -- ^ Database schema name-    -> Name                     -- ^ Name of the persistent record type corresponds to the table-    -> [EntityDef]              -- ^ @EntityDef@ which is generated by persistent+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM = (fmap concat .) . mapM++-- | Generate `HasProjection "columnName" (Entity table) columnType` instances+defineMonomorphicProjections :: TableDef -> Q [Dec]+defineMonomorphicProjections TableDef{tableTypeName = tableTypeNameStr, tableIdColumn, tableColumns} = do+    columnOffsetsVarName <- newName $ "columnOffsets" ++ tableTypeNameStr+    columnOffsetsEntityVarName <- newName $ "columnOffsetsEntity" ++ tableTypeNameStr+    coVar <- defineColumnOffsetsVar tableTypeName columnOffsetsVarName columnOffsetsEntityVarName+    piPrjs <- concatMapM (definePiProjection tableTypeName columnOffsetsEntityVarName) $ zip [0..] columns+    return $ coVar ++ piPrjs+  where+    tableTypeName = mkName tableTypeNameStr+    columns = tableIdColumn : tableColumns++-- | Generate a `HasProjection "columnName" (Entity table) columnType` instance+definePiProjection ::+       Name -- ^ table type name+    -> Name -- ^ columnOffsetsVarName+    -> (Integer, Column) -- ^ (column idx, (column name, column type))     -> Q [Dec]-defineTableFromPersistentWithConfig config schema persistentRecordName entities =-    case filter ((== nameBase persistentRecordName) . T.unpack . unHaskellName . entityHaskell) entities of-        (t:_) -> do-            let columns = makeColumns t-                tableName = T.unpack . unDBName . entityDB $ t-                -- (mkName Generic) != ''Generic == GHC.Generics.Generic-                deriveNames = filter (/= "Generic") . entityDerives $ t-                derives = ''Generic : map (mkName . T.unpack) deriveNames-            tblD <- defineTable-                        config-                        schema-                        tableName-                        columns-                        derives-                        [0]-                        (Just 0)-            entI <- makeToPersistEntityInstance config schema tableName persistentRecordName columns-            return $ tblD ++ entI-        _ -> error $ "makeColumns: Table related to " ++ show persistentRecordName ++ " not found"+definePiProjection tableTypeName columnOffsetsEntityVarName (colIdx, Column {..}) =+    [d| instance HasProjection $(litT . strTyLit $ columnLabelName) (Entity $(conT tableTypeName)) $(columnType) where+            projection _ = definePi $ $(varE columnOffsetsEntityVarName) Arr.! $(litE . integerL $ colIdx)+    |] --- | Generate all templates about table from persistent table definition using default naming rule.-defineTableFromPersistent-    :: Name                     -- ^ Name of the persistent record type corresponds to the table-    -> [EntityDef]              -- ^ @EntityDef@ which is generated by persistent+defineColumnOffsetsVar ::+       Name -- ^ table type name+    -> Name -- ^ columnOffsetsVarName+    -> Name -- ^ columnOffsetsEntityVarName     -> Q [Dec]-defineTableFromPersistent =-    defineTableFromPersistentWithConfig-        defaultConfig { schemaNameMode = SchemaNotQualified }-        (error "[bug] Database.Persist.Relational.TH.defineTableFromPersistent: schema name must not be used")+defineColumnOffsetsVar tableTypeName columnOffsetsVarName columnOffsetsEntityVarName = do+    sig <- sigD columnOffsetsVarName [t| Arr.Array Int Int |]+    val <- valD (varP columnOffsetsVarName) (normalB [| getProductConst (genericFieldOffsets :: ProductConst (Arr.Array Int Int) $(conT tableTypeName)) |]) [] -makeToPersistEntityInstance :: Config -> String -> String -> Name -> [(String, TypeQ)] -> Q [Dec]-makeToPersistEntityInstance config schema tableName persistentRecordName columns = do-    (typName, dataConName) <- recType <$> reify persistentRecordName-    deriveToPersistEntityForRecord hrrRecordType (conT typName, conE dataConName) columns+    -- `Entity val` has nested data structure, but we assume that it has flat data structure like: (id, val1, val2, ...)+    sigEnt <- sigD columnOffsetsEntityVarName [t| Arr.Array Int Int |]+    valEnt <-+        valD+            (varP columnOffsetsEntityVarName)+            (normalB+                 [|Arr.listArray (0, length $(varE columnOffsetsVarName)) $+                     (0 :) . map (+ runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth (PersistSql.Key $(conT tableTypeName)))) . Arr.elems $ $(varE columnOffsetsVarName)+                  |])+            []+    return [sig, val, sigEnt, valEnt]++defineTableTypesForTableDef :: NameConfig -> TableDef -> Q [Dec]+defineTableTypesForTableDef conf TableDef {..} =+    defineTableTypes+        tableOfVarName+        tableVarName+        insertVarName+        insertQueryVarName+        [t|Entity $tableType|]+        tableDatabaseName+        colNames   where-#if MIN_VERSION_template_haskell(2, 11, 0)-    recType (TyConI (DataD _ tName [] _ [RecC dcName _] _)) = (tName, dcName)-#else-    recType (TyConI (DataD _ tName [] [RecC dcName _] _)) = (tName, dcName)-#endif-    recType info = error $ "makeToPersistEntityInstance: unexpected record info " ++ show info+    tableOfVarName = varCamelcaseName $ "tableOf_" ++ tableTypeName+    mkVarName f = VarName $ mkName $ f conf tableTypeName+    tableVarName = mkVarName tableVarNameFromTableTypeName+    insertVarName = mkVarName insertVarNameFromTableTypeName+    insertQueryVarName = mkVarName insertQueryVarNameFromTableTypeName+    colNames = map columnDBName $ tableIdColumn : tableColumns -#if MIN_VERSION_persistable_record(0, 5, 0)-    hrrRecordType = fst $ recordTemplate (recordConfig . nameConfig $ config) schema tableName-#else-    hrrRecordType = recordType (recordConfig . nameConfig $ config) schema tableName-#endif --- | Generate instances for haskell-relational-record.-mkHrrInstances :: [EntityDef] -> Q [Dec]-mkHrrInstances entities =-    concat `fmap` mapM mkHrrInstancesEachEntityDef entities+definePersistableWidthInstances :: TypeQ -> Q [Dec]+definePersistableWidthInstances tableType =+    [d| instance PersistableWidth $tableType+        instance PersistableWidth (Entity $tableType) |] -mkHrrInstancesEachEntityDef :: EntityDef -> Q [Dec]-mkHrrInstancesEachEntityDef = mkPersistablePrimaryKey . entityId+defineFromSqlPersistValueInstances :: TypeQ -> Q [Dec]+defineFromSqlPersistValueInstances tableType =+    [d| instance FromSql PersistValue $tableType+        instance FromSql PersistValue (Entity $tableType) |] -mkPersistablePrimaryKey :: FieldDef -> Q [Dec]-mkPersistablePrimaryKey fd = do+mkPersistablePrimaryKey :: TypeQ -> Q [Dec]+mkPersistablePrimaryKey typ = do     notNullD <- deriveNotNullType typ     persistableD <- defineFromToSqlPersistValue typ     scalarDegD <- defineScalarDegree typ     showCTermSQLD <- mkShowConstantTermsSQL typ-    toPersistEntityD <- deriveTrivialToPersistEntity typ-    return $ notNullD ++ persistableD ++ scalarDegD ++ showCTermSQLD ++ toPersistEntityD-  where-    typ = mkFieldType fd+    return $ notNullD ++ persistableD ++ scalarDegD ++ showCTermSQLD  mkShowConstantTermsSQL :: TypeQ -> Q [Dec] mkShowConstantTermsSQL typ =-    [d|instance ShowConstantTermsSQL $typ where-           showConstantTermsSQL' = showConstantTermsSQL' . PersistSql.fromSqlKey|]+    [d|instance LiteralSQL $typ where+           showLiteral' = showLiteral' . PersistSql.fromSqlKey|]  mkFieldType :: FieldDef -> TypeQ mkFieldType fd =@@ -155,20 +217,6 @@                 recordToSql = valueRecordToSql toPersistValue |]     return $ fromSqlI ++ toSqlI -deriveTrivialToPersistEntity :: TypeQ -> Q [Dec]-deriveTrivialToPersistEntity typ =-    [d| instance ToPersistEntity $typ $typ where-            recordFromSql' = recordFromSql |]--deriveToPersistEntityForRecord :: TypeQ -> (TypeQ, ExpQ) -> [(String, TypeQ)] -> Q [Dec]-deriveToPersistEntityForRecord hrrTyp (pTyp, pCon) ((_, pKeyTyp):columns) =-    [d| instance ToPersistEntity $hrrTyp (Entity $pTyp) where-            recordFromSql' = Entity <$> (recordFromSql :: RecordFromSql PersistValue $pKeyTyp) <*> $rfsql |]-  where-    fields = map (\(_, typ) -> [| recordFromSql :: RecordFromSql PersistValue $typ |]) columns-    rfsql = foldl' (\s a -> [| $s <*> $a |]) [| pure $pCon |] fields-deriveToPersistEntityForRecord _ _ [] = fail "deriveToPersistEntityForRecord: missing columns"- unsafePersistValueFromSql :: PersistField a => PersistValue -> a unsafePersistValueFromSql v =     case fromPersistValue v of@@ -185,11 +233,7 @@        ClassI _ instances -> return . M.fromList $ mapMaybe (go pfT) instances        unknown -> fail $ "persistValueTypesFromPersistFieldInstances: unknown declaration: " ++ show unknown   where-#if MIN_VERSION_template_haskell(2, 11, 0)     go pfT (InstanceD _ [] (AppT insT t@(ConT n)) [])-#else-    go pfT (InstanceD [] (AppT insT t@(ConT n)) [])-#endif            | insT == pfT           && nameBase n `notElem` blacklist = Just (n, return t)     go _ _ = Nothing@@ -201,11 +245,7 @@     unknownDecl decl = fail $ "persistableWidthTypes: Unknown declaration: " ++ show decl     goI (ClassI _ instances) = return . M.fromList . mapMaybe goD $ instances     goI unknown = unknownDecl unknown-#if MIN_VERSION_template_haskell(2, 11, 0)     goD (InstanceD _ _cxt (AppT _insT a@(ConT n)) _defs) = Just (n, return a)-#else-    goD (InstanceD _cxt (AppT _insT a@(ConT n)) _defs) = Just (n, return a)-#endif     goD _ = Nothing  derivePersistableInstancesFromPersistFieldInstances@@ -215,9 +255,8 @@     types <- persistValueTypesFromPersistFieldInstances blacklist     pwts <- persistableWidthTypes     ftsql <- concatMapTypes defineFromToSqlPersistValue types-    toER <- concatMapTypes deriveTrivialToPersistEntity types     ws <- concatMapTypes deriveNotNullType $ types `M.difference` pwts-    return $ ftsql ++ toER ++ ws+    return $ ftsql ++ ws   where     concatMapTypes :: (Q Type -> Q [Dec]) -> M.Map Name TypeQ -> Q [Dec]     concatMapTypes f = fmap concat . mapM f . M.elems

@@ -1,18 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}--module Database.Persist.Relational.ToPersistEntity-       where--import Database.Record.FromSql (RecordFromSql, recordFromSql, (<&>))-import Database.Persist (PersistValue)--class ToPersistEntity a b | a -> b, b -> a where-    recordFromSql' :: RecordFromSql PersistValue b--instance ToPersistEntity () () where-    recordFromSql' = recordFromSql--instance (ToPersistEntity a c, ToPersistEntity b d) =>  ToPersistEntity (a, b) (c, d) where-    recordFromSql' = recordFromSql' <&> recordFromSql'

@@ -1,4 +1,4 @@-resolver: lts-9.14+resolver: lts-13.7 packages: - '.' extra-deps: []

@@ -1,11 +1,14 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}  module Fixtures.BlogSample.Model where @@ -13,26 +16,27 @@ import Data.Time import Database.Persist.TH import Database.Persist.Relational+import GHC.Generics -share [mkPersist sqlSettings, mkMigrate "migrateAll", mkSave "db", mkHrrInstances] [persistLowerCase|+share [mkPersist sqlSettings, mkMigrate "migrateAll", mkHrr, deriveGenericForEntityId] [persistLowerCase| User     name    Text     age     Int     UniqueUserName name-    deriving Show Eq+    deriving Show Eq Generic Post     title   Text     userId  UserId     created UTCTime     body    Text-    deriving Show Eq+    deriving Show Eq Generic Tag     name    Text     UniqueTagName name-    deriving Show Eq+    deriving Show Eq Generic PostTag     postId  PostId     tagId   TagId     UniquePostTag postId tagId-    deriving Show Eq+    deriving Show Eq Generic |]

@@ -1,16 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Fixtures.BlogSample.Post where--import Data.Text (Text)-import Data.Time-import Database.Persist.Relational-import Fixtures.BlogSample.Model hiding (Post)-import qualified Fixtures.BlogSample.Model as Model--defineTableFromPersistent ''Model.Post db-

@@ -1,14 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Fixtures.BlogSample.PostTag where--import Database.Persist.Relational-import Fixtures.BlogSample.Model hiding (PostTag)-import qualified Fixtures.BlogSample.Model as Model--defineTableFromPersistent ''Model.PostTag db-

@@ -1,15 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Fixtures.BlogSample.Tag where--import Data.Text (Text)-import Database.Persist.Relational-import Fixtures.BlogSample.Model hiding (Tag)-import qualified Fixtures.BlogSample.Model as Model--defineTableFromPersistent ''Model.Tag db-

@@ -1,15 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Fixtures.BlogSample.User where--import Data.Text (Text)-import Database.Persist.Relational-import Fixtures.BlogSample.Model hiding (User)-import qualified Fixtures.BlogSample.Model as Model--defineTableFromPersistent ''Model.User db-

@@ -1,20 +1,12 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}  module Main where -#if MIN_VERSION_relational_query(0, 10, 0) import Database.Relational as HRR-#else-import Database.Relational.Query as HRR-#endif import Fixtures.BlogSample.Model-import qualified Fixtures.BlogSample.Post as Post-import qualified Fixtures.BlogSample.PostTag as PostTag-import qualified Fixtures.BlogSample.Tag as Tag-import qualified Fixtures.BlogSample.User as User import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.TH@@ -25,8 +17,8 @@     show subject @?= "SELECT ALL T0.id AS f0, T0.name AS f1, T0.age AS f2 FROM user T0 WHERE (T0.name = 'testuser')"   where     subject = relation $ do-        user <- query User.user-        wheres $ user ! User.name' .=. value "testuser"+        user <- query userTable+        wheres $ #name user .=. value "testuser"         return user  case_simple_equal_id_query :: Assertion@@ -34,8 +26,8 @@     show subject @?= "SELECT ALL T0.id AS f0, T0.name AS f1, T0.age AS f2 FROM user T0 WHERE (T0.id = 1)"   where     subject = relation $ do-        user <- query User.user-        wheres $ user ! User.id' .=. value (UserKey 1)+        user <- query userTable+        wheres $ #id user .=. value (UserKey 1)         return user  case_simple_equal_placeholder :: Assertion@@ -43,8 +35,8 @@     show subject @?= "SELECT ALL T0.id AS f0, T0.name AS f1, T0.age AS f2 FROM user T0 WHERE (T0.id = ?)"   where     subject = relation' . placeholder $ \ph -> do-        user <- query User.user-        wheres $ user ! User.id' .=. ph+        user <- query userTable+        wheres $ #id user .=. ph         return user  case_simple_comparing_int_query :: Assertion@@ -52,8 +44,8 @@     show subject @?= "SELECT ALL T0.id AS f0, T0.name AS f1, T0.age AS f2 FROM user T0 WHERE (T0.age >= 18)"   where     subject = relation $ do-        user <- query User.user-        wheres $ user ! User.age' .>=. value 18+        user <- query userTable+        wheres $ #age user .>=. value 18         return user  case_inner_join_query :: Assertion@@ -61,10 +53,10 @@     show subject @?= "SELECT ALL T0.id AS f0, T0.title AS f1, T0.user_id AS f2, T0.created AS f3, T0.body AS f4 FROM post T0 INNER JOIN user T1 ON (T1.id = T0.user_id) WHERE (T1.age > 18)"   where     subject = relation $ do-        post <- query Post.post-        user <- query User.user-        on $ user ! User.id' .=. post ! Post.userId'-        wheres $ user ! User.age' .>. value 18+        post <- query postTable+        user <- query userTable+        on $ #id user .=. #userId post+        wheres $ #age user .>. value 18         return post  case_inner_join_with_subquery :: Assertion@@ -72,18 +64,18 @@     show subject @?= "SELECT ALL T0.id AS f0, T0.title AS f1, T0.user_id AS f2, T0.created AS f3, T0.body AS f4 FROM post T0 INNER JOIN (SELECT ALL T2.post_id AS f0 FROM tag T1 INNER JOIN post_tag T2 ON (T1.id = T2.tag_id) WHERE (T1.name IN ('haskell', 'hrr')) GROUP BY T2.post_id HAVING (COUNT(T2.post_id) = 2)) T3 ON (T0.id = T3.f0)"   where     subject = relation $ do-        post <- query Post.post+        post <- query postTable         postids <- query $ postIdsFromTagNameList ["haskell", "hrr"]-        on $ post ! Post.id' .=. postids+        on $ #id post .=. postids         return post      postIdsFromTagNameList taglist = aggregateRelation $ do-        tag <- query Tag.tag-        posttag <- query PostTag.postTag-        on $ tag ! Tag.id' .=. posttag ! PostTag.tagId'-        wheres $ tag ! Tag.name' `in'` values taglist-        g <- groupBy $ posttag ! PostTag.postId'-        let c = HRR.count $ posttag ! PostTag.postId'+        tag <- query tagTable+        posttag <- query postTagTable+        on $ #id tag .=. #tagId posttag+        wheres $ #name tag `in'` values taglist+        g <- groupBy $ #postId posttag+        let c = HRR.count $ #postId posttag         having $ c .=. value (length taglist)         return g