registry 0.1.2.3 → 0.1.2.4
raw patch · 3 files changed
+95/−11 lines, 3 files
Files
- registry.cabal +2/−2
- src/Data/Registry/Lift.hs +62/−8
- test/Test/Data/Registry/GenSpec.hs +31/−1
registry.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: e570c9eb12f1d7452ae6ba23b2fd2fde606bc45719f4bc981ddea25dc2b18704+-- hash: 875841de93fa8c39edcfa699e24ae654224e8f39182a77262a4dff5f67e8938d name: registry-version: 0.1.2.3+version: 0.1.2.4 synopsis: data structure for assembling components description: This library provides a "Registry" which is a data structure containing a list of functions and values representing dependencies in a directed acyclic graph. A `make` function can then be used to create a value of a specific type out of the registry. You can start with the [README](https://github.com/etorreborre/registry/blob/master/README.md) for a full description of the library.
src/Data/Registry/Lift.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE IncoherentInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} {- | This code is taken from https://stackoverflow.com/questions/28003135/is-it-possible-to-encode-a-generic-lift-function-in-haskell@@ -18,7 +20,7 @@ -} module Data.Registry.Lift where -import Protolude+import Protolude hiding (Nat) -- | Typeclass for lifting pure functions to effectful arguments and results class Applicative f => ApplyVariadic f a b where@@ -50,15 +52,67 @@ -- | Typeclass for lifting a function with a result of type m b into a function -- with a result of type n b-class Applicative f => ApplyVariadic2 f g a b where+class ApplyVariadic2 f g a b where applyVariadic2 :: (forall x . f x -> g x) -> a -> b -instance (Applicative f, b ~ g a) => ApplyVariadic2 f g (f a) b where+instance (b ~ g a) => ApplyVariadic2 f g (f a) b where applyVariadic2 natfg = natfg -instance (Applicative f, ApplyVariadic2 f g a' b', b ~ (a -> b')) => ApplyVariadic2 f g (a -> a') b where+instance (ApplyVariadic2 f g a' b', b ~ (a -> b')) => ApplyVariadic2 f g (a -> a') b where applyVariadic2 natfg f a = applyVariadic2 natfg (f a) -- | Lift a function returning an effectful result to a function returning another effectful result outTo :: forall g f a b . ApplyVariadic2 f g a b => (forall x . f x -> g x) -> a -> b outTo natfg = applyVariadic2 natfg :: a -> b++-- * Tagging++-- | The output of some constructors can be "tagged" with a string to indicate how a given+-- value was built.+newtype Tag (s :: Symbol) a = Tag { unTag :: a } deriving (Eq, Show)++instance Functor (Tag s) where+ fmap f (Tag a) = Tag @s (f a)++instance Applicative (Tag s) where+ pure = Tag+ Tag f <*> Tag a = Tag @s (f a)++-- | Tag a given constructor f with a string s. The 'applyLast' function only applies the tag to the output+-- type of the constructor. For example+-- data Salary = Fixed Int | Variable Int Double+-- tag @"Variable" Variable :: Int -> Double -> Tag "Variable" Salary+tag :: forall (s :: Symbol) fun . (CNumArgs (CountArgs fun) fun) => fun -> Apply (Tag s) (CountArgs fun) fun+tag = applyLast @(Tag s)++-- | ApplyLast typeclass provided by @neongreen+-- It uses an auxiliary typeclass to count the arguments of a function+data Nat = Z | S Nat++data NumArgs :: Nat -> * -> * where+ NAZ :: NumArgs Z a+ NAS :: NumArgs n b -> NumArgs (S n) (a -> b)++type family CountArgs (f :: *) :: Nat where+ CountArgs (a -> b) = S (CountArgs b)+ CountArgs result = Z++class CNumArgs (numArgs :: Nat) (arrows :: *) where+ getNA :: NumArgs numArgs arrows++instance CNumArgs Z a where+ getNA = NAZ++instance CNumArgs n b => CNumArgs (S n) (a -> b) where+ getNA = NAS getNA++type family Apply (f :: * -> *) (n :: Nat) (arrows :: *) :: * where+ Apply f (S n) (a -> b) = a -> Apply f n b+ Apply f Z a = f a++applyLast :: forall f fun . (Applicative f, CNumArgs (CountArgs fun) fun) => fun -> Apply f (CountArgs fun) fun+applyLast = applyLast' @f (getNA :: NumArgs (CountArgs fun) fun)++applyLast' :: forall f n fun . Applicative f => NumArgs n fun -> fun -> Apply f n fun+applyLast' NAZ x = pure x+applyLast' (NAS n) f = applyLast' @f n . f
test/Test/Data/Registry/GenSpec.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}@@ -7,6 +8,7 @@ -} module Test.Data.Registry.GenSpec where +import Data.List (partition) import Data.Registry import Hedgehog.Gen as Gen import Hedgehog.Range as Range@@ -37,6 +39,9 @@ | Variable Int Double deriving (Eq, Show) +isFixed (Fixed _) = True+isFixed _ = False+ -- * GENERATORS genText :: Gen Text@@ -90,6 +95,28 @@ let allEmployees = company & departments >>= (& employees) length allEmployees === 1 ++-- * WITH VARIANTS++registry' =+ fun (sequence . replicate @(Gen Salary) 10)+ +: fun salaryGen+ +: funTo @Gen (tag @"Fixed" Fixed)+ +: funTo @Gen (tag @"Variable" Variable)+ +: registry++salaryGen :: Gen (Tag "Fixed" Salary) -> Gen (Tag "Variable" Salary) -> Gen Salary+salaryGen fixed variable = choice [unTag <$> fixed, unTag <$> variable]++test_with_different_salaries = noShrink $ prop "generate both fixed and variable salaries" $ runWith registry' $ do+ salaries <- forall @[Salary]+ let (fixed, variables) = partition isFixed salaries++ annotate "the choice operator allows us to generate both fixed and variable salaries"+ not (null fixed) === True+ not (null variables) === True++ -- * HELPERS type RegistryProperty m a = forall ins out . StateT (Registry ins out) (PropertyT m) a@@ -101,6 +128,9 @@ tweakGen f = modify $ tweakUnsafe @(Gen a) f run :: Monad m => RegistryProperty m a -> PropertyT m a-run = flip evalStateT registry+run = runWith registry++runWith :: Monad m => Registry ins out -> RegistryProperty m a -> PropertyT m a+runWith = flip evalStateT ---- tests = $(testGroupGenerator)