From c20e88b8de768728dff246b458fde55068779322 Mon Sep 17 00:00:00 2001
From: Evan Rutledge Borden <eborden@frontrowed.com>
Date: Mon, 1 Jun 2020 10:41:32 -0500
Subject: [PATCH] Expose generate via Graphula.Arbitrary

Anything in tests that utilizes random generation can use the graphula
seed and remain deterministic, instead of falling back to `IO`.
---
 graphula-core/src/Graphula.hs           | 26 +++----------------
 graphula-core/src/Graphula/Arbitrary.hs | 34 +++++++++++++++++++++++++
 graphula-core/src/Graphula/Internal.hs  | 10 ++++++++
 3 files changed, 48 insertions(+), 22 deletions(-)
 create mode 100644 graphula-core/src/Graphula/Arbitrary.hs

diff --git a/graphula-core/src/Graphula.hs b/graphula-core/src/Graphula.hs
index cfee4c4..4558c49 100755
--- a/graphula-core/src/Graphula.hs
+++ b/graphula-core/src/Graphula.hs
@@ -90,7 +90,7 @@ 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, writeIORef)
+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
 import Data.Kind (Constraint, Type)
 import Data.Proxy (Proxy(..))
 import Data.Semigroup.Generic (gmappend, gmempty)
@@ -115,15 +115,15 @@ import Database.Persist
 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, split)
+import System.Random (randomIO)
 import Test.HUnit.Lang
   (FailureReason(..), HUnitFailure(..), formatFailureReason)
-import Test.QuickCheck (Arbitrary(..), Gen)
-import Test.QuickCheck.Gen (unGen)
+import Test.QuickCheck (Arbitrary(..))
 import Test.QuickCheck.Random (QCGen, mkQCGen)
 import UnliftIO.Exception
   (Exception, SomeException, bracket, catch, mask, throwIO)
@@ -148,14 +148,6 @@ type family GraphulaContext (m :: Type -> Type) (ts :: [Type]) :: Constraint whe
    GraphulaContext m '[] = MonadGraphula m
    GraphulaContext m (t ': ts) = (GraphulaNode m t, GraphulaContext m ts)
 
-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 ()
-
 class MonadGraphulaFrontend m where
   insert
     :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m)
@@ -561,13 +553,3 @@ newtype Only a = Only { fromOnly :: a }
 
 only :: a -> Only a
 only = Only
-
-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
diff --git a/graphula-core/src/Graphula/Arbitrary.hs b/graphula-core/src/Graphula/Arbitrary.hs
new file mode 100644
index 0000000..42aa70e
--- /dev/null
+++ b/graphula-core/src/Graphula/Arbitrary.hs
@@ -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
diff --git a/graphula-core/src/Graphula/Internal.hs b/graphula-core/src/Graphula/Internal.hs
index 4972dd1..546c98b 100644
--- a/graphula-core/src/Graphula/Internal.hs
+++ b/graphula-core/src/Graphula/Internal.hs
@@ -11,11 +11,21 @@
 
 module Graphula.Internal 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