graphula-core (empty) → 2.0.0.1

raw patch · 11 files changed

+1582/−0 lines, 11 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed

Dependencies added: HUnit, QuickCheck, aeson, base, bytestring, containers, directory, generics-eot, graphula-core, hspec, http-api-data, markdown-unlit, monad-logger, mtl, path-pieces, persistent, persistent-sqlite, persistent-template, random, resourcet, semigroups, temporary, text, transformers, unliftio, unliftio-core, uuid

Files

CHANGELOG.md +7/−0
LICENSE +21/−0
README.md +267/−0
Setup.hs +2/−0
graphula-core.cabal +87/−0
src/Graphula.hs +558/−0
src/Graphula/Arbitrary.hs +34/−0
src/Graphula/Internal.hs +237/−0
src/Graphula/Key.hs +55/−0
test/Graphula/UUIDKey.hs +47/−0
test/README.lhs +267/−0

+ CHANGELOG.md view

@@ -0,0 +1,7 @@+## [*Unreleased*](https://github.com/freckle/graphula/compare/v2.0.0.1...main)++None++## [v2.0.0.1](https://github.com/faktory/graphula/tree/v2.0.0.1)++First tagged release.

+ LICENSE view

@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2020 Renaissance Learning Inc++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.

+ README.md view

@@ -0,0 +1,267 @@+# Graphula Core++Graphula is a simple interface for generating persistent data and linking its dependencies. We use this interface to generate fixtures for automated testing. The interface is extensible and supports pluggable front-ends.+++<!--+```haskell+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-deriving-strategies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main (module Main) where++import Control.Monad (replicateM_)+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger (NoLoggingT)+import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Trans.Resource (ResourceT)+import Database.Persist.Sqlite+import Database.Persist.TH+import Data.Typeable+import GHC.Generics (Generic)+import Graphula+import Graphula.UUIDKey+import Test.Hspec+import Test.QuickCheck++instance (ToBackendKey SqlBackend a) => Arbitrary (Key a) where+  arbitrary = toSqlKey <$> arbitrary+```+-->++## Arbitrary Data++Graphula utilizes `QuickCheck` to generate random data. We need to declare `Arbitrary` instances for our types.++```haskell+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+A+  a String+  b Int+  deriving Show Eq Generic++B+  a AId+  b String+  deriving Show Eq Generic++C+  a AId+  b BId+  c String+  deriving Show Eq Generic++D+  Id UUIDKey+  a Int+  b String+  deriving Show Eq Generic++E+  Id DId sqltype=uuid+  a String+  deriving Show Eq Generic++F+  a Bool+  UniqueFA a+  deriving Show Eq Generic+|]++instance Arbitrary A where+  arbitrary = A <$> arbitrary <*> arbitrary++instance Arbitrary B where+  arbitrary = B <$> arbitrary <*> arbitrary++instance Arbitrary C where+  arbitrary = C <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary D where+  arbitrary = D <$> arbitrary <*> arbitrary++instance Arbitrary E where+  arbitrary = E <$> arbitrary++instance Arbitrary F where+  arbitrary = F <$> arbitrary+```++## Dependencies++We declare dependencies via the `HasDependencies` typeclass and its associated type `Dependencies`.++By default a type does not have any dependencies. We only need to declare an empty instance.++```haskell+instance HasDependencies A+instance HasDependencies F+```++For single dependencies we use the `Only` type.++```haskell+instance HasDependencies B where+  type Dependencies B = Only AId+```++Groups of dependencies use tuples. Declare these dependencies in the order they appear in the type. `HasDependencies` leverages generic programming to inject dependencies for you.++```haskell+instance HasDependencies C where+  type Dependencies C = (AId, BId)+```++## Non Sequential Keys++Graphula supports non-sequential keys with the `KeySource` associated type. To generate a key using+its `Arbitrary` instance, use `'SourceArbitrary`. Non-serial keys will need to also derive+an overlapping `Arbitrary` instance.++```haskell+instance HasDependencies D where+  type KeySource D = 'SourceArbitrary++deriving newtype instance {-# OVERLAPPING #-} Arbitrary (Key D)+```++You can also elect to always specify an external key using `'SourceExternal`. This means that+this type cannot be constructed with `node`; use `nodeKeyed` instead.++```haskell+instance HasDependencies E where+  type KeySource E = 'SourceExternal+```++By default, `HasDependencies` instances use `type KeySource _ = 'SourceDefault`, which means+that graphula will expect the database to provide a key.++## Serialization++Graphula allows logging of graphs via `runGraphulaLogged`. Graphula dumps graphs+to a temp file on test failure.++```haskell+loggingSpec :: IO ()+loggingSpec = do+  let+    logFile :: FilePath+    logFile = "test.graphula"++    -- We'd typically use `runGraphulaLogged` which utilizes a temp file.+    failingGraph :: IO ()+    failingGraph = runGraphulaT Nothing runDB . runGraphulaLoggedWithFileT logFile $ do+      Entity _ a <- node @A () $ edit $ \n ->+        n {aA = "success"}+      liftIO $ aA a `shouldBe` "failed"++  failingGraph+    `shouldThrow` anyException++  n <- lines <$> readFile "test.graphula"+  n `shouldSatisfy` (not . null)+```++## Running It++```haskell+simpleSpec :: IO ()+simpleSpec =+  runGraphulaT Nothing runDB $ do+    -- Type application is not necessary, but recommended for clarity.+    Entity aId _ <- node @A () mempty+    Entity bId b <- node @B (only aId) mempty+    Entity _ c <- node @C (aId, bId) $ edit $ \n -> n { cC = "edited" }+    Entity dId _ <- node @D () mempty+    Entity eId _ <- nodeKeyed @E (EKey dId) () mempty++    -- Do something with your data+    liftIO $ do+      cC c `shouldBe` "edited"+      cA c `shouldBe` bA b+      unEKey eId `shouldBe` dId+```++`runGraphulaT` carries frontend instructions. If we'd like to override them we need to declare our own frontend.++For example, a front-end that always fails to insert.++```haskell+newtype GraphulaFailT m a = GraphulaFailT { runGraphulaFailT :: m a }+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadGraphulaBackend)++instance MonadGraphulaFrontend (GraphulaFailT m) where+  insert _ _ = pure Nothing+  remove = const (pure ())++insertionFailureSpec :: IO ()+insertionFailureSpec = do+  let+    failingGraph :: IO ()+    failingGraph =  runGraphulaT Nothing runDB . runGraphulaFailT $ do+      Entity _ _ <- node @A () mempty+      pure ()+  failingGraph+    `shouldThrow` (== (GenerationFailureMaxAttemptsToInsert (typeRep $ Proxy @A)))+```++Note that graphula can fail naturally if we define a graph that violates unique constraints+in the database:++```haskell+constraintFailureSpec :: IO ()+constraintFailureSpec = do+  let+    failingGraph :: IO ()+    failingGraph =  runGraphulaT Nothing runDB $+      replicateM_ 3 $ node @F () mempty+  failingGraph+    `shouldThrow` (== (GenerationFailureMaxAttemptsToInsert (typeRep $ Proxy @F)))+```++or if we define a graph with an unsatisfiable predicates:++```haskell+ensureFailureSpec :: IO ()+ensureFailureSpec = do+  let+    failingGraph :: IO ()+    failingGraph =  runGraphulaT Nothing runDB $ do+      Entity _ _ <- node @A () $ ensure $ \a -> a /= a+      pure ()+  failingGraph+    `shouldThrow` (== (GenerationFailureMaxAttemptsToConstrain (typeRep $ Proxy @A)))+```++<!--+```haskell+main :: IO ()+main = hspec $+  describe "graphula-core" . parallel $ do+    it "generates and links arbitrary graphs of data" simpleSpec+    it "allows logging graphs" loggingSpec+    it "attempts to retry node generation on insertion failure" insertionFailureSpec+    it "attempts to retry node generation on a database constraint violation" constraintFailureSpec+    it "attempts to retry node generation on unsatisfiable predicates" ensureFailureSpec++runDB :: MonadUnliftIO m => ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a+runDB f = runSqlite "test.db" $ do+  runMigration migrateAll+  f+```+-->

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ graphula-core.cabal view

