diff --git a/quickspec.cabal b/quickspec.cabal --- a/quickspec.cabal +++ b/quickspec.cabal @@ -1,5 +1,5 @@ Name: quickspec -Version: 2.1.4 +Version: 2.1.5 Cabal-version: >= 1.10 Build-type: Simple diff --git a/src/QuickSpec/Internal/Haskell.hs b/src/QuickSpec/Internal/Haskell.hs --- a/src/QuickSpec/Internal/Haskell.hs +++ b/src/QuickSpec/Internal/Haskell.hs @@ -50,6 +50,16 @@ import qualified Test.QuickCheck.Poly as Poly import Numeric.Natural import Test.QuickCheck.Instances() +import Data.Word +import Data.List.NonEmpty (NonEmpty) +import Data.Complex +import Data.Ratio +import Data.Functor.Compose +import Data.Int +import Data.Void +import Data.Unique +import qualified Data.Monoid as DM +import qualified Data.Semigroup as DS baseInstances :: Instances baseInstances = @@ -171,9 +181,94 @@ instance (Arbitrary a, Observe test outcome b) => Observe (a, test) outcome (a -> b) where observe (x, obs) f = observe obs (f x) +instance Observe () Int Int +instance Observe () Int8 Int8 +instance Observe () Int16 Int16 +instance Observe () Int32 Int32 +instance Observe () Int64 Int64 +instance Observe () Float Float +instance Observe () Double Double +instance Observe () Word Word +instance Observe () Word8 Word8 +instance Observe () Word16 Word16 +instance Observe () Word32 Word32 +instance Observe () Word64 Word64 +instance Observe () Integer Integer +instance Observe () Char Char +instance Observe () Bool Bool +instance Observe () Ordering Ordering +instance Observe () Void Void +instance Observe () Unique Unique +instance Observe () Natural Natural +instance Observe () DS.All DS.All +instance Observe () DS.Any DS.Any +instance Observe () () () +instance (Observe xt xo x, Observe yt yo y) + => Observe (xt, yt) (xo, yo) (x, y) where + observe (xt, yt) (x, y) + = (observe xt x, observe yt y) +instance (Observe xt xo x, Observe yt yo y, Observe zt zo z) + => Observe (xt, yt, zt) (xo, yo, zo) (x, y, z) where + observe (xt, yt, zt) (x, y, z) + = (observe xt x, observe yt y, observe zt z) +instance (Observe xt xo x, Observe yt yo y, Observe zt zo z, Observe wt wo w) + => Observe (xt, yt, zt, wt) (xo, yo, zo, wo) (x, y, z, w) where + observe (xt, yt, zt, wt) (x, y, z, w) + = (observe xt x, observe yt y, observe zt z, observe wt w) +instance Observe t p a => Observe t [p] [a] where + observe t ps = fmap (observe t) ps +instance Observe t p a => Observe t (NonEmpty p) (NonEmpty a) where + observe t ps = fmap (observe t) ps +instance Observe t p a => Observe (t, t) (p, p) (Complex a) where + observe (t1, t2) (p1 :+ p2) = (observe t1 p1, observe t2 p2) +instance Observe t p a => Observe (t, t) (p, p) (Ratio a) where + observe (t1, t2) (p) + = (observe t1 $ numerator p, observe t2 $ denominator p) +instance Observe t p a => Observe t p (Identity a) where + observe t = observe t . runIdentity +instance Observe t p (f (g a)) => Observe t p (Compose f g a) where + observe t = observe t . getCompose +instance (Observe at ao a, Observe bt bo b) + => Observe (at, bt) (Either ao bo) (Either a b) where + observe (at, _) (Left a) = Left $ observe at a + observe (_, bt) (Right b) = Right $ observe bt b +instance Observe t p a => Observe t p (DS.Sum a) where + observe t = observe t . DS.getSum +instance Observe t p a => Observe t p (DS.Product a) where + observe t = observe t . DS.getProduct +instance Observe t p a => Observe t p (DS.First a) where + observe t = observe t . DS.getFirst +instance Observe t p a => Observe t p (DS.Last a) where + observe t = observe t . DS.getLast +instance Observe t p a => Observe t p (DS.Dual a) where + observe t = observe t . DS.getDual +instance Observe t p a => Observe t p (DS.Min a) where + observe t = observe t . DS.getMin +instance Observe t p a => Observe t p (DS.Max a) where + observe t = observe t . DS.getMax +instance Observe t p a => Observe t p (DS.WrappedMonoid a) where + observe t = observe t . DS.unwrapMonoid +instance Observe t p (f a) => Observe t p (DM.Alt f a) where + observe t = observe t . DM.getAlt +instance Observe t p (f a) => Observe t p (DM.Ap f a) where + observe t = observe t . DM.getAp +instance Observe t p a => Observe t (Maybe p) (DM.First a) where + observe t = observe t . DM.getFirst +instance Observe t p a => Observe t (Maybe p) (DM.Last a) where + observe t = observe t . DM.getLast +instance Observe t p a => Observe t (Maybe p) (DS.Option a) where + observe t = observe t . DS.getOption +instance Observe t p a => Observe t (Maybe p) (Maybe a) where + observe t (Just a) = Just $ observe t a + observe _ Nothing = Nothing +instance (Arbitrary a, Observe t p a) => Observe (a, t) p (DS.Endo a) where + observe t = observe t . DS.appEndo + + -- | Like 'Test.QuickCheck.===', but using the 'Observe' typeclass instead of 'Eq'. (=~=) :: (Show test, Show outcome, Observe test outcome a) => a -> a -> Property a =~= b = property $ \test -> observe test a Test.QuickCheck.=== observe test b +infix 4 =~= -- An observation function along with instances. -- The parameters are in this order so that we can use findInstance to get at appropriate Wrappers. @@ -292,17 +387,6 @@ con_size :: Int, con_classify :: Classification Constant } -makeQuickcheckFun :: String -> Constant -makeQuickcheckFun nm = Constant - { con_name = nm - , con_style = infixStyle 9 -- high precedence to always force parens - , con_value = undefined - , con_type = undefined - , con_constraints = undefined - , con_size = 1 - , con_classify = Function - } - instance Eq Constant where x == y = con_name x == con_name y && typ (con_value x) == typ (con_value y) @@ -629,8 +713,8 @@ ForQuickCheck -> renderStyle (style {lineLength = 78}) $ nest 2 $ prettyPropQC + cfg_default_to was_observed - makeQuickcheckFun n (names instances) prop' diff --git a/src/QuickSpec/Internal/Prop.hs b/src/QuickSpec/Internal/Prop.hs --- a/src/QuickSpec/Internal/Prop.hs +++ b/src/QuickSpec/Internal/Prop.hs @@ -8,11 +8,12 @@ import Data.Ord import QuickSpec.Internal.Type import QuickSpec.Internal.Utils -import QuickSpec.Internal.Term +import QuickSpec.Internal.Term hiding (first) import GHC.Generics(Generic) import qualified Data.Map.Strict as Map import Control.Monad.Trans.State.Strict import Data.List +import Control.Arrow (first) data Prop a = (:=>:) { @@ -90,18 +91,17 @@ prettyPropQC :: (Typed fun, Apply (Term fun), PrettyTerm fun) => - (Type -> Bool) -> (String -> fun) -> Int -> (Type -> [String]) -> Prop (Term fun) -> Doc -prettyPropQC was_observed mk_fun nth cands x + Type -> (Type -> Bool) -> Int -> (Type -> [String]) -> Prop (Term fun) -> Doc +prettyPropQC default_to was_observed nth cands x = hang (text first_char <+> text "(" <+> ((text $ show $ show $ pPrint law))) 2 $ hang (hsep [text ",", text "property", text "$"]) 4 $ hang ppr_binds 4 - $ ppr_ctx <+> (pPrint (eq_fn :$: lhs :$: rhs) <> text ")") - + $ (ppr_ctx <+> with_sig lhs lhs_type <+> eq_fn <+> pPrint rhs) <> text ")" where - eq = mk_fun "===" - obs_eq = mk_fun "=~=" - eq_fn = Fun $ Ordinary $ bool eq obs_eq $ was_observed $ typ lhs_for_type - + eq = "===" + obs_eq = "=~=" + eq_fn = text $ bool eq obs_eq $ was_observed lhs_type + lhs_type = typ lhs_for_type first_char = case nth of @@ -114,11 +114,12 @@ (_ :=>: (lhs_for_type :=: _)) = x (var_defs, law@(ctx :=>: (lhs :=: rhs))) = nameVars cands x - print_sig name ty = parens $ text name <+> text "::" <+> pPrintType ty + with_sig expr ty = print_sig (pPrint expr) ty + print_sig doc ty = parens $ doc <+> text "::" <+> pPrintType (defaultTo default_to ty) ppr_binds = case Map.size var_defs of 0 -> pPrintEmpty - _ -> (text "\\ " <> sep (fmap (uncurry print_sig) (Map.assocs var_defs))) <+> text "->" + _ -> (text "\\ " <> sep (fmap (uncurry print_sig) (fmap (first text) $ Map.assocs var_defs))) <+> text "->" data Named fun = Name String | Ordinary fun