genvalidity-persistent (empty) → 0.0.0.0

raw patch · 6 files changed

+330/−0 lines, 6 filesdep +QuickCheckdep +basedep +containers

Dependencies added: QuickCheck, base, containers, criterion, deepseq, genvalidity, genvalidity-containers, genvalidity-criterion, genvalidity-hspec, genvalidity-persistent, hspec, persistent, persistent-template, validity-containers, validity-persistent

Files

• LICENSE +21/−0
• bench/Main.hs +59/−0
• genvalidity-persistent.cabal +82/−0
• src/Data/GenValidity/Persist.hs +93/−0
• test/Data/GenValidity/PersistSpec.hs +74/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2016-2020 Tom Sydney Kerckhove++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Main where++import Control.DeepSeq+import Criterion.Main+import Data.GenValidity+import Data.GenValidity.Criterion+import Data.GenValidity.Persist ()+import Database.Persist+import Database.Persist.Sql+import Database.Persist.TH+import GHC.Generics (Generic)++share+  [mkPersist sqlSettings]+  [persistLowerCase|++Thing+  number Int++  deriving Show+  deriving Eq+  deriving Ord+  deriving Generic++|]++instance Validity Thing++instance GenUnchecked Thing++instance GenValid Thing++instance NFData (Key Thing) where+  rnf = rnf . fromSqlKey++instance NFData Thing++instance NFData (Entity Thing) where+  rnf (Entity k v) = seq (rnf k) $ rnf v++main :: IO ()+main =+  defaultMain+    [ genValidBench @ThingId,+      genValidBench @(Entity Thing)+    ]

@@ -0,0 +1,82 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: f8a0ec9a40a5f3d148068cf9d75a3f6c86751f3038e70bf242194a2528fefd75++name:           genvalidity-persistent+version:        0.0.0.0+synopsis:       GenValidity support for Persistent+category:       Testing+homepage:       https://github.com/NorfairKing/validity#readme+bug-reports:    https://github.com/NorfairKing/validity/issues+author:         Tom Sydney Kerckhove+maintainer:     syd@cs-syd.eu+copyright:      Copyright: (c) 2020 Tom Sydney Kerckhove+license:        MIT+license-file:   LICENSE+build-type:     Simple++source-repository head+  type: git+  location: https://github.com/NorfairKing/validity++library+  exposed-modules:+      Data.GenValidity.Persist+  other-modules:+      Paths_genvalidity_persistent+  hs-source-dirs:+      src+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , containers+    , genvalidity+    , genvalidity-containers+    , persistent >=0.5+    , validity-containers+    , validity-persistent+  default-language: Haskell2010++test-suite genvalidity-persistent-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Data.GenValidity.PersistSpec+      Paths_genvalidity_persistent+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , genvalidity+    , genvalidity-hspec+    , genvalidity-persistent+    , hspec+    , persistent >=0.5+    , persistent-template+    , validity-containers+  default-language: Haskell2010++benchmark genvalidity-persistent-bench+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_genvalidity_persistent+  hs-source-dirs:+      bench+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+      base >=4.7 && <5+    , criterion+    , deepseq+    , genvalidity+    , genvalidity-criterion+    , genvalidity-persistent+    , persistent >=0.5+    , persistent-template+  default-language: Haskell2010