@@ -0,0 +1,87 @@+cabal-version:      1.12+name:               graphula-core+version:            2.0.0.1+license:            MIT+license-file:       LICENSE+maintainer:         Freckle Education+homepage:           https://github.com/freckle/graphula#readme+bug-reports:        https://github.com/freckle/graphula/issues+synopsis:+    A declarative library for describing dependencies between data++description:        Please see README.md+category:           Network+build-type:         Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+    type:     git+    location: https://github.com/freckle/graphula++library+    exposed-modules:+        Graphula+        Graphula.Arbitrary+        Graphula.Internal+        Graphula.Key++    hs-source-dirs:   src+    other-modules:    Paths_graphula_core+    default-language: Haskell2010+    ghc-options:+        -Weverything -Wno-unsafe -Wno-safe -Wno-missing-import-lists+        -Wno-implicit-prelude++    build-depends:+        HUnit >=1.6.1.0 && <1.7,+        QuickCheck >=2.13.2 && <2.14,+        base >=4.13.0.0 && <4.14,+        containers >=0.6.2.1 && <0.7,+        directory >=1.3.6.0 && <1.4,+        generics-eot >=0.4.0.1 && <0.5,+        mtl >=2.2.2 && <2.3,+        persistent >=2.10.5.3 && <2.11,+        random ==1.1.*,+        semigroups >=0.19.1 && <0.20,+        temporary ==1.3.*,+        text >=1.2.4.0 && <1.3,+        transformers >=0.5.6.2 && <0.6,+        unliftio >=0.2.13.1 && <0.3,+        unliftio-core >=0.1.2.0 && <0.2++test-suite readme+    type:             exitcode-stdio-1.0+    main-is:          README.lhs+    hs-source-dirs:   test+    other-modules:+        Graphula.UUIDKey+        Paths_graphula_core++    default-language: Haskell2010+    ghc-options:+        -Weverything -Wno-unsafe -Wno-safe -Wno-missing-import-lists+        -Wno-implicit-prelude -pgmL markdown-unlit++    build-depends:+        QuickCheck >=2.13.2 && <2.14,+        aeson >=1.4.7.1 && <1.5,+        base >=4.13.0.0 && <4.14,+        bytestring >=0.10.10.1 && <0.11,+        containers >=0.6.2.1 && <0.7,+        graphula-core -any,+        hspec >=2.7.4 && <2.8,+        http-api-data >=0.4.1.1 && <0.5,+        markdown-unlit >=0.5.0 && <0.6,+        monad-logger >=0.3.35 && <0.4,+        path-pieces >=0.2.1 && <0.3,+        persistent >=2.10.5.3 && <2.11,+        persistent-sqlite >=2.10.6.2 && <2.11,+        persistent-template >=2.8.2.3 && <2.9,+        resourcet >=1.2.4.2 && <1.3,+        semigroups >=0.19.1 && <0.20,+        text >=1.2.4.0 && <1.3,+        transformers >=0.5.6.2 && <0.6,+        unliftio-core >=0.1.2.0 && <0.2,+        uuid >=1.3.13 && <1.4

+ src/Graphula.hs view

