diff --git a/flake.lock b/flake.lock index bc8772785..4cea76bca 100644 --- a/flake.lock +++ b/flake.lock @@ -16,23 +16,6 @@ "type": "github" } }, - "cabal-32": { - "flake": false, - "locked": { - "lastModified": 1603716527, - "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", - "owner": "haskell", - "repo": "cabal", - "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "3.2", - "repo": "cabal", - "type": "github" - } - }, "cabal-34": { "flake": false, "locked": { @@ -118,52 +101,51 @@ "type": "github" } }, - "ghc-8.6.5-iohk": { + "hackage": { "flake": false, "locked": { - "lastModified": 1600920045, - "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", + "lastModified": 1772412768, + "narHash": "sha256-GWrUAQGblUGCdv7ck831vDhbsMDWIfNUodYeXdwFfps=", "owner": "input-output-hk", - "repo": "ghc", - "rev": "95713a6ecce4551240da7c96b6176f980af75cae", + "repo": "hackage.nix", + "rev": "dbfac005ac9d1527db75bbef6b38b0969f1f3133", "type": "github" }, "original": { "owner": "input-output-hk", - "ref": "release/8.6.5-iohk", - "repo": "ghc", + "repo": "hackage.nix", "type": "github" } }, - "hackage": { + "hackage-for-stackage": { "flake": false, "locked": { - "lastModified": 1740615848, - "narHash": "sha256-YhhduYJuXQtNzM5H/g6g4neJtYax4sZFnPY+lBP/bZQ=", + "lastModified": 1772411634, + "narHash": "sha256-BQtMh/7lAwEA8scXMpR37OazFrrgrUDZLvpCvwTc5mA=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "fc0b2e94f27de17fca8e63f15fbb8987e23ff9ae", + "rev": "c6e2b792c9255c43c698582ac469a53d7e69b6ee", "type": "github" }, "original": { "owner": "input-output-hk", + "ref": "for-stackage", "repo": "hackage.nix", "type": "github" } }, - "hackage-for-stackage": { + "hackage-internal": { "flake": false, "locked": { - "lastModified": 1740615838, - "narHash": "sha256-Lg6E0uRfGzOEUjhiE/UAj1IQkPwFnG264wPtV+sYcpY=", + "lastModified": 1750307553, + "narHash": "sha256-iiafNoeLHwlSLQTyvy8nPe2t6g5AV4PPcpMeH/2/DLs=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "4a4aea6de97835226109669f083d27319354ab25", + "rev": "f7867baa8817fab296528f4a4ec39d1c7c4da4f3", "type": "github" }, "original": { "owner": "input-output-hk", - "ref": "for-stackage", "repo": "hackage.nix", "type": "github" } @@ -171,16 +153,19 @@ "haskellNix": { "inputs": { "HTTP": "HTTP", - "cabal-32": "cabal-32", "cabal-34": "cabal-34", "cabal-36": "cabal-36", "cardano-shell": "cardano-shell", "flake-compat": "flake-compat", - "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", "hackage": "hackage", "hackage-for-stackage": "hackage-for-stackage", + "hackage-internal": "hackage-internal", + "hls": "hls", "hls-1.10": "hls-1.10", "hls-2.0": "hls-2.0", + "hls-2.10": "hls-2.10", + "hls-2.11": "hls-2.11", + "hls-2.12": "hls-2.12", "hls-2.2": "hls-2.2", "hls-2.3": "hls-2.3", "hls-2.4": "hls-2.4", @@ -199,16 +184,18 @@ "nixpkgs-2311": "nixpkgs-2311", "nixpkgs-2405": "nixpkgs-2405", "nixpkgs-2411": "nixpkgs-2411", + "nixpkgs-2505": "nixpkgs-2505", + "nixpkgs-2511": "nixpkgs-2511", "nixpkgs-unstable": "nixpkgs-unstable", "old-ghc-nix": "old-ghc-nix", "stackage": "stackage" }, "locked": { - "lastModified": 1740617510, - "narHash": "sha256-dZEpPNJLyUErO5WO0+HTOX5/ywZuibyy4Byp7g8rQJ8=", + "lastModified": 1772413018, + "narHash": "sha256-R1dNN5bb7Ohv1Zy1YEbxVqq9ekZt1hfpZ6aqAHoOon4=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "cdcce3719c3f47402e9e447961ca66e063d65ea7", + "rev": "28b1839e8aa056d77d0727ce3099ebd6aed495ba", "type": "github" }, "original": { @@ -217,6 +204,22 @@ "type": "github" } }, + "hls": { + "flake": false, + "locked": { + "lastModified": 1741604408, + "narHash": "sha256-tuq3+Ip70yu89GswZ7DSINBpwRprnWnl6xDYnS4GOsc=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "682d6894c94087da5e566771f25311c47e145359", + "type": "github" + }, + "original": { + "owner": "haskell", + "repo": "haskell-language-server", + "type": "github" + } + }, "hls-1.10": { "flake": false, "locked": { @@ -237,11 +240,6 @@ "hls-2.0": { "flake": false, "locked": { - "lastModified": 1739020877, - "narHash": "sha256-mIvECo/NNdJJ/bXjNqIh8yeoSjVLAuDuTUzAo7dzs8Y=", - "owner": "nixos", - "repo": "nixpkgs", - "rev": "a79cfe0ebd24952b580b1cf08cd906354996d547", "lastModified": 1687698105, "narHash": "sha256-OHXlgRzs/kuJH8q7Sxh507H+0Rb8b7VOiPAjcY9sM1k=", "owner": "haskell", @@ -256,6 +254,57 @@ "type": "github" } }, + "hls-2.10": { + "flake": false, + "locked": { + "lastModified": 1743069404, + "narHash": "sha256-q4kDFyJDDeoGqfEtrZRx4iqMVEC2MOzCToWsFY+TOzY=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "2318c61db3a01e03700bd4b05665662929b7fe8b", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.10.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.11": { + "flake": false, + "locked": { + "lastModified": 1747306193, + "narHash": "sha256-/MmtpF8+FyQlwfKHqHK05BdsxC9LHV70d/FiMM7pzBM=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "46ef4523ea4949f47f6d2752476239f1c6d806fe", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.11.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.12": { + "flake": false, + "locked": { + "lastModified": 1758709460, + "narHash": "sha256-xkI8MIIVEVARskfWbGAgP5sHG/lyeKnkm0LIOJ19X5w=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "7d983de4fa7ff54369f6dd31444bdb9869aec83e", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.12.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, "hls-2.2": { "flake": false, "locked": { @@ -378,11 +427,11 @@ "hls-2.9": { "flake": false, "locked": { - "lastModified": 1720003792, - "narHash": "sha256-qnDx8Pk0UxtoPr7BimEsAZh9g2WuTuMB/kGqnmdryKs=", + "lastModified": 1719993701, + "narHash": "sha256-wy348++MiMm/xwtI9M3vVpqj2qfGgnDcZIGXw8sF1sA=", "owner": "haskell", "repo": "haskell-language-server", - "rev": "0c1817cb2babef0765e4e72dd297c013e8e3d12b", + "rev": "90319a7e62ab93ab65a95f8f2bcf537e34dae76a", "type": "github" }, "original": { @@ -411,11 +460,11 @@ "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1717479972, - "narHash": "sha256-7vE3RQycHI1YT9LHJ1/fUaeln2vIpYm6Mmn8FTpYeVo=", + "lastModified": 1770174258, + "narHash": "sha256-x6QYupvHZM7rRpVO4AIC5gUWFprFQ59A95FPC7/Owjg=", "owner": "stable-haskell", "repo": "iserv-proxy", - "rev": "2ed34002247213fc435d0062350b91bab920626e", + "rev": "91ef7ffdeedfb141a4d69dcf9e550abe3e1160c6", "type": "github" }, "original": { @@ -475,11 +524,11 @@ }, "nixpkgs-2411": { "locked": { - "lastModified": 1737255904, - "narHash": "sha256-r3fxHvh+M/mBgCZXOACzRFPsJdix2QSsKazb7VCXXo0=", + "lastModified": 1751290243, + "narHash": "sha256-kNf+obkpJZWar7HZymXZbW+Rlk3HTEIMlpc6FCNz0Ds=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "eacdab35066b0bb1c9413c96898e326b76398a81", + "rev": "5ab036a8d97cb9476fbe81b09076e6e91d15e1b6", "type": "github" }, "original": { @@ -489,13 +538,45 @@ "type": "github" } }, + "nixpkgs-2505": { + "locked": { + "lastModified": 1764560356, + "narHash": "sha256-M5aFEFPppI4UhdOxwdmceJ9bDJC4T6C6CzCK1E2FZyo=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "6c8f0cca84510cc79e09ea99a299c9bc17d03cb6", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-25.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2511": { + "locked": { + "lastModified": 1764572236, + "narHash": "sha256-hLp6T/vKdrBQolpbN3EhJOKTXZYxJZPzpnoZz+fEGlE=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "b0924ea1889b366de6bb0018a9db70b2c43a15f8", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-25.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, "nixpkgs-unstable": { "locked": { - "lastModified": 1737110817, - "narHash": "sha256-DSenga8XjPaUV5KUFW/i3rNkN7jm9XmguW+qQ1ZJTR4=", + "lastModified": 1764587062, + "narHash": "sha256-hdFa0TAVQAQLDF31cEW3enWmBP+b592OvHs6WVe3D8k=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "041c867bad68dfe34b78b2813028a2e2ea70a23c", + "rev": "c1cb7d097cb250f6e1904aacd5f2ba5ffd8a49ce", "type": "github" }, "original": { @@ -535,11 +616,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1740615115, - "narHash": "sha256-8nv8fvnW6axl7ogjOfMQGJ2LhgT7JMcgq1P2yMFynyY=", + "lastModified": 1772237728, + "narHash": "sha256-1GUz83fMt+g8A3Vh8EYakENOEXN9snn2qVlDDE6FmB8=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "dca0ea6196058fbbd367f32f76d184ef550676c1", + "rev": "d3613b6dec720201ac5c57dd7399358ff28a3190", "type": "github" }, "original": { @@ -548,21 +629,6 @@ "type": "github" } }, - "systems": { - "locked": { - "lastModified": 1681028828, - "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", - "owner": "nix-systems", - "repo": "default", - "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", - "type": "github" - }, - "original": { - "owner": "nix-systems", - "repo": "default", - "type": "github" - } - }, "systems": { "locked": { "lastModified": 1681028828, diff --git a/flake.nix b/flake.nix index aff85c381..c706c5a5d 100644 --- a/flake.nix +++ b/flake.nix @@ -20,7 +20,7 @@ (final: prev: { project = final.haskell-nix.project' { src = ./.; - compiler-nix-name = "ghc966"; + compiler-nix-name = "ghc967"; projectFileName = "cabal.project"; shell = { tools = { diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 1459775a2..6b0bc87ba 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -5,7 +5,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} @@ -33,6 +34,7 @@ module Database.Persist.MySQL , copyUnlessNull , copyUnlessEmpty , copyUnlessEq + , copyAll , openMySQLConn ) where @@ -47,15 +49,13 @@ import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Reader (ReaderT, runReaderT) -import Control.Monad.Trans.Writer (runWriterT) +import Control.Monad.Trans.Writer (runWriter, runWriterT, tell) import Data.IORef (newIORef) -import Data.Proxy (Proxy (..)) import Data.Acquire (Acquire, mkAcquire, with) import Data.Aeson import Data.Aeson.Types (modifyFailure) import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as BSL import Data.Conduit import qualified Data.Conduit.List as CL import Data.Either (partitionEithers) @@ -66,7 +66,6 @@ import Data.List (find, groupBy, intercalate, sort) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) -import Data.Monoid ((<>)) import qualified Data.Monoid as Monoid import Data.Pool (Pool) import Data.Text (Text, pack) @@ -80,7 +79,6 @@ import Database.Persist.Sql import Database.Persist.Sql.Types.Internal (makeIsolationLevelStatement) import qualified Database.Persist.Sql.Util as Util import Database.Persist.SqlBackend -import Database.Persist.SqlBackend.StatementCache import qualified Database.MySQL.Base as MySQLBase import qualified Database.MySQL.Base.Types as MySQLBase @@ -1556,6 +1554,24 @@ copyField :: (PersistField typ) => EntityField record typ -> HandleUpdateCollision record copyField = CopyField +-- | Create a list with a @copyField field@ for every @field@ and @value@ in +-- record, except its @Key@. +-- This is useful in combination with @insertManyOnDuplicateKeyUpdate@. +-- The implementation assumes the tabulateEntityA implementation is not strict in +-- the returned field value (and the default implementation indeed isn't). +-- @since 2.13.2.0 +copyAll + :: forall record + . (PersistEntity record, HasCallStack) + => [HandleUpdateCollision record] +copyAll = snd $ runWriter $ tabulateEntityA $ \field -> + error "copyAll: field value was used" + <$ when + ( fieldHaskell (persistFieldDef field) + /= fieldHaskell (persistFieldDef @record persistIdField) + ) + (tell [copyField field]) + -- | Do a bulk insert on the given records in the first parameter. In the event -- that a key conflicts with a record currently in the database, the second and -- third parameters determine what will happen. diff --git a/persistent/Database/Persist/Class/PersistEntity.hs b/persistent/Database/Persist/Class/PersistEntity.hs index 69964d586..d178ea153 100644 --- a/persistent/Database/Persist/Class/PersistEntity.hs +++ b/persistent/Database/Persist/Class/PersistEntity.hs @@ -27,6 +27,7 @@ module Database.Persist.Class.PersistEntity , ViaPersistEntity (..) , recordName , entityValues + , assignAll , keyValueEntityToJSON , keyValueEntityFromJSON , entityIdToJSON @@ -47,7 +48,6 @@ module Database.Persist.Class.PersistEntity ) where import Data.Functor.Apply (Apply) -import Data.Functor.Constant import Data.Aeson ( FromJSON (..) @@ -72,6 +72,9 @@ import qualified Data.Aeson.KeyMap as AM import qualified Data.HashMap.Strict as AM #endif +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Writer.CPS import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isJust) @@ -83,6 +86,7 @@ import qualified Data.Text.Lazy.Builder as TB import GHC.Generics import GHC.OverloadedLabels import GHC.Records +import GHC.Stack import GHC.TypeLits import Database.Persist.Class.PersistField @@ -176,7 +180,7 @@ class -- @since 2.14.0.0 tabulateEntityA :: (Applicative f) - => (forall a. EntityField record a -> f a) + => (forall a. (PersistField a) => EntityField record a -> f a) -- ^ A function that builds a fragment of a record in an -- 'Applicative' context. -> f (Entity record) @@ -188,7 +192,7 @@ class -- @since 2.17.0.0 tabulateEntityApply :: (Apply f) - => (forall a. EntityField record a -> f a) + => (forall a. (PersistField a) => EntityField record a -> f a) -> f (Entity record) -- | Unique keys besides the 'Key'. @@ -208,7 +212,10 @@ class fieldLens :: EntityField record field -> ( forall f - . (Functor f) => (field -> f field) -> Entity record -> f (Entity record) + . (Functor f) + => (field -> f field) + -> Entity record + -> f (Entity record) ) -- | Extract a @'Key' record@ from a @record@ value. Currently, this is @@ -266,7 +273,7 @@ instance (PersistEntity record) => PathMultiPiece (ViaPersistEntity record) wher -- @since 2.14.0.0 tabulateEntity :: (PersistEntity record) - => (forall a. EntityField record a -> a) + => (forall a. (PersistField a) => EntityField record a -> a) -> Entity record tabulateEntity fromField = runIdentity (tabulateEntityA (Identity . fromField)) @@ -276,9 +283,7 @@ type family BackendSpecificUpdate backend record -- Moved over from Database.Persist.Class.PersistUnique -- | Textual representation of the record -recordName - :: (PersistEntity record) - => record -> Text +recordName :: (PersistEntity record) => record -> Text recordName = unEntityNameHS . entityHaskell . entityDef . Just -- | Updating a database entity. @@ -392,6 +397,28 @@ entityValues (Entity k record) = where ent = entityDef $ Just record +-- | Create a list with an @Update field value Assign@ for every @field@ and +-- @value@ in record, except its 'Key'. +-- This is useful in combination with @upsert@. +-- The implementation assumes 'tabulateEntityA' is not strict in the 'entityKey' +-- of 'Entity' (and the default implementation indeed isn't). +-- @since 2.13.2.0 +assignAll + :: forall record. (PersistEntity record, HasCallStack) => record -> [Update record] +assignAll r = snd $ runWriter $ tabulateEntityA $ \field -> + let + fieldVal = getConst $ fieldLens field Const fakeEntity + in + fieldVal + <$ when + ( fieldHaskell (persistFieldDef field) + /= fieldHaskell (persistFieldDef @record persistIdField) + ) + (tell [Update field fieldVal Assign]) + where + -- slightly hacky. The entity key is filtered out above and never used. + fakeEntity = Entity (error "assignAll: tabulateEntityA was strict in the Entity's key") r + -- | Predefined @toJSON@. The resulting JSON looks like -- @{"key": 1, "value": {"name": ...}}@. -- @@ -403,7 +430,8 @@ entityValues (Entity k record) = -- @ keyValueEntityToJSON :: (PersistEntity record, ToJSON record) - => Entity record -> Value + => Entity record + -> Value keyValueEntityToJSON (Entity key value) = object [ "key" .= key @@ -421,7 +449,8 @@ keyValueEntityToJSON (Entity key value) = -- @ keyValueEntityFromJSON :: (PersistEntity record, FromJSON record) - => Value -> Parser (Entity record) + => Value + -> Parser (Entity record) keyValueEntityFromJSON (Object o) = Entity <$> o .: "key"