@@ -0,0 +1,93 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.GenValidity.Persist where++import Data.GenValidity+import Data.GenValidity.Containers+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Validity.Containers+import Data.Validity.Persist ()+import Database.Persist+import Database.Persist.Sql+import Test.QuickCheck++instance ToBackendKey SqlBackend record => GenUnchecked (Key record) where+  genUnchecked = toSqlKey <$> genUnchecked+  shrinkUnchecked = fmap toSqlKey . shrinkValid . fromSqlKey++instance ToBackendKey SqlBackend record => GenValid (Key record) where+  genValid = toSqlKey <$> genValid+  shrinkValid = shrinkUnchecked++instance+  (GenUnchecked a, ToBackendKey SqlBackend a) =>+  GenUnchecked (Entity a)+  where+  genUnchecked = Entity <$> genUnchecked <*> genUnchecked+  shrinkUnchecked (Entity k v) = [Entity k' v' | (k', v') <- shrinkUnchecked (k, v)]++instance (GenValid a, ToBackendKey SqlBackend a) => GenValid (Entity a) where+  genValid = Entity <$> genValid <*> genValid+  shrinkValid (Entity k v) = [Entity k' v' | (k', v') <- shrinkValid (k, v)]++validsWithSeperateIDs ::+  forall a.+  (ToBackendKey SqlBackend a, GenValid a) =>+  Gen [Entity a]+validsWithSeperateIDs = genValidsWithSeperateIDs genValid++genValidsWithSeperateIDs ::+  forall a.+  (PersistEntity a, ToBackendKey SqlBackend a) =>+  Gen a ->+  Gen [Entity a]+genValidsWithSeperateIDs gen =+  sized $ \n -> do+    list <- arbPartition n+    go list+  where+    go :: [Int] -> Gen [Entity a]+    go [] = pure []+    go (s : ss) = do+      es <- go ss+      resize s $ do+        ei <- genValid `suchThat` (`notElem` map entityKey es)+        e <- gen+        pure $ Entity ei e : es++genSeperateIdsForNE ::+  forall a.+  (PersistEntity a, ToBackendKey SqlBackend a, GenValid a) =>+  NonEmpty a ->+  Gen (NonEmpty (Entity a))+genSeperateIdsForNE (a :| as) = do+  es <- genSeperateIdsFor as+  i <- genValid `suchThat` (`notElem` map entityKey es)+  pure (Entity i a :| es)++genSeperateIds ::+  forall a.+  (PersistEntity a, ToBackendKey SqlBackend a) =>+  Gen [Key a]+genSeperateIds = genSeperate genValid++genSeperateIdsFor ::+  forall a.+  (ToBackendKey SqlBackend a, GenValid a) =>+  [a] ->+  Gen [Entity a]+genSeperateIdsFor [] = pure []+genSeperateIdsFor (a : as) = NE.toList <$> genSeperateIdsForNE (a :| as)++#if MIN_VERSION_containers(0,6,0)+shrinkValidWithSeperateIds ::+  (PersistEntity a, ToBackendKey SqlBackend a, GenValid a) =>+  [Entity a] ->+  [[Entity a]]+shrinkValidWithSeperateIds = filter (distinctOrd . map entityKey) . shrinkValid+#endif

@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.GenValidity.PersistSpec+  ( spec,+  )+where++import Data.GenValidity.Persist+import Data.Validity.Containers+import Database.Persist+import Database.Persist.TH+import GHC.Generics (Generic)+import Test.Hspec+import Test.QuickCheck+import Test.Validity++share+  [mkPersist sqlSettings]+  [persistLowerCase|++Thing+  number Int++  deriving Show+  deriving Eq+  deriving Ord+  deriving Generic++|]++instance Validity Thing++instance GenUnchecked Thing++instance GenValid Thing++spec :: Spec+spec = do+  genValidSpec @ThingId+  shrinkValidSpec @ThingId+  genValidSpec @(Entity Thing)+  shrinkValidSpec @(Entity Thing)+  describe "genSeperateIds"+    $ it "generates values with seperate ids"+    $ forAll genSeperateIds+    $ \is -> distinctOrd (is :: [Key Thing])+  describe "genSeperateIdsFor"+    $ it "generates values with seperate ids"+    $ forAll genValid+    $ \as ->+      forAll (genSeperateIdsFor as) $ \es -> distinctOrd $ map entityKey (es :: [Entity Thing])+  describe "genValidsWithSeperateIds" $ do+    it "generates values with seperate ids"+      $ forAll (genValidsWithSeperateIDs genValid)+      $ \es ->+        distinctOrd $ map entityKey (es :: [Entity Thing])+    it "generates values with seperate ids"+      $ forAll (genValidsWithSeperateIDs genValid)+      $ \es ->+        distinctOrd $ map entityKey (es :: [Entity Thing])+  describe "validsWithSeperateIDs"+    $ it "generates values with seperate ids"+    $ forAll validsWithSeperateIDs+    $ \es -> distinctOrd $ map entityKey (es :: [Entity Thing])

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}