quickspec 2.1.4 → 2.1.5
raw patch · 3 files changed
+109/−24 lines, 3 files
Files
- quickspec.cabal +1/−1
- src/QuickSpec/Internal/Haskell.hs +96/−12
- src/QuickSpec/Internal/Prop.hs +12/−11
quickspec.cabal view
@@ -1,5 +1,5 @@ Name: quickspec-Version: 2.1.4+Version: 2.1.5 Cabal-version: >= 1.10 Build-type: Simple
src/QuickSpec/Internal/Haskell.hs view
@@ -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'
src/QuickSpec/Internal/Prop.hs view
@@ -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