diff --git a/src/Test/StrictCheck.hs b/src/Test/StrictCheck.hs index de8f822..e1dc8d3 100644 --- a/src/Test/StrictCheck.hs +++ b/src/Test/StrictCheck.hs @@ -80,6 +80,7 @@ import qualified Test.QuickCheck as QC import Data.Char (ord) import Data.Function (on) +import Data.Kind (Type) import Data.List import Data.Maybe import Data.IORef @@ -138,7 +139,7 @@ newtype DemandComparison a = -- to manipulate these implicit demand representations when writing @Spec@s, and -- see the documentation for "Test.StrictCheck.Examples.Lists" for more examples -- of writing specifications. -newtype Spec (args :: [*]) (result :: *) +newtype Spec (args :: [Type]) (result :: Type) = Spec (forall r. (args ⋯-> r) -> result -> args ⋯-> r) -- | Unwrap a @Spec@ constructor, returning the contained CPS-ed specification @@ -187,7 +188,7 @@ compareToSpecWith comparisons spec (Evaluation inputs inputsD resultD) = curryCollect @args (hcmap (Proxy @Shaped) (toDemand . unI)) curryCollect - :: forall (xs :: [*]) r. Curry xs => (NP I xs -> r) -> xs ⋯-> r + :: forall (xs :: [Type]) r. Curry xs => (NP I xs -> r) -> xs ⋯-> r curryCollect k = Curry.curry @xs k -- | Checks if a given 'Evaluation' exactly matches the prediction of a given @@ -296,7 +297,9 @@ strictCheckSpecExact spec function = strictnessViaSized (equalToSpec spec) function - (putStrLn . head . lines) (output result) + case lines (output result) of + line0 : _ -> putStrLn line0 + [] -> pure () case maybeExample of Nothing -> return () Just example -> do diff --git a/src/Test/StrictCheck/Consume.hs b/src/Test/StrictCheck/Consume.hs index eb70f73..1a783ac 100644 --- a/src/Test/StrictCheck/Consume.hs +++ b/src/Test/StrictCheck/Consume.hs @@ -129,7 +129,7 @@ instance Consume Double where consume = consumePrimitive instance Consume Float where consume = consumePrimitive instance Consume Rational where consume = consumePrimitive instance Consume Integer where consume = consumePrimitive -instance (CoArbitrary a, RealFloat a) => Consume (Complex a) where +instance CoArbitrary a => Consume (Complex a) where consume = consumePrimitive instance Consume () diff --git a/src/Test/StrictCheck/Curry.hs b/src/Test/StrictCheck/Curry.hs index 03aefa6..25e6a9b 100644 --- a/src/Test/StrictCheck/Curry.hs +++ b/src/Test/StrictCheck/Curry.hs @@ -21,6 +21,7 @@ module Test.StrictCheck.Curry import Prelude hiding (curry, uncurry) +import Data.Kind (Type) import Data.Type.Equality import qualified Unsafe.Coerce as UNSAFE @@ -36,7 +37,7 @@ import qualified Generics.SOP as SOP -- For example: -- -- > Args (Int -> Bool -> Char) ~ [Int, Bool] -type family Args (f :: *) :: [*] where +type family Args (f :: Type) :: [Type] where Args (a -> rest) = a : Args rest Args x = '[] @@ -50,7 +51,7 @@ type family Args (f :: *) :: [*] where -- -- This infix unicode symbol is meant to evoke a function arrow with an -- ellipsis. -type family (args :: [*]) ⋯-> (rest :: *) :: * where +type family (args :: [Type]) ⋯-> (rest :: Type) :: Type where '[] ⋯-> rest = rest (a : args) ⋯-> rest = a -> args ⋯-> rest @@ -64,7 +65,7 @@ type args -..-> rest = args ⋯-> rest -- For example: -- -- > Result (Int -> Bool -> Char) ~ Char -type family Result (f :: *) :: * where +type family Result (f :: Type) :: Type where Result (a -> rest) = Result rest Result r = r @@ -91,14 +92,14 @@ withCurryIdentity r = -- | This currying mechanism is agnostic to the concrete heterogeneous list type -- used to carry arguments. The @List@ class abstracts over the nil and cons -- operations of a heterogeneous list: to use your own, just define an instance. -class List (list :: [*] -> *) where +class List (list :: [Type] -> Type) where nil :: list '[] cons :: x -> list xs -> list (x : xs) uncons :: list (x : xs) -> (x, list xs) -- | The Curry class witnesses that for any list of arguments, it is always -- possible to curry/uncurry at that arity -class Curry (args :: [*]) where +class Curry (args :: [Type]) where uncurry :: forall result list. List list => (args ⋯-> result) -> list args -> result diff --git a/src/Test/StrictCheck/Demand.hs b/src/Test/StrictCheck/Demand.hs index 7d6d64f..02cc481 100644 --- a/src/Test/StrictCheck/Demand.hs +++ b/src/Test/StrictCheck/Demand.hs @@ -36,7 +36,7 @@ module Test.StrictCheck.Demand import qualified Control.Exception as Exception import qualified GHC.Generics as GHC -import Control.Applicative +import Control.Applicative (liftA2) -- for GHC 9.2 import Data.Bifunctor import System.IO.Unsafe import Data.Monoid ( Endo(..) ) diff --git a/src/Test/StrictCheck/Produce.hs b/src/Test/StrictCheck/Produce.hs index 36f1317..977f503 100644 --- a/src/Test/StrictCheck/Produce.hs +++ b/src/Test/StrictCheck/Produce.hs @@ -34,8 +34,7 @@ import Test.StrictCheck.Curry import Generics.SOP import Data.Complex -import Data.Monoid ((<>)) - +import Data.List.NonEmpty (NonEmpty(..)) ------------------------------------------------------- -- The user interface for creating Produce instances -- @@ -206,7 +205,7 @@ instance Produce Float where produce = arbitrary instance Produce Rational where produce = arbitrary instance Produce Integer where produce = arbitrary -instance (Arbitrary a, RealFloat a) => Produce (Complex a) where +instance Arbitrary a => Produce (Complex a) where produce = arbitrary instance Produce a => Produce (Maybe a) where @@ -227,3 +226,6 @@ instance (Produce a) => Produce [a] where , (1, (:) <$> recur <*> recur) ] + +instance Produce a => Produce (NonEmpty a) where + produce = (:|) <$> recur <*> recur diff --git a/src/Test/StrictCheck/Shaped.hs b/src/Test/StrictCheck/Shaped.hs index 009c48a..9bc282d 100644 --- a/src/Test/StrictCheck/Shaped.hs +++ b/src/Test/StrictCheck/Shaped.hs @@ -86,11 +86,12 @@ import Data.Functor.Product import Data.Bifunctor import Data.Bifunctor.Flip import Data.Coerce +import Data.Kind (Type) import Generics.SOP hiding ( Shape ) import Data.Complex --- import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty (NonEmpty(..)) import Test.StrictCheck.Shaped.Flattened @@ -117,11 +118,11 @@ import Test.StrictCheck.Shaped.Flattened -- -- The shape of a primitive type should be isomorphic to the primitive type, -- with the functor parameter left unused. -class Typeable a => Shaped (a :: *) where +class Typeable a => Shaped (a :: Type) where -- | The @Shape@ of an @a@ is a type isomorphic to the outermost level of -- structure in an @a@, parameterized by the functor @f@, which is wrapped -- around any fields (of any type) in the original @a@. - type Shape a :: (* -> *) -> * + type Shape a :: (Type -> Type) -> Type type Shape a = GShape a -- | Given a function to expand any @Shaped@ @x@ into an @f x@, expand an @a@ @@ -210,7 +211,7 @@ class Typeable a => Shaped (a :: *) where -- | A value of type @f % a@ has the same structure as an @a@, but with the -- structure of the functor @f@ interleaved at every field (including ones of -- types other than @a@). Read this type aloud as "a interleaved with f's". -newtype (f :: * -> *) % (a :: *) :: * where +newtype (f :: Type -> Type) % (a :: Type) :: Type where Wrap :: f (Shape a ((%) f)) -> f % a -- | Look inside a single level of an interleaved @f % a@. Inverse to the 'Wrap' @@ -423,7 +424,7 @@ embedContainer e (Container x) = fmap e x -- type really is primitive, in that it contains no interesting substructure. -- If you use the @Prim@ representation inappropriately, StrictCheck will not be -- able to inspect the richer structure of the type in question. -newtype Prim (x :: *) (f :: * -> *) +newtype Prim (x :: Type) (f :: Type -> Type) = Prim x deriving (Eq, Ord, Show) deriving newtype (Num) @@ -644,7 +645,7 @@ gRender :: forall a x. (HasDatatypeInfo a, GShaped a) => Shape a (K x) -> RenderLevel x gRender (GS demand) = case info of - ADT m d cs s -> + ADT m d cs _s -> renderC m d demand cs Newtype m d c -> renderC m d demand (c :* Nil) @@ -750,9 +751,7 @@ instance (Typeable a, Eq a, Show a) => Shaped (Complex a) where match = matchPrim render = renderPrim --- instance Generic (NonEmpty a) --- instance HasDatatypeInfo (NonEmpty a) --- instance Shaped a => Shaped (NonEmpty a) where +instance Shaped a => Shaped (NonEmpty a) where -- Tree -- Map k diff --git a/src/Test/StrictCheck/Shaped/Flattened.hs b/src/Test/StrictCheck/Shaped/Flattened.hs index 5eb1107..5ff7172 100644 --- a/src/Test/StrictCheck/Shaped/Flattened.hs +++ b/src/Test/StrictCheck/Shaped/Flattened.hs @@ -22,8 +22,8 @@ import Generics.SOP -- a value @d h@ for any @h@, given an n-ary product with matching field types -- to the one contained here. -- --- Pay attention to the kinds! @d :: (* -> *) -> *@, @f :: * -> *@, and --- @xs :: [*]@. +-- Pay attention to the kinds! @d :: (Type -> Type) -> Type@, @f :: Type -> Type@, +-- and @xs :: [Type]@. -- -- For types which are literally a collection of fields with no extra -- information, the reconstruction function merely converts the given list of diff --git a/src/Test/StrictCheck/TH.hs b/src/Test/StrictCheck/TH.hs index 6c579c1..cf36c4b 100644 --- a/src/Test/StrictCheck/TH.hs +++ b/src/Test/StrictCheck/TH.hs @@ -6,7 +6,6 @@ module Test.StrictCheck.TH ) where -import Control.Monad (when) import Generics.SOP (NP (..), NS (..)) import Language.Haskell.TH import Test.StrictCheck.Demand