@@ -0,0 +1,558 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++-- |+--+-- Graphula is a compact interface for generating data and linking its+-- dependencies. You can use this interface to generate fixtures for automated+-- testing.+--+-- The interface is extensible and supports pluggable front-ends.+--+-- @+-- runGraphIdentity . runGraphulaT $ do+--   -- Compose dependencies at the value level+--   Identity vet <- node @Veterinarian () mempty+--   Identity owner <- node @Owner (only vet) mempty+--   -- TypeApplications is not necessary, but recommended for clarity.+--   Identity dog <- node @Dog (owner, vet) $ edit $ \d -> d { name = "fido" }+-- @+--+module Graphula+  ( -- * Graph Declaration+    node+  , nodeKeyed+  , GraphulaNode+  , GraphulaContext+    -- ** Node options+  , NodeOptions+  , edit+  , ensure+    -- * Declaring Dependencies and key source+  , HasDependencies(..)+  , KeySourceType(..)+    -- * Abstract over how keys are generated using 'SourceDefault' or+    -- 'SourceArbitrary'+  , GenerateKey+    -- ** Singular Dependencies+  , Only(..)+  , only+    -- * The Graph Monad+    -- ** Type Classes+  , MonadGraphula+  , MonadGraphulaBackend(..)+  , MonadGraphulaFrontend(..)+    -- ** Backends+  , runGraphulaT+  , GraphulaT+  , runGraphulaLoggedT+  , runGraphulaLoggedWithFileT+  , GraphulaLoggedT+    -- ** Frontends+  , runGraphulaIdempotentT+  , GraphulaIdempotentT+    -- * Extras+  , NoConstraint+    -- * Exceptions+  , GenerationFailure(..)+  )+where++import Prelude hiding (readFile)++import Control.Monad (guard, (<=<))+import Control.Monad.IO.Unlift+import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT)+import Control.Monad.Trans (MonadTrans, lift)+import Data.Foldable (for_, traverse_)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.Kind (Constraint, Type)+import Data.Proxy (Proxy(..))+import Data.Semigroup.Generic (gmappend, gmempty)+import Data.Sequence (Seq, empty, (|>))+import Data.Text (Text, pack)+import qualified Data.Text.IO as T+import Data.Traversable (for)+import Data.Typeable (TypeRep, Typeable, typeRep)+import Database.Persist+  ( Entity(..)+  , Key+  , PersistEntity+  , PersistEntityBackend+  , checkUnique+  , delete+  , entityKey+  , get+  , getEntity+  , insertKey+  , insertUnique+  )+import Database.Persist.Sql (SqlBackend)+import Generics.Eot (Eot, HasEot, fromEot, toEot)+import GHC.Generics (Generic)+import Graphula.Arbitrary (generate)+import Graphula.Internal+import System.Directory (createDirectoryIfMissing, getTemporaryDirectory)+import System.IO (Handle, IOMode(..), hClose, openFile)+import System.IO.Temp (openTempFile)+import System.Random (randomIO)+import Test.HUnit.Lang+  (FailureReason(..), HUnitFailure(..), formatFailureReason)+import Test.QuickCheck (Arbitrary(..))+import Test.QuickCheck.Random (QCGen, mkQCGen)+import UnliftIO.Exception+  (Exception, SomeException, bracket, catch, mask, throwIO)++type MonadGraphula m+  = (Monad m, MonadGraphulaBackend m, MonadGraphulaFrontend m, MonadIO m)++-- | A constraint over lists of nodes for 'MonadGraphula', and 'GraphulaNode'.+--+-- Helpful for defining utility functions over many nodes.+--+-- @+-- mkABC :: (GraphulaContext m '[A, B, C]) => m (Node m C)+-- mkABC = do+--   a <- node @A () mempty+--   b <- node @B (only a) mempty+--   node @C (a, b) $ edit $ \n ->+--     n { cc = "spanish" }+-- @+--+type family GraphulaContext (m :: Type -> Type) (ts :: [Type]) :: Constraint where+   GraphulaContext m '[] = MonadGraphula m+   GraphulaContext m (t ': ts) = (GraphulaNode m t, GraphulaContext m ts)++class MonadGraphulaFrontend m where+  insert+    :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m)+    => Maybe (Key a) -> a -> m (Maybe (Entity a))+  remove :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m) => Key a -> m ()++data Args backend n m = Args+  { dbRunner :: RunDB backend n m+  , gen :: IORef QCGen+  }++newtype RunDB backend n m = RunDB (forall b. ReaderT backend n b -> m b)++newtype GraphulaT n m a =+  GraphulaT { runGraphulaT' :: ReaderT (Args SqlBackend n m) m a }+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (Args SqlBackend n m))++instance MonadTrans (GraphulaT n) where+  lift = GraphulaT . lift++instance MonadUnliftIO m => MonadUnliftIO (GraphulaT n m) where+  {-# INLINE askUnliftIO #-}+  askUnliftIO = GraphulaT $ withUnliftIO $ \u ->+    return $ UnliftIO $ unliftIO u . runGraphulaT'+  {-# INLINE withRunInIO #-}+  withRunInIO inner =+    GraphulaT $ withRunInIO $ \run -> inner $ run . runGraphulaT'++instance MonadIO m => MonadGraphulaBackend (GraphulaT n m) where+  type Logging (GraphulaT n m) = NoConstraint+  askGen = asks gen+  logNode _ = pure ()++instance (MonadIO m, Applicative n, MonadIO n) => MonadGraphulaFrontend (GraphulaT n m) where+  insert mKey n = do+    RunDB runDB <- asks dbRunner+    lift . runDB $ case mKey of+      Nothing -> insertUnique n >>= \case+        Nothing -> pure Nothing+        Just key -> getEntity key+      Just key -> do+        existingKey <- get key+        whenNothing existingKey $ do+          existingUnique <- checkUnique n+          whenNothing existingUnique $ do+            insertKey key n+            getEntity key++  remove key = do+    RunDB runDB <- asks dbRunner+    lift . runDB $ delete key++whenNothing :: Applicative m => Maybe a -> m (Maybe b) -> m (Maybe b)+whenNothing Nothing f = f+whenNothing (Just _) _ = pure Nothing++runGraphulaT+  :: (MonadUnliftIO m)+  => Maybe Int -- ^ Optional seed+  -> (forall b . ReaderT SqlBackend n b -> m b) -- ^ Database runner+  -> GraphulaT n m a+  -> m a+runGraphulaT mSeed runDB action = do+  seed <- maybe (liftIO randomIO) pure mSeed+  qcGen <- liftIO $ newIORef $ mkQCGen seed+  runReaderT (runGraphulaT' action) (Args (RunDB runDB) qcGen)+    `catch` logFailingSeed seed++logFailingSeed :: MonadIO m => Int -> HUnitFailure -> m a+logFailingSeed seed = rethrowHUnitWith ("Graphula with seed: " ++ show seed)++newtype GraphulaIdempotentT m a =+  GraphulaIdempotentT {runGraphulaIdempotentT' :: ReaderT (IORef (m ())) m a}+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (IORef (m ())))++instance MonadUnliftIO m => MonadUnliftIO (GraphulaIdempotentT m) where+  {-# INLINE askUnliftIO #-}+  askUnliftIO = GraphulaIdempotentT $ withUnliftIO $ \u ->+    return $ UnliftIO $ unliftIO u . runGraphulaIdempotentT'+  {-# INLINE withRunInIO #-}+  withRunInIO inner = GraphulaIdempotentT $ withRunInIO $ \run ->+    inner $ run . runGraphulaIdempotentT'++instance MonadTrans GraphulaIdempotentT where+  lift = GraphulaIdempotentT . lift++instance (MonadIO m, MonadGraphulaFrontend m) => MonadGraphulaFrontend (GraphulaIdempotentT m) where+  insert mKey n = do+    finalizersRef <- ask+    mEnt <- lift $ insert mKey n+    for_ (entityKey <$> mEnt)+      $ \key -> liftIO $ modifyIORef' finalizersRef (remove key >>)+    pure mEnt+  remove = lift . remove++-- | A wrapper around a graphula frontend that produces finalizers to remove+-- graph nodes on error or completion. An idempotent graph produces no data+-- outside of its own closure.+--+-- @+-- runGraphIdentity . runGraphulaIdempotentT . runGraphulaT $ do+--   node @PancakeBreakfast () mempty+-- @+--+runGraphulaIdempotentT :: (MonadUnliftIO m) => GraphulaIdempotentT m a -> m a+runGraphulaIdempotentT action = mask $ \unmasked -> do+  finalizersRef <- liftIO . newIORef $ pure ()+  x <-+    unmasked+    $ runReaderT (runGraphulaIdempotentT' action) finalizersRef+    `catch` rollbackRethrow finalizersRef+  rollback finalizersRef $ pure x+ where+  rollback :: MonadIO m => IORef (m a) -> m b -> m b+  rollback finalizersRef x = do+    finalizers <- liftIO $ readIORef finalizersRef+    finalizers >> x++  rollbackRethrow :: MonadIO m => IORef (m a) -> SomeException -> m b+  rollbackRethrow finalizersRef (e :: SomeException) =+    rollback finalizersRef (throwIO e)++newtype GraphulaLoggedT m a =+  GraphulaLoggedT {runGraphulaLoggedT' :: ReaderT (IORef (Seq Text)) m a}+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (IORef (Seq Text)))++instance MonadTrans GraphulaLoggedT where+  lift = GraphulaLoggedT . lift++instance (MonadGraphulaBackend m, MonadIO m) => MonadGraphulaBackend (GraphulaLoggedT m) where+  type Logging (GraphulaLoggedT m) = Show+  askGen = lift askGen+  logNode n = do+    graphLog <- ask+    liftIO $ modifyIORef' graphLog (|> pack (show n))++instance (Monad m, MonadGraphulaFrontend m) => MonadGraphulaFrontend (GraphulaLoggedT m) where+  insert mKey = lift . insert mKey+  remove = lift . remove++-- | An extension of 'runGraphulaT' that logs all nodes to a temporary file on+-- 'Exception' and re-throws the 'Exception'.+runGraphulaLoggedT :: MonadUnliftIO m => GraphulaLoggedT m a -> m a+runGraphulaLoggedT = runGraphulaLoggedUsingT logFailTemp++-- | A variant of 'runGraphulaLoggedT' that accepts a file path to logged to+-- instead of utilizing a temp file.+runGraphulaLoggedWithFileT+  :: MonadUnliftIO m => FilePath -> GraphulaLoggedT m a -> m a+runGraphulaLoggedWithFileT = runGraphulaLoggedUsingT . logFailFile++runGraphulaLoggedUsingT+  :: MonadUnliftIO m+  => (IORef (Seq Text) -> HUnitFailure -> m a)+  -> GraphulaLoggedT m a+  -> m a+runGraphulaLoggedUsingT logFail action = do+  graphLog <- liftIO $ newIORef empty+  runReaderT (runGraphulaLoggedT' action) graphLog `catch` logFail graphLog++logFailUsing+  :: MonadIO m+  => IO (FilePath, Handle)+  -> IORef (Seq Text)+  -> HUnitFailure+  -> m a+logFailUsing f graphLog hunitfailure =+  flip rethrowHUnitLogged hunitfailure =<< logGraphToHandle graphLog f++logFailFile :: MonadIO m => FilePath -> IORef (Seq Text) -> HUnitFailure -> m a+logFailFile path = logFailUsing ((path, ) <$> openFile path WriteMode)++logFailTemp :: MonadIO m => IORef (Seq Text) -> HUnitFailure -> m a+logFailTemp = logFailUsing $ do+  tmp <- (++ "/graphula") <$> getTemporaryDirectory+  createDirectoryIfMissing True tmp+  openTempFile tmp "fail-.graphula"++logGraphToHandle+  :: (MonadIO m) => IORef (Seq Text) -> IO (FilePath, Handle) -> m FilePath+logGraphToHandle graphLog openHandle = liftIO $ bracket+  openHandle+  (hClose . snd)+  (\(path, handle) -> do+    nodes <- readIORef graphLog+    path <$ traverse_ (T.hPutStrLn handle) nodes+  )++rethrowHUnitWith :: MonadIO m => String -> HUnitFailure -> m a+rethrowHUnitWith message (HUnitFailure l r) =+  throwIO . HUnitFailure l . Reason $ message ++ "\n\n" ++ formatFailureReason r++rethrowHUnitLogged :: MonadIO m => FilePath -> HUnitFailure -> m a+rethrowHUnitLogged path =+  rethrowHUnitWith ("Graph dumped in temp file: " ++ path)++class HasDependencies a where+  -- | A data type that contains values to be injected into @a@ via+  -- `dependsOn`. The default generic implementation of `dependsOn` supports+  -- tuples as 'Dependencies'. Data types with a single dependency should use+  -- 'Only' as a 1-tuple.+  --+  -- note: The contents of a tuple must be ordered as they appear in the+  -- definition of @a@.+  type Dependencies a+  type instance Dependencies a = ()++  -- | Specify the method for resolving a node's key+  --+  -- This can be+  --+  -- @+  -- 'SourceDefault   -- automatically generate keys from the database+  -- 'SourceArbitrary -- automatically generate keys using @'Arbitrary'@+  -- 'SourceExternal  -- explicitly pass a key using @'nodeKeyed'@+  -- @+  --+  -- Most types will use @'SourceDefault'@ or @'SourceArbitrary'@. Only+  -- use @'SourceExternal'@ if the key for a value is always defined+  -- externally.+  --+  type KeySource a :: KeySourceType+  type instance KeySource a = 'SourceDefault++  -- | Assign values from the 'Dependencies' collection to a value.+  -- 'dependsOn' must be an idempotent operation.+  --+  -- Law:+  --+  -- prop> (\x d -> x `dependsOn` d `dependsOn` d) = dependsOn+  dependsOn :: a -> Dependencies a -> a+  default dependsOn+    ::+      ( HasEot a+      , HasEot (Dependencies a)+      , GHasDependencies (Proxy a) (Proxy (Dependencies a)) (Eot a) (Eot (Dependencies a))+      )+    => a -> Dependencies a -> a+  dependsOn a dependencies =+    fromEot $+      genericDependsOn+        (Proxy :: Proxy a)+        (Proxy :: Proxy (Dependencies a))+        (toEot a)+        (toEot dependencies)++-- | Abstract over how keys are generated using @'SourceDefault'@ or @'SourceArbitrary'@+class (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a) => GenerateKey a+instance (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a) => GenerateKey a++data GenerationFailure+  = GenerationFailureMaxAttemptsToConstrain TypeRep+  -- ^ Could not satisfy constraints defined using @'ensure'@+  | GenerationFailureMaxAttemptsToInsert TypeRep+  -- ^ Could not satisfy database constraints on insert+  deriving stock (Show, Eq)++instance Exception GenerationFailure++type GraphulaNode m a+  = ( HasDependencies a+    , Logging m a+    , PersistEntityBackend a ~ SqlBackend+    , PersistEntity a+    , Typeable a+    , Arbitrary a+    )++{-|+  Generate a value with data dependencies. This leverages+  'HasDependencies' to insert the specified data in the generated value. All+  dependency data is inserted after any editing operations.++  > node @Dog (ownerId, veterinarianId) mempty+  > node @Dog (ownerId, veterinarianId) $ edit $ \dog ->+  >   dog {name = "fido"}++  A value that has an externally managed key must use @'nodeKeyed'@ instead.+-}+node+  :: forall a m+   . (GraphulaContext m '[a], GenerateKey a)+  => Dependencies a+  -> NodeOptions a+  -> m (Entity a)+node = nodeImpl $ generate $ generateKey @(KeySource a) @a++{-|+  Generate a value with data dependencies given an externally managed+  key. This leverages 'HasDependencies' to insert the specified data+  in the generated value. All dependency data is inserted after any+  editing operations.++  > someKey <- generateKey+  > node @Cat someKey (ownerId, veterinarianId) mempty+  > anotherKey <- generateKey+  > node @Cat anotherKey (ownerId, veterinarianId) $ edit $ \cat ->+  >   cat {name = "milo"}++  A value that has an automatically managed key may use @'node'@ instead.+-}+nodeKeyed+  :: forall a m+   . GraphulaContext m '[a]+  => Key a+  -> Dependencies a+  -> NodeOptions a+  -> m (Entity a)+nodeKeyed key = nodeImpl $ pure $ Just key++nodeImpl+  :: forall a m+   . GraphulaContext m '[a]+  => m (Maybe (Key a))+  -> Dependencies a+  -> NodeOptions a+  -> m (Entity a)+nodeImpl genKey dependencies NodeOptions {..} = attempt 100 10 $ do+  initial <- generate arbitrary+  for (appKendo nodeOptionsEdit initial) $ \edited -> do+    let hydrated = edited `dependsOn` dependencies+    logNode hydrated+    mKey <- genKey+    pure (mKey, hydrated)++-- | Modify the node after it's been generated+--+-- @+-- a <- node @A () $ edit $ \a -> a { someField = True }+-- @+--+edit :: (a -> a) -> NodeOptions a+edit f = mempty { nodeOptionsEdit = Kendo $ Just . f }++-- | Require a node to satisfy the specified predicate+--+-- @+-- a <- node @A () $ ensure $ (== True) . someField+-- @+--+ensure :: (a -> Bool) -> NodeOptions a+ensure f = mempty { nodeOptionsEdit = Kendo $ \a -> a <$ guard (f a) }++-- | Options for generating an individual node+--+-- @'NodeOptions'@ can be created and combined with the Monoidal+-- operations @'(<>)'@ and @'mempty'@.+--+-- @+-- a1 <- node @A () mempty+-- a2 <- node @A () $ edit $ \a -> a { someField = True }+-- a3 <- node @A () $ ensure $ (== True) . someField+-- @+--+newtype NodeOptions a = NodeOptions+  { nodeOptionsEdit :: Kendo Maybe a+  }+  deriving stock Generic++instance Semigroup (NodeOptions a) where+  (<>) = gmappend+  {-# INLINE (<>) #-}++instance Monoid (NodeOptions a) where+  mempty = gmempty+  {-# INLINE mempty #-}++-- | Like @'Endo'@ but uses Kliesli composition+newtype Kendo m a = Kendo { appKendo :: a -> m a }+    deriving stock Generic++instance Monad m => Semigroup (Kendo m a) where+  Kendo f <> Kendo g = Kendo $ f <=< g+  {-# INLINE (<>) #-}++instance Monad m => Monoid (Kendo m a) where+  mempty = Kendo pure+  {-# INLINE mempty #-}++attempt+  :: forall a m+   . (GraphulaContext m '[a])+  => Int+  -> Int+  -> m (Maybe (Maybe (Key a), a))+  -> m (Entity a)+attempt maxEdits maxInserts source = loop 0 0+ where+  loop :: Int -> Int -> m (Entity a)+  loop numEdits numInserts+    | numEdits >= maxEdits = die GenerationFailureMaxAttemptsToConstrain+    | numInserts >= maxInserts = die GenerationFailureMaxAttemptsToInsert+    | otherwise = source >>= \case+      Nothing -> loop (succ numEdits) numInserts+      --               ^ failed to edit, only increments this+      Just (mKey, value) -> insert mKey value >>= \case+        Nothing -> loop (succ numEdits) (succ numInserts)+        --               ^ failed to insert, but also increments this+        Just a -> pure a++  die :: (TypeRep -> GenerationFailure) -> m (Entity a)+  die e = throwIO $ e $ typeRep (Proxy :: Proxy a)++-- | For entities that only have singular 'Dependencies'+newtype Only a = Only { fromOnly :: a }+  deriving stock (Eq, Show, Ord, Generic, Functor, Foldable, Traversable)++only :: a -> Only a+only = Only

+ src/Graphula/Arbitrary.hs view

@@ -0,0 +1,34 @@+{-|+  Graphula tracks its own 'QCGen' for deterministic generation with 'Arbitrary'+  and 'Gen'. 'generate' can be used to produce arbitrary values utilizing+  graphula's generation.+-}+module Graphula.Arbitrary+  ( generate+  )+where++import Prelude++import Control.Monad.IO.Unlift (MonadIO, liftIO)+import Data.IORef (readIORef, writeIORef)+import Graphula.Internal (MonadGraphulaBackend, askGen)+import System.Random (split)+import Test.QuickCheck (Gen)+import Test.QuickCheck.Gen (unGen)++-- | Run a generator+--+-- This is akin to 'Test.QuickCheck.generate', but utilizing graphula's+-- generation. The size passed to the generator is always 30; if you want+-- another size then you should explicitly use 'Test.QuickCheck.resize'.+--+generate :: (MonadIO m, MonadGraphulaBackend m) => Gen a -> m a+generate gen = do+  genRef <- askGen+  g <- liftIO $ readIORef genRef+  let+    (g1, g2) = split g+    x = unGen gen g1 30+  liftIO $ writeIORef genRef g2+  pure x

+ src/Graphula/Internal.hs view

@@ -0,0 +1,237 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Graphula.Internal+  ( MonadGraphulaBackend(..)+  , GHasDependencies(..)+  , KeySourceType(..)+  , GenerateKeyInternal(..)+  , NoConstraint+  )+where++import Data.IORef (IORef)+import Data.Kind (Constraint, Type)+import Database.Persist (Key)+import Generics.Eot (Proxy(..), Void)+import GHC.TypeLits (ErrorMessage(..), TypeError)+import Test.QuickCheck (Arbitrary(..), Gen)+import Test.QuickCheck.Random (QCGen)++class MonadGraphulaBackend m where+  type Logging m :: Type -> Constraint+  -- ^ A constraint provided to log details of the graph to some form of+  --   persistence. This is used by 'runGraphulaLogged' to store graph nodes as+  --   'Show'n 'Text' values+  askGen :: m (IORef QCGen)+  logNode :: Logging m a => a -> m ()++data Match t+  = NoMatch t+  | Match t++type family DependenciesTypeInstance nodeTy depsTy where+  DependenciesTypeInstance nodeTy depsTy =+    'Text "‘type Dependencies " ':<>: 'ShowType nodeTy ':<>:+    'Text " = " ':<>: 'ShowType depsTy ':<>: 'Text "’"++-- Walk through the fields of our node and match them up with fields from the dependencies.+type family FindMatches nodeTy depsTy as ds :: [Match Type] where+  -- Excess dependencies+  FindMatches nodeTy depsTy () (d, _ds) =+    TypeError+      ( 'Text "Excess dependency ‘" ':<>: 'ShowType d ':<>:+        'Text "’ in " ':$$: DependenciesTypeInstance nodeTy depsTy ':$$:+        'Text "Ordering of dependencies must match their occurrence in the target type ‘" ':<>:+        'ShowType nodeTy ':<>: 'Text "’"+      )++  -- No more fields or dependencies left+  FindMatches _nodeTy _depsTy () () = '[]++  -- Fields left, but no more dependencies+  FindMatches nodeTy depsTy (a, as) () = 'NoMatch a ': FindMatches nodeTy depsTy as ()++  -- Field matches dependency, keep going+  FindMatches nodeTy depsTy (a, as) (a, ds) = 'Match a ': FindMatches nodeTy depsTy as ds++  -- Field does not match dependency, keep going+  FindMatches nodeTy depsTy (a, as) (d, ds) = 'NoMatch a ': FindMatches nodeTy depsTy as (d, ds)++class GHasDependencies nodeTyProxy depsTyProxy node deps where+  genericDependsOn :: nodeTyProxy -> depsTyProxy -> node -> deps -> node++class GHasDependenciesRecursive fieldsProxy node deps where+  genericDependsOnRecursive :: fieldsProxy -> node -> deps -> node++-- This instance head only matches EoT representations of+-- datatypes with no constructors and no dependencies+instance {-# OVERLAPPING #-} GHasDependencies (Proxy nodeTy) (Proxy depsTy) Void (Either () Void) where+  genericDependsOn _ _ node _ = node++-- This instance warns the user if they give dependencies+-- to a datatype with no constructors+instance+  {-# OVERLAPPABLE #-}+  ( TypeError+    ( 'Text "A datatype with no constructors can't use the dependencies in" ':$$:+      DependenciesTypeInstance nodeTy depsTy+    )+  ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) Void (Either deps rest) where+  genericDependsOn _ _ _ _ = error "Impossible"++-- This instance head only matches EoT representations of+-- datatypes with a single constructor+instance+  ( FindMatches nodeTy depsTy node deps ~ fields+  , GHasDependenciesRecursive (Proxy fields) node deps+  ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either node Void) (Either deps Void) where+  genericDependsOn _ _ (Left node) (Left deps) =+    Left (genericDependsOnRecursive (Proxy :: Proxy fields) node deps)+  genericDependsOn _ _ _ _ = error "Impossible" -- EoT never generates an actual `Right (x :: Void)` here++-- This instance matches a sum type as both node and dependencies.+-- We use this to report an error to the user.+instance+  ( TypeError+    ( 'Text "Cannot automatically find dependencies for sum type in" ':$$:+      DependenciesTypeInstance nodeTy depsTy+    )+  ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either left (Either right rest)) (Either deps Void) where+  genericDependsOn _ _ _ _ = error "Impossible"++-- This instance matches a sum type as the node.+-- This is also an error.+instance+  ( TypeError+    ( 'Text "Cannot automatically use a sum type as dependencies in" ':$$:+      DependenciesTypeInstance nodeTy depsTy+    )+  ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either node Void) (Either left (Either right rest)) where+  genericDependsOn _ _ _ _ = error "Impossible"++-- This instance matches a sum type as the dependencies.+-- This is also an error.+instance+  ( TypeError+    ( 'Text "Cannot automatically find dependencies for sum type or use a sum type as a dependency in" ':$$:+      DependenciesTypeInstance nodeTy depsTy+    )+  ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either left1 (Either right1 rest1)) (Either left2 (Either right2 rest2)) where+  genericDependsOn _ _ _ _ = error "Impossible"++-- Don't let the user specify `Void` as a dependency+instance+  ( TypeError+    ( 'Text "Use ‘()’ instead of ‘Void’ for datatypes with no dependencies in" ':$$:+      DependenciesTypeInstance nodeTy depsTy+    )+  ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) node Void where+  genericDependsOn _ _ _ _ = error "Impossible"++instance+  ( a ~ dep+  , GHasDependenciesRecursive (Proxy fields) as deps+  ) => GHasDependenciesRecursive (Proxy ('Match a ': fields)) (a, as) (dep, deps) where+  genericDependsOnRecursive _ (_, as) (dep, deps) =+    (dep, genericDependsOnRecursive (Proxy :: Proxy fields) as deps)++instance+  ( GHasDependenciesRecursive (Proxy fields) as deps+  ) => GHasDependenciesRecursive (Proxy ('NoMatch a ': fields)) (a, as) deps where+  genericDependsOnRecursive _ (a, as) deps =+    (a, genericDependsOnRecursive (Proxy :: Proxy fields) as deps)++-- Without the kind-signature for '[], ghc will fail to find this+-- instance for nullary constructors+instance GHasDependenciesRecursive (Proxy ('[] :: [Match Type])) () () where+  genericDependsOnRecursive _ _ _ = ()++data KeySourceType+  = SourceDefault+  -- ^ Generate keys using the database's @DEFAULT@ strategy+  | SourceArbitrary+  -- ^ Generate keys using the @'Arbitrary'@ instance for the @'Key'@+  | SourceExternal+  -- ^ Always explicitly pass an external key++-- | Handle key generation for @'SourceDefault'@ and @'SourceArbitrary'@+--+-- Ths could be a single-parameter class, but carrying the @a@ around+-- lets us give a better error message when @'node'@ is called instead+-- of @'nodeKeyed'@.+--+class GenerateKeyInternal (s :: KeySourceType) a where+  type KeyConstraint s a :: Constraint+  generateKey :: KeyConstraint s a => Gen (Maybe (Key a))++instance GenerateKeyInternal 'SourceDefault a where+  type KeyConstraint 'SourceDefault a = NoConstraint a+  generateKey = pure Nothing++instance GenerateKeyInternal 'SourceArbitrary a where+  type KeyConstraint 'SourceArbitrary a = Arbitrary (Key a)+  generateKey = Just <$> arbitrary++-- | Explicit instance for @'SourceExternal'@ to give an actionable error message+--+-- Rendered:+--+-- @+-- Cannot generate a value of type ‘X’ using ‘node’ since+--+--   instance HasDependencies X where+--     type KeySource X = 'SourceExternal+--+-- Possible fixes include:+-- • Use ‘nodeKeyed’ instead of ‘node’+-- • Change ‘KeySource X’ to 'SourceDefault or 'SourceArbitrary+-- @+--+instance TypeError+  ( 'Text "Cannot generate a value of type "+    ':<>: Quote ('ShowType a)+    ':<>: 'Text " using "+    ':<>: Quote ('Text "node")+    ':<>: 'Text " since"+    ':$$: 'Text ""+    ':$$: 'Text "  instance HasDependencies "+    ':<>: 'ShowType a+    ':<>: 'Text " where"+    ':$$: 'Text "    "+    ':<>: 'Text "type KeySource "+    ':<>: 'ShowType a+    ':<>: 'Text  " = "+    ':<>: 'ShowType 'SourceExternal+    ':$$: 'Text ""+    ':$$: 'Text "Possible fixes include:"+    ':$$: 'Text "• Use "+    ':<>: Quote ('Text "nodeKeyed")+    ':<>: 'Text " instead of "+    ':<>: Quote ('Text "node")+    ':$$: 'Text "• Change "+    ':<>: Quote ('Text "KeySource " ':<>: 'ShowType a)+    ':<>: 'Text " to "+    ':<>: 'Text "'SourceDefault"+    ':<>: 'Text " or "+    ':<>: 'Text "'SourceArbitrary"+  ) => GenerateKeyInternal 'SourceExternal a where+  type KeyConstraint 'SourceExternal a = NoConstraint a+  generateKey = error "unreachable"++type family Quote t where+  Quote t = 'Text "‘" ':<>: t ':<>: 'Text "’"++-- | Graphula accepts constraints for various uses. Frontends do not always+-- utilize these constraints. 'NoConstraint' is a universal class that all+-- types inhabit. It has no behavior and no additional constraints.+class NoConstraint a+instance NoConstraint a

+ src/Graphula/Key.hs view

@@ -0,0 +1,55 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Graphula.Key+  ( onlyKey+  , keys+  , Keys+  )+where++import Database.Persist+import GHC.TypeLits (ErrorMessage(..), TypeError)+import Graphula (Only(..), only)++class EntityKeys a where+  type Keys a+  keys :: a -> Keys a++instance+  ( TypeError+    ( 'Text "Cannot use naked ‘" ':<>: 'ShowType (Entity a) ':<>:+      'Text "’ as argument to ‘keys’." ':$$:+      'Text "Did you mean ‘Only (" ':<>:+      'ShowType (Entity a) ':<>: 'Text ")’?"+    )+  ) => EntityKeys (Entity a) where+  type Keys (Entity a) = Key a+  keys = entityKey++onlyKey :: Entity a -> Only (Key a)+onlyKey = keys . only++instance EntityKeys (Only (Entity a)) where+  type Keys (Only (Entity a)) = Only (Key a)+  keys (Only a) = Only (entityKey a)++instance EntityKeys (Entity a, Entity b) where+  type Keys (Entity a, Entity b) = (Key a, Key b)+  keys (a, b) = (entityKey a, entityKey b)++instance EntityKeys (Entity a, Entity b, Entity c) where+  type Keys (Entity a, Entity b, Entity c) = (Key a, Key b, Key c)+  keys (a, b, c) = (entityKey a, entityKey b, entityKey c)++-- For some reason, this definition (but no others) triggers+--+--   ERROR: brittany pretty printer returned syntactically invalid result.+--+-- brittany-disable-next-binding++instance EntityKeys (Entity a, Entity b, Entity c, Entity d) where+  type Keys (Entity a, Entity b, Entity c, Entity d) = (Key a, Key b, Key c, Key d)+  keys (a, b, c, d) = (entityKey a, entityKey b, entityKey c, entityKey d)

+ test/Graphula/UUIDKey.hs view

@@ -0,0 +1,47 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Graphula.UUIDKey+  ( UUIDKey+  )+where++import Prelude++import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Text as Text+import Data.UUID (UUID)+import qualified Data.UUID as UUID+import Database.Persist+import Database.Persist.Sql+import Test.QuickCheck (Arbitrary(..), Gen, getLarge)+import Web.HttpApiData (FromHttpApiData, ToHttpApiData)+import Web.PathPieces (PathPiece(..))++-- | Example non-serial key+newtype UUIDKey = UUIDKey { unUUIDKey :: UUID }+  deriving newtype (Eq, Show, Ord, Read, FromJSON, ToJSON, ToHttpApiData, FromHttpApiData)++instance Arbitrary UUIDKey where+  arbitrary = UUIDKey <$> uuid+    where uuid = UUID.fromWords <$> large <*> large <*> large <*> large++large :: (Integral a, Bounded a) => Gen a+large = getLarge <$> arbitrary++instance PathPiece UUIDKey where+  toPathPiece = Text.pack . UUID.toString . unUUIDKey+  fromPathPiece = fmap UUIDKey . UUID.fromString . Text.unpack++instance PersistField UUIDKey where+  toPersistValue = PersistText . Text.pack . UUID.toString . unUUIDKey+  fromPersistValue = \case+    PersistText t -> case UUID.fromString $ Text.unpack t of+      Just x -> Right $ UUIDKey x+      Nothing -> Left "Invalid UUID"+    _ -> Left "Not PersistText"++instance PersistFieldSql UUIDKey where+  sqlType _ = SqlOther "uuid"

+ test/README.lhs view

@@ -0,0 +1,267 @@+# Graphula Core++Graphula is a simple interface for generating persistent data and linking its dependencies. We use this interface to generate fixtures for automated testing. The interface is extensible and supports pluggable front-ends.+++<!--+```haskell+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-deriving-strategies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main (module Main) where++import Control.Monad (replicateM_)+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger (NoLoggingT)+import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Trans.Resource (ResourceT)+import Database.Persist.Sqlite+import Database.Persist.TH+import Data.Typeable+import GHC.Generics (Generic)+import Graphula+import Graphula.UUIDKey+import Test.Hspec+import Test.QuickCheck++instance (ToBackendKey SqlBackend a) => Arbitrary (Key a) where+  arbitrary = toSqlKey <$> arbitrary+```+-->++## Arbitrary Data++Graphula utilizes `QuickCheck` to generate random data. We need to declare `Arbitrary` instances for our types.++```haskell+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+A+  a String+  b Int+  deriving Show Eq Generic++B+  a AId+  b String+  deriving Show Eq Generic++C+  a AId+  b BId+  c String+  deriving Show Eq Generic++D+  Id UUIDKey+  a Int+  b String+  deriving Show Eq Generic++E+  Id DId sqltype=uuid+  a String+  deriving Show Eq Generic++F+  a Bool+  UniqueFA a+  deriving Show Eq Generic+|]++instance Arbitrary A where+  arbitrary = A <$> arbitrary <*> arbitrary++instance Arbitrary B where+  arbitrary = B <$> arbitrary <*> arbitrary++instance Arbitrary C where+  arbitrary = C <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary D where+  arbitrary = D <$> arbitrary <*> arbitrary++instance Arbitrary E where+  arbitrary = E <$> arbitrary++instance Arbitrary F where+  arbitrary = F <$> arbitrary+```++## Dependencies++We declare dependencies via the `HasDependencies` typeclass and its associated type `Dependencies`.++By default a type does not have any dependencies. We only need to declare an empty instance.++```haskell+instance HasDependencies A+instance HasDependencies F+```++For single dependencies we use the `Only` type.++```haskell+instance HasDependencies B where+  type Dependencies B = Only AId+```++Groups of dependencies use tuples. Declare these dependencies in the order they appear in the type. `HasDependencies` leverages generic programming to inject dependencies for you.++```haskell+instance HasDependencies C where+  type Dependencies C = (AId, BId)+```++## Non Sequential Keys++Graphula supports non-sequential keys with the `KeySource` associated type. To generate a key using+its `Arbitrary` instance, use `'SourceArbitrary`. Non-serial keys will need to also derive+an overlapping `Arbitrary` instance.++```haskell+instance HasDependencies D where+  type KeySource D = 'SourceArbitrary++deriving newtype instance {-# OVERLAPPING #-} Arbitrary (Key D)+```++You can also elect to always specify an external key using `'SourceExternal`. This means that+this type cannot be constructed with `node`; use `nodeKeyed` instead.++```haskell+instance HasDependencies E where+  type KeySource E = 'SourceExternal+```++By default, `HasDependencies` instances use `type KeySource _ = 'SourceDefault`, which means+that graphula will expect the database to provide a key.++## Serialization++Graphula allows logging of graphs via `runGraphulaLogged`. Graphula dumps graphs+to a temp file on test failure.++```haskell+loggingSpec :: IO ()+loggingSpec = do+  let+    logFile :: FilePath+    logFile = "test.graphula"++    -- We'd typically use `runGraphulaLogged` which utilizes a temp file.+    failingGraph :: IO ()+    failingGraph = runGraphulaT Nothing runDB . runGraphulaLoggedWithFileT logFile $ do+      Entity _ a <- node @A () $ edit $ \n ->+        n {aA = "success"}+      liftIO $ aA a `shouldBe` "failed"++  failingGraph+    `shouldThrow` anyException++  n <- lines <$> readFile "test.graphula"+  n `shouldSatisfy` (not . null)+```++## Running It++```haskell+simpleSpec :: IO ()+simpleSpec =+  runGraphulaT Nothing runDB $ do+    -- Type application is not necessary, but recommended for clarity.+    Entity aId _ <- node @A () mempty+    Entity bId b <- node @B (only aId) mempty+    Entity _ c <- node @C (aId, bId) $ edit $ \n -> n { cC = "edited" }+    Entity dId _ <- node @D () mempty+    Entity eId _ <- nodeKeyed @E (EKey dId) () mempty++    -- Do something with your data+    liftIO $ do+      cC c `shouldBe` "edited"+      cA c `shouldBe` bA b+      unEKey eId `shouldBe` dId+```++`runGraphulaT` carries frontend instructions. If we'd like to override them we need to declare our own frontend.++For example, a front-end that always fails to insert.++```haskell+newtype GraphulaFailT m a = GraphulaFailT { runGraphulaFailT :: m a }+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadGraphulaBackend)++instance MonadGraphulaFrontend (GraphulaFailT m) where+  insert _ _ = pure Nothing+  remove = const (pure ())++insertionFailureSpec :: IO ()+insertionFailureSpec = do+  let+    failingGraph :: IO ()+    failingGraph =  runGraphulaT Nothing runDB . runGraphulaFailT $ do+      Entity _ _ <- node @A () mempty+      pure ()+  failingGraph+    `shouldThrow` (== (GenerationFailureMaxAttemptsToInsert (typeRep $ Proxy @A)))+```++Note that graphula can fail naturally if we define a graph that violates unique constraints+in the database:++```haskell+constraintFailureSpec :: IO ()+constraintFailureSpec = do+  let+    failingGraph :: IO ()+    failingGraph =  runGraphulaT Nothing runDB $+      replicateM_ 3 $ node @F () mempty+  failingGraph+    `shouldThrow` (== (GenerationFailureMaxAttemptsToInsert (typeRep $ Proxy @F)))+```++or if we define a graph with an unsatisfiable predicates:++```haskell+ensureFailureSpec :: IO ()+ensureFailureSpec = do+  let+    failingGraph :: IO ()+    failingGraph =  runGraphulaT Nothing runDB $ do+      Entity _ _ <- node @A () $ ensure $ \a -> a /= a+      pure ()+  failingGraph+    `shouldThrow` (== (GenerationFailureMaxAttemptsToConstrain (typeRep $ Proxy @A)))+```++<!--+```haskell+main :: IO ()+main = hspec $+  describe "graphula-core" . parallel $ do+    it "generates and links arbitrary graphs of data" simpleSpec+    it "allows logging graphs" loggingSpec+    it "attempts to retry node generation on insertion failure" insertionFailureSpec+    it "attempts to retry node generation on a database constraint violation" constraintFailureSpec+    it "attempts to retry node generation on unsatisfiable predicates" ensureFailureSpec++runDB :: MonadUnliftIO m => ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a+runDB f = runSqlite "test.db" $ do+  runMigration migrateAll+  f+```+-->