diff --git a/graphula-core.cabal b/graphula-core.cabal index a6f77a6..a498a01 100644 --- a/graphula-core.cabal +++ b/graphula-core.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: c702d130f70b24da8de0ffee7a182f6962fb405feea3f8e1bc1070a191b37900 +-- hash: f2c74205b24377421432714686288b910a90f4d9a5470075974e153ba270bb2a name: graphula-core version: 2.0.0.0 @@ -26,7 +26,7 @@ library Paths_graphula_core hs-source-dirs: src - ghc-options: -Wall + ghc-options: -Weverything -Wno-unsafe -Wno-safe -Wno-missing-import-lists -Wno-implicit-prelude build-depends: HUnit , QuickCheck @@ -53,7 +53,7 @@ test-suite readme Paths_graphula_core hs-source-dirs: test - ghc-options: -Wall -pgmL markdown-unlit + ghc-options: -Weverything -Wno-unsafe -Wno-safe -Wno-missing-import-lists -Wno-implicit-prelude -pgmL markdown-unlit build-depends: QuickCheck , aeson diff --git a/package.yaml b/package.yaml index 1e147f4..dda4f81 100644 --- a/package.yaml +++ b/package.yaml @@ -6,13 +6,19 @@ extra-source-files: - README.md - CHANGELOG.md +ghc-options: + -Weverything + -Wno-unsafe + -Wno-safe + -Wno-missing-import-lists + -Wno-implicit-prelude + dependencies: - base library: source-dirs: - src - ghc-options: -Wall dependencies: - HUnit - QuickCheck @@ -32,7 +38,7 @@ library: tests: readme: main: README.lhs - ghc-options: -Wall -pgmL markdown-unlit + ghc-options: -pgmL markdown-unlit source-dirs: - test dependencies: diff --git a/src/Graphula.hs b/src/Graphula.hs index 4558c49..e38c5d8 100755 --- a/src/Graphula.hs +++ b/src/Graphula.hs @@ -1,28 +1,10 @@ -{-| - 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" } - @ --} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -43,6 +25,23 @@ {-# 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 @@ -163,7 +162,7 @@ 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 (Functor, Applicative, Monad, MonadIO, MonadReader (Args SqlBackend n m)) + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (Args SqlBackend n m)) instance MonadTrans (GraphulaT n) where lift = GraphulaT . lift @@ -221,7 +220,7 @@ logFailingSeed seed = rethrowHUnitWith ("Graphula with seed: " ++ show seed) newtype GraphulaIdempotentT m a = GraphulaIdempotentT {runGraphulaIdempotentT' :: ReaderT (IORef (m ())) m a} - deriving (Functor, Applicative, Monad, MonadIO, MonadReader (IORef (m ()))) + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (IORef (m ()))) instance MonadUnliftIO m => MonadUnliftIO (GraphulaIdempotentT m) where {-# INLINE askUnliftIO #-} @@ -261,15 +260,18 @@ runGraphulaIdempotentT action = mask $ \unmasked -> do `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 (Functor, Applicative, Monad, MonadIO, MonadReader (IORef (Seq Text))) + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (IORef (Seq Text))) instance MonadTrans GraphulaLoggedT where lift = GraphulaLoggedT . lift @@ -400,7 +402,7 @@ data GenerationFailure -- ^ Could not satisfy constraints defined using @'ensure'@ | GenerationFailureMaxAttemptsToInsert TypeRep -- ^ Could not satisfy database constraints on insert - deriving (Show, Typeable, Eq) + deriving stock (Show, Eq) instance Exception GenerationFailure @@ -502,7 +504,7 @@ ensure f = mempty { nodeOptionsEdit = Kendo $ \a -> a <$ guard (f a) } newtype NodeOptions a = NodeOptions { nodeOptionsEdit :: Kendo Maybe a } - deriving (Generic) + deriving stock Generic instance Semigroup (NodeOptions a) where (<>) = gmappend @@ -514,6 +516,7 @@ instance Monoid (NodeOptions a) where -- | 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 @@ -525,7 +528,7 @@ instance Monad m => Monoid (Kendo m a) where attempt :: forall a m - . (Typeable a, GraphulaContext m '[a]) + . (GraphulaContext m '[a]) => Int -> Int -> m (Maybe (Maybe (Key a), a)) @@ -549,7 +552,7 @@ attempt maxEdits maxInserts source = loop 0 0 -- | For entities that only have singular 'Dependencies' newtype Only a = Only { fromOnly :: a } - deriving (Eq, Show, Ord, Generic, Functor, Foldable, Traversable) + deriving stock (Eq, Show, Ord, Generic, Functor, Foldable, Traversable) only :: a -> Only a only = Only diff --git a/src/Graphula/Internal.hs b/src/Graphula/Internal.hs index 546c98b..a0ab5dc 100644 --- a/src/Graphula/Internal.hs +++ b/src/Graphula/Internal.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Graphula.Internal where @@ -39,7 +40,7 @@ type family DependenciesTypeInstance nodeTy depsTy where -- 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) = + FindMatches nodeTy depsTy () (d, _ds) = TypeError ( 'Text "Excess dependency ‘" ':<>: 'ShowType d ':<>: 'Text "’ in " ':$$: DependenciesTypeInstance nodeTy depsTy ':$$: @@ -48,7 +49,7 @@ type family FindMatches nodeTy depsTy as ds :: [Match Type] where ) -- No more fields or dependencies left - FindMatches nodeTy depsTy () () = '[] + FindMatches _nodeTy _depsTy () () = '[] -- Fields left, but no more dependencies FindMatches nodeTy depsTy (a, as) () = 'NoMatch a ': FindMatches nodeTy depsTy as () diff --git a/test/Graphula/UUIDKey.hs b/test/Graphula/UUIDKey.hs index ce654e1..811aa6e 100644 --- a/test/Graphula/UUIDKey.hs +++ b/test/Graphula/UUIDKey.hs @@ -16,7 +16,7 @@ import Data.UUID (UUID) import qualified Data.UUID as UUID import Database.Persist import Database.Persist.Sql -import Test.QuickCheck (Arbitrary(..), getLarge) +import Test.QuickCheck (Arbitrary(..), Gen, getLarge) import Web.HttpApiData (FromHttpApiData, ToHttpApiData) import Web.PathPieces (PathPiece(..)) @@ -26,9 +26,10 @@ newtype UUIDKey = UUIDKey { unUUIDKey :: UUID } instance Arbitrary UUIDKey where arbitrary = UUIDKey <$> uuid - where - uuid = UUID.fromWords <$> word <*> word <*> word <*> word - word = getLarge <$> arbitrary + 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 diff --git a/test/README.lhs b/test/README.lhs index d8c448a..02bb7c6 100644 --- a/test/README.lhs +++ b/test/README.lhs @@ -19,8 +19,10 @@ Graphula is a simple interface for generating persistent data and linking its de {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-missing-deriving-strategies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Main where + +module Main (module Main) where import Control.Monad (replicateM_) import Control.Monad.IO.Class @@ -135,7 +137,7 @@ an overlapping `Arbitrary` instance. instance HasDependencies D where type KeySource D = 'SourceArbitrary -deriving instance {-# OVERLAPPING #-} Arbitrary (Key D) +deriving newtype instance {-# OVERLAPPING #-} Arbitrary (Key D) ``` You can also elect to always specify an external key using `'SourceExternal`. This means that @@ -158,8 +160,11 @@ to a temp file on test failure. 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"} @@ -207,6 +212,7 @@ instance MonadGraphulaFrontend (GraphulaFailT m) where insertionFailureSpec :: IO () insertionFailureSpec = do let + failingGraph :: IO () failingGraph = runGraphulaT Nothing runDB . runGraphulaFailT $ do Entity _ _ <- node @A () mempty pure () @@ -221,6 +227,7 @@ in the database: constraintFailureSpec :: IO () constraintFailureSpec = do let + failingGraph :: IO () failingGraph = runGraphulaT Nothing runDB $ replicateM_ 3 $ node @F () mempty failingGraph @@ -233,6 +240,7 @@ or if we define a graph with an unsatisfiable predicates: ensureFailureSpec :: IO () ensureFailureSpec = do let + failingGraph :: IO () failingGraph = runGraphulaT Nothing runDB $ do Entity _ _ <- node @A () $ ensure $ \a -> a /= a pure ()