quickcheck-silent 0.11.0.9 → 0.11.0.10

raw patch · 8 files changed

+2312/−19 lines, 8 filesdep +containersdep +mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: containers, mtl

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−0
• quickcheck-silent.cabal +17/−3
• src/Internal/GaloisInc/Text/JSON.hs +537/−0
• src/Internal/GaloisInc/Text/JSON/Generic.hs +241/−0
• src/Internal/GaloisInc/Text/JSON/String.hs +412/−0
• src/Internal/GaloisInc/Text/JSON/Types.hs +126/−0
• src/Internal/GlasgowUniversity/Data/Generics/Aliases.hs +754/−0
• src/Test/QuickCheck/Silent.hs +207/−16

@@ -1,5 +1,23 @@ # Revision history for quickcheck-silent +## 0.11.0.10 -- 2026-08-18++* Added basic test hierarchy capabilities: `suite`, `group` (category) and+  `case`.++* Exposing `property` in order to re-use defined silent property test cases with+  other compatible `QuickChech` frameworks.+  +* Dropped the `Result` data type from `QuickChech` as it's a bit complex. A more+  simple, heavily inspired in the `Count` type from the `HUnit` package has been+  added.+  +* To be able to run test suites, both `quickCheckSilentSuite` and+  `quickCheckSilentSuiteJSON` have been added.++* Finally, `isSuccess` has been added to ease the iteration over a sequence of+  test results to check if they are all successful.+ ## 0.11.0.9 -- 2026-08-14  * Feedback from `#nixos` on [Libera](https://libera.chat/) helped us realize that we can

@@ -10,7 +10,7 @@ build-type: Simple                                                name: quickcheck-silent-version: 0.11.0.9+version: 0.11.0.10  synopsis: Testing with QuickCheck in silence description: Testing with QuickCheck in silence. For more info see README.md@@ -56,9 +56,12 @@       Haskell2010   build-depends:       -- Prelude-      base       >= 4    && < 5+      base       >= 4        && < 5       -- Test-    , QuickCheck >= 2.18 && < 3+    , QuickCheck >= 2.18     && < 3+      -- JSON+    , containers >= 0.7      && < 1+    , mtl        >= 2.3.1    && < 3   ghc-options:       --------------------------------------------------------------------------       -- GHC 9.10.3 Users Guide@@ -127,6 +130,9 @@       -trust=ghc-prim       -trust=random       -trust=splitmix+      -- JSON+      -trust=containers+      -trust=mtl   if impl(ghc >= 9.10 && < 9.15)     ghc-options:       -- Base@@ -139,6 +145,14 @@       base   hs-source-dirs:       src+  other-modules:+      -- +      Internal.GaloisInc.Text.JSON+      Internal.GaloisInc.Text.JSON.Generic+      Internal.GaloisInc.Text.JSON.String+      Internal.GaloisInc.Text.JSON.Types+      --+      Internal.GlasgowUniversity.Data.Generics.Aliases   exposed-modules:       Test.QuickCheck.Silent 

@@ -0,0 +1,537 @@+{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------------------++-- |+-- Copyright  : (c) 2007-2018 Galois Inc.+-- License    : BSD-3-Clause+-- Maintainer : Iavor S. Diatchki (iavor.diatchki@gmail.com)+-- Stability  : experimental+--+-- Serialising Haskell values to and from JSON values.++--------------------------------------------------------------------------------++module Internal.GaloisInc.Text.JSON (+    -- * JSON Types+    JSValue(..)++    -- * Serialization to and from JSValues+  , JSON(..)++    -- * Encoding and Decoding+  , Result(..)+  , encode -- :: JSON a => a -> String+  , decode -- :: JSON a => String -> Either String a+  , encodeStrict -- :: JSON a => a -> String+  , decodeStrict -- :: JSON a => String -> Either String a++    -- * Wrapper Types+  , JSString+  , toJSString+  , fromJSString++  , JSObject+  , toJSObject+  , fromJSObject+  , resultToEither++    -- * Serialization to and from Strings.+    -- ** Reading JSON+  , readJSNull, readJSBool, readJSString, readJSRational+  , readJSArray, readJSObject, readJSValue++    -- ** Writing JSON+  , showJSNull, showJSBool, showJSArray+  , showJSRational, showJSRational'+  , showJSObject, showJSValue++    -- ** Instance helpers+  , makeObj, valFromObj+  , JSKey(..), encJSDict, decJSDict+  +  ) where++import Internal.GaloisInc.Text.JSON.Types+import Internal.GaloisInc.Text.JSON.String++import Data.Int+import Data.Word++{- NOTE: [GHC-66111] [-Wunused-imports] The import of `Control.Monad.Fail' is+   redundant++import Control.Monad.Fail (MonadFail (..))++-}++import Control.Monad(liftM,ap,MonadPlus(..))+import Control.Applicative++{- NOTE: Non-Safe++import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L++-}++import qualified Data.IntSet as I+import qualified Data.Set as Set+import qualified Data.Map as M+import qualified Data.IntMap as IntMap++import qualified Data.Array as Array++{- NOTE: Non-Safe++import qualified Data.Text as T++-}++------------------------------------------------------------------------++-- | Decode a String representing a JSON value +-- (either an object, array, bool, number, null)+--+-- This is a superset of JSON, as types other than+-- Array and Object are allowed at the top level.+--+decode :: (JSON a) => String -> Result a+decode s = case runGetJSON readJSValue s of+             Right a  -> readJSON a+             Left err -> Error err++-- | Encode a Haskell value into a string, in JSON format.+--+-- This is a superset of JSON, as types other than+-- Array and Object are allowed at the top level.+--+encode :: (JSON a) => a -> String+encode = (flip showJSValue [] . showJSON)++------------------------------------------------------------------------++-- | Decode a String representing a strict JSON value.+-- This follows the spec, and requires top level+-- JSON types to be an Array or Object.+decodeStrict :: (JSON a) => String -> Result a+decodeStrict s = case runGetJSON readJSTopType s of+     Right a  -> readJSON a+     Left err -> Error err++-- | Encode a value as a String in strict JSON format.+-- This follows the spec, and requires all values+-- at the top level to be wrapped in either an Array or Object.+-- JSON types to be an Array or Object.+encodeStrict :: (JSON a) => a -> String+encodeStrict = (flip showJSTopType [] . showJSON)++------------------------------------------------------------------------++-- | The class of types serialisable to and from JSON+class JSON a where+  readJSON  :: JSValue -> Result a+  showJSON  :: a -> JSValue++  readJSONs :: JSValue -> Result [a]+  readJSONs (JSArray as) = mapM readJSON as+  readJSONs _            = mkError "Unable to read list"++  showJSONs :: [a] -> JSValue+  showJSONs = JSArray . map showJSON++-- | A type for parser results+data Result a = Ok a | Error String+  deriving (Eq,Show)++-- | Map Results to Eithers+resultToEither :: Result a -> Either String a+resultToEither (Ok a)    = Right a+resultToEither (Error s) = Left  s++instance Functor Result where fmap = liftM++{- NOTE: [GHC-22705] [-Wnoncanonical-monad-instances] Noncanonical `pure = return'+   definition detected in the instance declaration for `Applicative Result'.+   Suggested fix: Move definition from `return' to `pure'++instance Applicative Result where+  (<*>) = ap+  pure  = return++-}++instance Applicative Result where+  pure x = Ok x+  (<*>)  = ap++instance Alternative Result where+  Ok a    <|> _ = Ok a+  Error _ <|> b = b+  empty         = Error "empty"++instance MonadPlus Result where+  Ok a `mplus` _ = Ok a+  _ `mplus` x    = x+  mzero          = Error "Result: MonadPlus.empty"++{- NOTE: [GHC-22705] [-Wnoncanonical-monad-instances] Noncanonical `return'+   definition detected in the instance declaration for `Monad Result'.  `return'+   will eventually be removed in favour of `pure' Suggested fix: Either remove+   definition for `return' (recommended) or define as `return = pure++instance Monad Result where+  return x      = Ok x+  Ok a >>= f    = f a+  Error x >>= _ = Error x++-}++instance Monad Result where+  Ok a >>= f    = f a+  Error x >>= _ = Error x++instance MonadFail Result where+  fail x        = Error x++-- | Convenient error generation+mkError :: String -> Result a+mkError s = Error s++--------------------------------------------------------------------+--+-- | To ensure we generate valid JSON, we map Haskell types to JSValue+-- internally, then pretty print that.+--+instance JSON JSValue where+    showJSON = id+    readJSON = return++second :: (a -> b) -> (x,a) -> (x,b)+second f (a,b) = (a, f b)++--------------------------------------------------------------------+-- Some simple JSON wrapper types, to avoid overlapping instances++instance JSON JSString where+  readJSON (JSString s) = return s+  readJSON _            = mkError "Unable to read JSString"+  showJSON = JSString++instance (JSON a) => JSON (JSObject a) where+  readJSON (JSObject o) =+      let f (x,y) = do y' <- readJSON y; return (x,y')+      in toJSObject `fmap` mapM f (fromJSObject o)+  readJSON _ = mkError "Unable to read JSObject"+  showJSON = JSObject . toJSObject . map (second showJSON) . fromJSObject+++-- -----------------------------------------------------------------+-- Instances+--++instance JSON Bool where+  showJSON = JSBool+  readJSON (JSBool b) = return b+  readJSON _          = mkError "Unable to read Bool"++instance JSON Char where+  showJSON  = JSString . toJSString . (:[])+  showJSONs = JSString . toJSString++  readJSON (JSString s) = case fromJSString s of+                            [c] -> return c+                            _ -> mkError "Unable to read Char"+  readJSON _            = mkError "Unable to read Char"++  readJSONs (JSString s)  = return (fromJSString s)+  readJSONs (JSArray a)   = mapM readJSON a+  readJSONs _             = mkError "Unable to read String"++instance JSON Ordering where+  showJSON = encJSString show+  readJSON = decJSString "Ordering" readOrd+    where+     readOrd x = +       case x of+         "LT" -> return Prelude.LT+         "EQ" -> return Prelude.EQ+         "GT" -> return Prelude.GT+         _    -> mkError ("Unable to read Ordering")++-- -----------------------------------------------------------------+-- Integral types++instance JSON Integer where+  showJSON = JSRational False . fromIntegral+  readJSON (JSRational _ i) = return $ round i+  readJSON _             = mkError "Unable to read Integer"++-- constrained:+instance JSON Int where+  showJSON = JSRational False . fromIntegral+  readJSON (JSRational _ i) = return $ round i+  readJSON _              = mkError "Unable to read Int"++-- constrained:+instance JSON Word where+  showJSON = JSRational False . toRational+  readJSON (JSRational _ i) = return $ truncate i+  readJSON _             = mkError "Unable to read Word"++-- -----------------------------------------------------------------++instance JSON Word8 where+  showJSON = JSRational False . fromIntegral+  readJSON (JSRational _ i) = return $ truncate i+  readJSON _             = mkError "Unable to read Word8"++instance JSON Word16 where+  showJSON = JSRational False . fromIntegral+  readJSON (JSRational _ i) = return $ truncate i+  readJSON _             = mkError "Unable to read Word16"++instance JSON Word32 where+  showJSON = JSRational False . fromIntegral+  readJSON (JSRational _ i) = return $ truncate i+  readJSON _             = mkError "Unable to read Word32"++instance JSON Word64 where+  showJSON = JSRational False . fromIntegral+  readJSON (JSRational _ i) = return $ truncate i+  readJSON _             = mkError "Unable to read Word64"++instance JSON Int8 where+  showJSON = JSRational False . fromIntegral+  readJSON (JSRational _ i) = return $ truncate i+  readJSON _             = mkError "Unable to read Int8"++instance JSON Int16 where+  showJSON = JSRational False . fromIntegral+  readJSON (JSRational _ i) = return $ truncate i+  readJSON _             = mkError "Unable to read Int16"++instance JSON Int32 where+  showJSON = JSRational False . fromIntegral+  readJSON (JSRational _ i) = return $ truncate i+  readJSON _             = mkError "Unable to read Int32"++instance JSON Int64 where+  showJSON = JSRational False . fromIntegral+  readJSON (JSRational _ i) = return $ truncate i+  readJSON _                = mkError "Unable to read Int64"++-- -----------------------------------------------------------------++instance JSON Double where+  showJSON = JSRational False . toRational+  readJSON (JSRational _ r) = return $ fromRational r+  readJSON _                = mkError "Unable to read Double"+    -- can't use JSRational here, due to ambiguous '0' parse+    -- it will parse as Integer.++instance JSON Float where+  showJSON = JSRational True . toRational+  readJSON (JSRational _ r) = return $ fromRational r+  readJSON _                = mkError "Unable to read Float"++-- -----------------------------------------------------------------+-- Sums++instance (JSON a) => JSON (Maybe a) where+  readJSON (JSObject o) = case "Just" `lookup` as of+      Just x -> Just <$> readJSON x+      _      -> case ("Nothing" `lookup` as) of+          Just JSNull -> return Nothing+          _           -> mkError "Unable to read Maybe"+    where as = fromJSObject o+  readJSON _ = mkError "Unable to read Maybe"+  showJSON (Just x) = JSObject $ toJSObject [("Just", showJSON x)]+  showJSON Nothing  = JSObject $ toJSObject [("Nothing", JSNull)]++instance (JSON a, JSON b) => JSON (Either a b) where+  readJSON (JSObject o) = case "Left" `lookup` as of+      Just a  -> Left <$> readJSON a+      Nothing -> case "Right" `lookup` as of+          Just b  -> Right <$> readJSON b+          Nothing -> mkError "Unable to read Either"+    where as = fromJSObject o+  readJSON _ = mkError "Unable to read Either"+  showJSON (Left a)  = JSObject $ toJSObject [("Left",  showJSON a)]+  showJSON (Right b) = JSObject $ toJSObject [("Right", showJSON b)]++-- -----------------------------------------------------------------+-- Products++instance JSON () where+  showJSON _ = JSArray []+  readJSON (JSArray []) = return ()+  readJSON _      = mkError "Unable to read ()"++instance (JSON a, JSON b) => JSON (a,b) where+  showJSON (a,b) = JSArray [ showJSON a, showJSON b ]+  readJSON (JSArray [a,b]) = (,) `fmap` readJSON a `ap` readJSON b+  readJSON _ = mkError "Unable to read Pair"++instance (JSON a, JSON b, JSON c) => JSON (a,b,c) where+  showJSON (a,b,c) = JSArray [ showJSON a, showJSON b, showJSON c ]+  readJSON (JSArray [a,b,c]) = (,,) `fmap`+                                  readJSON a `ap`+                                  readJSON b `ap`+                                  readJSON c+  readJSON _ = mkError "Unable to read Triple"++instance (JSON a, JSON b, JSON c, JSON d) => JSON (a,b,c,d) where+  showJSON (a,b,c,d) = JSArray [showJSON a, showJSON b, showJSON c, showJSON d]+  readJSON (JSArray [a,b,c,d]) = (,,,) `fmap`+                                  readJSON a `ap`+                                  readJSON b `ap`+                                  readJSON c `ap`+                                  readJSON d++  readJSON _ = mkError "Unable to read 4 tuple"++-- -----------------------------------------------------------------+-- List-like types+++instance JSON a => JSON [a] where+  showJSON = showJSONs+  readJSON = readJSONs++-- container types:++#if !defined(MAP_AS_DICT)+instance (Ord a, JSON a, JSON b) => JSON (M.Map a b) where+  showJSON = encJSArray M.toList+  readJSON = decJSArray "Map" M.fromList++instance (JSON a) => JSON (IntMap.IntMap a) where+  showJSON = encJSArray IntMap.toList+  readJSON = decJSArray "IntMap" IntMap.fromList++#else+instance (Ord a, JSKey a, JSON b) => JSON (M.Map a b) where+  showJSON    = encJSDict . M.toList+  readJSON o  = M.fromList <$> decJSDict "Map" o++instance (JSON a) => JSON (IntMap.IntMap a) where+  {- alternate (dict) mapping: -}+  showJSON    = encJSDict . IntMap.toList+  readJSON o  = IntMap.fromList <$> decJSDict "IntMap" o+#endif+++instance (Ord a, JSON a) => JSON (Set.Set a) where+  showJSON = encJSArray Set.toList+  readJSON = decJSArray "Set" Set.fromList++instance (Array.Ix i, JSON i, JSON e) => JSON (Array.Array i e) where+  showJSON = encJSArray Array.assocs+  readJSON = decJSArray "Array" arrayFromList++instance JSON I.IntSet where+  showJSON = encJSArray I.toList+  readJSON = decJSArray "IntSet" I.fromList++-- helper functions for array / object serializers:+arrayFromList :: (Array.Ix i) => [(i,e)] -> Array.Array i e+arrayFromList [] = Array.array undefined []+arrayFromList ls@((i,_):xs) = Array.array bnds ls+  where+  bnds = foldr step (i,i) xs++  step (ix,_) (mi,ma) =+    let mi1 = min ix mi+        ma1 = max ix ma+    in mi1 `seq` ma1 `seq` (mi1,ma1)++{- NOTE: Non-Safe++-- -----------------------------------------------------------------+-- ByteStrings++instance JSON S.ByteString where+  showJSON = encJSString S.unpack+  readJSON = decJSString "ByteString" (return . S.pack)++instance JSON L.ByteString where+  showJSON = encJSString L.unpack+  readJSON = decJSString "Lazy.ByteString" (return . L.pack)++-- -----------------------------------------------------------------+-- Data.Text++instance JSON T.Text where+  readJSON (JSString s) = return (T.pack . fromJSString $ s)+  readJSON _            = mkError "Unable to read JSString"+  showJSON              = JSString . toJSString . T.unpack++-}++-- -----------------------------------------------------------------+-- Instance Helpers++makeObj :: [(String, JSValue)] -> JSValue+makeObj = JSObject . toJSObject++-- | Pull a value out of a JSON object.+valFromObj :: JSON a => String -> JSObject JSValue -> Result a+valFromObj k o = maybe (Error $ "valFromObj: Could not find key: " ++ show k)+                       readJSON+                       (lookup k (fromJSObject o))++encJSString :: (a -> String) -> a -> JSValue+encJSString f v = JSString (toJSString (f v))++decJSString :: String -> (String -> Result a) -> JSValue -> Result a+decJSString _ f (JSString s) = f (fromJSString s)+decJSString l _ _ = mkError ("readJSON{"++l++"}: unable to parse string value")++encJSArray :: (JSON a) => (b-> [a]) -> b -> JSValue+encJSArray f v = showJSON (f v)++decJSArray :: (JSON a) => String -> ([a] -> b) -> JSValue -> Result b+decJSArray _ f a@JSArray{} = f <$> readJSON a+decJSArray l _ _ = mkError ("readJSON{"++l++"}: unable to parse array value")++-- | Haskell types that can be used as keys in JSON objects.+class JSKey a where+  toJSKey   :: a -> String+  fromJSKey :: String -> Maybe a++instance JSKey JSString where+  toJSKey x   = fromJSString x+  fromJSKey x = Just (toJSString x)++instance JSKey Int where+  toJSKey   = show+  fromJSKey key = case reads key of+                    [(a,"")] -> Just a+                    _        -> Nothing++-- NOTE: This prevents us from making other instances for lists but,+-- our guess is that strings are used as keys more often then other list types.+instance JSKey String where+  toJSKey   = id+  fromJSKey = Just+  +-- | Encode an association list as 'JSObject' value.+encJSDict :: (JSKey a, JSON b) => [(a,b)] -> JSValue+encJSDict v = makeObj [ (toJSKey x, showJSON y) | (x,y) <- v ]++-- | Decode a 'JSObject' value into an association list.+decJSDict :: (JSKey a, JSON b)+          => String+          -> JSValue+          -> Result [(a,b)]+decJSDict l (JSObject o) = mapM rd (fromJSObject o)+  where rd (a,b) = case fromJSKey a of+                     Just pa -> readJSON b >>= \pb -> return (pa,pb)+                     Nothing -> mkError ("readJSON{" ++ l ++ "}:" +++                                    "unable to read dict; invalid object key")++decJSDict l _ = mkError ("readJSON{"++l ++ "}: unable to read dict; expected JSON object")

@@ -0,0 +1,241 @@+{-# LANGUAGE PatternGuards #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------------------++-- |+-- Copyright  : (c) 2007-2018 Galois Inc.+-- License    : BSD-3-Clause+-- Maintainer : Iavor S. Diatchki (iavor.diatchki@gmail.com)+-- Stability  : experimental+--+-- JSON serializer and deserializer using Data.Generics.+-- The functions here handle algebraic data types and primitive types.+-- It uses the same representation as "Internal.GaloisInc.Text.JSON" for "Prelude"+-- types.++--------------------------------------------------------------------------------++module Internal.GaloisInc.Text.JSON.Generic+    ( module Internal.GaloisInc.Text.JSON+    , Data+    , Typeable+    , toJSON+    , fromJSON+    , encodeJSON+    , decodeJSON++    , toJSON_generic+    , fromJSON_generic+    ) where++import Control.Monad.State+import Internal.GaloisInc.Text.JSON+import Internal.GaloisInc.Text.JSON.String ( runGetJSON )++{- NOTE: `Data.Generics` from `syb` just wraps `Data.Data` from `base`:+   https://github.com/dreixel/syb/blob/master/src/Data/Generics.hs+   https://hackage-content.haskell.org/package/syb-0.7.3/docs/Data-Generics.html+   https://hackage-content.haskell.org/package/base-4.19.2.0/docs/Data-Data.html++import Data.Generics++-}++import Data.Data++import Data.Word+import Data.Int++{- NOTE: Non-Safe++import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L++-}++import qualified Data.IntSet as I+-- FIXME: The JSON library treats this specially, needs ext2Q+-- import qualified Data.Map as M++import Internal.GlasgowUniversity.Data.Generics.Aliases++type T a = a -> JSValue++-- |Convert anything to a JSON value.+toJSON :: (Data a) => a -> JSValue+toJSON = toJSON_generic+         `ext1Q` jList+         -- Use the standard encoding for all base types.+         `extQ` (showJSON :: T Integer)+         `extQ` (showJSON :: T Int)+         `extQ` (showJSON :: T Word8)+         `extQ` (showJSON :: T Word16)+         `extQ` (showJSON :: T Word32)+         `extQ` (showJSON :: T Word64)+         `extQ` (showJSON :: T Int8)+         `extQ` (showJSON :: T Int16)+         `extQ` (showJSON :: T Int32)+         `extQ` (showJSON :: T Int64)+         `extQ` (showJSON :: T Double)+         `extQ` (showJSON :: T Float)+         `extQ` (showJSON :: T Char)+         `extQ` (showJSON :: T String)+         -- Bool has a special encoding.+         `extQ` (showJSON :: T Bool)+         `extQ` (showJSON :: T ())+         `extQ` (showJSON :: T Ordering)++         -- More special cases.+         `extQ` (showJSON :: T I.IntSet)+         +         {- NOTE: Non-Safe++         `extQ` (showJSON :: T S.ByteString)+         `extQ` (showJSON :: T L.ByteString)++         -}+  where+        -- Lists are simply coded as arrays.+        jList vs = JSArray $ map toJSON vs+++toJSON_generic :: (Data a) => a -> JSValue+toJSON_generic = generic+  where+        -- Generic encoding of an algebraic data type.+        --   No constructor, so it must be an error value.  Code it anyway as JSNull.+        --   Elide a single constructor and just code the arguments.+        --   For multiple constructors, make an object with a field name that is the+        --   constructor (except lower case) and the data is the arguments encoded.+        generic a =+            case dataTypeRep (dataTypeOf a) of+                AlgRep []  -> JSNull+                AlgRep [c] -> encodeArgs c (gmapQ toJSON a)+                AlgRep _   -> encodeConstr (toConstr a) (gmapQ toJSON a)+                rep        -> err (dataTypeOf a) rep+           where+              err dt r = error $ "toJSON: not AlgRep " ++ show r ++ "(" ++ show dt ++ ")"+        -- Encode nullary constructor as a string.+        -- Encode non-nullary constructors as an object with the constructor+        -- name as the single field and the arguments as the value.+        -- Use an array if the are no field names, but elide singleton arrays,+        -- and use an object if there are field names.+        encodeConstr c [] = JSString $ toJSString $ constrString c+        encodeConstr c as = jsObject [(constrString c, encodeArgs c as)]++        constrString = showConstr++        encodeArgs c = encodeArgs' (constrFields c)+        encodeArgs' [] [j] = j+        encodeArgs' [] js  = JSArray js+        encodeArgs' ns js  = jsObject $ zip (map mungeField ns) js++        -- Skip leading '_' in field name so we can use keywords etc. as field names.+        mungeField ('_':cs) = cs+        mungeField cs = cs++        jsObject :: [(String, JSValue)] -> JSValue+        jsObject = JSObject . toJSObject+++type F a = Result a++-- |Convert a JSON value to anything (fails if the types do not match).+fromJSON :: (Data a) => JSValue -> Result a+fromJSON j = fromJSON_generic j+             `ext1R` jList++             `extR` (value :: F Integer)+             `extR` (value :: F Int)+             `extR` (value :: F Word8)+             `extR` (value :: F Word16)+             `extR` (value :: F Word32)+             `extR` (value :: F Word64)+             `extR` (value :: F Int8)+             `extR` (value :: F Int16)+             `extR` (value :: F Int32)+             `extR` (value :: F Int64)+             `extR` (value :: F Double)+             `extR` (value :: F Float)+             `extR` (value :: F Char)+             `extR` (value :: F String)++             `extR` (value :: F Bool)+             `extR` (value :: F ())+             `extR` (value :: F Ordering)++             `extR` (value :: F I.IntSet)+         +             {- NOTE: Non-Safe++             `extR` (value :: F S.ByteString)+             `extR` (value :: F L.ByteString)++             -}+  where value :: (JSON a) => Result a+        value = readJSON j++        jList :: (Data e) => Result [e]+        jList = case j of+                JSArray js -> mapM fromJSON js+                _ -> Error $ "fromJSON: Prelude.[] bad data: " ++ show j++++fromJSON_generic :: (Data a) => JSValue -> Result a+fromJSON_generic j = generic+  where+        typ = dataTypeOf $ resType generic+        generic = case dataTypeRep typ of+                      AlgRep []  -> case j of JSNull -> return (error "Empty type"); _ -> Error $ "fromJSON: no-constr bad data"+                      AlgRep [_] -> decodeArgs (indexConstr typ 1) j+                      AlgRep _   -> do (c, j') <- getConstr typ j; decodeArgs c j'+                      rep        -> Error $ "fromJSON: " ++ show rep ++ "(" ++ show typ ++ ")"+        getConstr t (JSObject o) | [(s, j')] <- fromJSObject o = do c <- readConstr' t s; return (c, j')+        getConstr t (JSString js) = do c <- readConstr' t (fromJSString js); return (c, JSNull) -- handle nullare constructor+        getConstr _ _ = Error "fromJSON: bad constructor encoding"+        readConstr' t s =+          maybe (Error $ "fromJSON: unknown constructor: " ++ s ++ " " ++ show t)+                return $ readConstr t s++        decodeArgs c = decodeArgs' (numConstrArgs (resType generic) c) c (constrFields c)+        decodeArgs' 0 c  _       JSNull               = construct c []   -- nullary constructor+        decodeArgs' 1 c []       jd                   = construct c [jd] -- unary constructor+        decodeArgs' n c []       (JSArray js) | n > 1 = construct c js   -- no field names+        -- FIXME? We could allow reading an array into a constructor with field names.+        decodeArgs' _ c fs@(_:_) (JSObject o)         = selectFields (fromJSObject o) fs >>= construct c -- field names+        decodeArgs' _ c _        jd                   = Error $ "fromJSON: bad decodeArgs data " ++ show (c, jd)++        -- Build the value by stepping through the list of subparts.+        construct c = evalStateT $ fromConstrM f c+          where f :: (Data a) => StateT [JSValue] Result a+                f = do js <- get; case js of [] -> lift $ Error "construct: empty list"; j' : js' -> do put js'; lift $ fromJSON j'++        -- Select the named fields from a JSON object.  FIXME? Should this use a map?+        selectFields fjs = mapM sel+          where sel f = maybe (Error $ "fromJSON: field does not exist " ++ f) Ok $ lookup f fjs++        -- Count how many arguments a constructor has.  The value x is used to determine what type the constructor returns.+        numConstrArgs :: (Data a) => a -> Constr -> Int+        numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0+          where f = do modify (+1); return undefined++        resType :: Result a -> a+        resType _ = error "resType"++-- |Encode a value as a string.+encodeJSON :: (Data a) => a -> String+encodeJSON x = showJSValue (toJSON x) ""++-- |Decode a string as a value.+decodeJSON :: (Data a) => String -> a+decodeJSON s =+    case runGetJSON readJSValue s of+    Left msg -> error msg+    Right j ->+        case fromJSON j of+        Error msg -> error msg+        Ok x -> x

@@ -0,0 +1,412 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------------------++-- |+-- Copyright  : (c) 2007-2018 Galois Inc.+-- License    : BSD-3-Clause+-- Maintainer : Iavor S. Diatchki (iavor.diatchki@gmail.com)+-- Stability  : experimental+--+-- Basic support for working with JSON values.++--------------------------------------------------------------------------------++module Internal.GaloisInc.Text.JSON.String +     ( +       -- * Parsing+       --+       GetJSON+     , runGetJSON++       -- ** Reading JSON+     , readJSNull+     , readJSBool+     , readJSString+     , readJSRational+     , readJSArray+     , readJSObject++     , readJSValue+     , readJSTopType++       -- ** Writing JSON+     , showJSNull+     , showJSBool+     , showJSArray+     , showJSObject+     , showJSRational+     , showJSRational'++     , showJSValue+     , showJSTopType+     ) where++import Prelude hiding (fail)+import Internal.GaloisInc.Text.JSON.Types (JSValue(..),+                        JSString, toJSString, fromJSString,+                        JSObject, toJSObject, fromJSObject)++import Control.Monad (liftM, ap)+import Control.Monad.Fail (MonadFail (..))++{- NOTE: [GHC-66111] [-Wunused-imports] The import of `Control.Applicative' is+   redundant++import Control.Applicative((<$>))++-}++import qualified Control.Applicative as A++{- NOTE: [GHC-38856] [-Wunused-imports] The import of `digitToInt' from module+   `Data.Char' is redundant++import Data.Char (isSpace, isDigit, digitToInt)++-}++import Data.Char (isSpace, isDigit)++{- NOTE: [GHC-38856] [-Wunused-imports] The import of `%' from module `Data.Ratio'+   is redundant++import Data.Ratio (numerator, denominator, (%))++-}++import Data.Ratio (numerator, denominator)++{- NOTE: [GHC-38856] [-Wunused-imports] The import of `readDec' from module+   `Numeric' is redundant+++import Numeric (readHex, readDec, showHex, readSigned, readFloat)++-}++import Numeric (readHex, showHex, readSigned, readFloat)++-- -----------------------------------------------------------------+-- | Parsing JSON++-- | The type of JSON parsers for String+newtype GetJSON a = GetJSON { un :: String -> Either String (a,String) }++{- NOTE: [GHC-22705] [-Wnoncanonical-monad-instances] Noncanonical `pure = return'+   definition detected in the instance declaration for `Applicative GetJSON'.+   Suggested fix: Move definition from `return' to `pure'++instance Functor GetJSON where fmap = liftM+instance A.Applicative GetJSON where+  pure  = return+  (<*>) = ap++instance Monad GetJSON where+  return x        = GetJSON (\s -> Right (x,s))+  GetJSON m >>= f = GetJSON (\s -> case m s of+                                     Left err -> Left err+                                     Right (a,s1) -> un (f a) s1)++-}++instance Functor GetJSON where fmap = liftM+instance A.Applicative GetJSON where+  pure x = GetJSON (\s -> Right (x,s))+  (<*>)  = ap++instance Monad GetJSON where+  GetJSON m >>= f = GetJSON (\s -> case m s of+                                     Left err -> Left err+                                     Right (a,s1) -> un (f a) s1)++instance MonadFail GetJSON where+  fail x          = GetJSON (\_ -> Left x)++-- | Run a JSON reader on an input String, returning some Haskell value.+-- All input will be consumed.+runGetJSON :: GetJSON a -> String -> Either String a+runGetJSON (GetJSON m) s = case m s of+     Left err    -> Left err+     Right (a,t) -> case t of+                        [] -> Right a+                        _  -> Left $ "Invalid tokens at end of JSON string: "++ show (take 10 t)++getInput   :: GetJSON String+getInput    = GetJSON (\s -> Right (s,s))++setInput   :: String -> GetJSON ()+setInput s  = GetJSON (\_ -> Right ((),s))++-------------------------------------------------------------------------++-- | Find 8 chars context, for error messages+context :: String -> String+context s = take 8 s++-- | Read the JSON null type+readJSNull :: GetJSON JSValue+readJSNull = do+  xs <- getInput+  case xs of+    'n':'u':'l':'l':xs1 -> setInput xs1 >> return JSNull+    _ -> fail $ "Unable to parse JSON null: " ++ context xs++tryJSNull :: GetJSON JSValue -> GetJSON JSValue+tryJSNull k = do+  xs <- getInput+  case xs of+    'n':'u':'l':'l':xs1 -> setInput xs1 >> return JSNull+    _ -> k ++-- | Read the JSON Bool type+readJSBool :: GetJSON JSValue+readJSBool = do+  xs <- getInput+  case xs of+    't':'r':'u':'e':xs1 -> setInput xs1 >> return (JSBool True)+    'f':'a':'l':'s':'e':xs1 -> setInput xs1 >> return (JSBool False)+    _ -> fail $ "Unable to parse JSON Bool: " ++ context xs++-- | Read the JSON String type+readJSString :: GetJSON JSValue+readJSString = do+  x <- getInput+  case x of+       '"' : cs -> parse [] cs+       _        -> fail $ "Malformed JSON: expecting string: " ++ context x+ where +  parse rs cs = +    case cs of+      '\\' : c : ds -> esc rs c ds+      '"'  : ds     -> do setInput ds+                          return (JSString (toJSString (reverse rs)))+      c    : ds+       | c >= '\x20' && c <= '\xff'    -> parse (c:rs) ds+       | c < '\x20'     -> fail $ "Illegal unescaped character in string: " ++ context cs+       | i <= 0x10ffff  -> parse (c:rs) ds+       | otherwise -> fail $ "Illegal unescaped character in string: " ++ context cs+       where+        i = (fromIntegral (fromEnum c) :: Integer)+      _ -> fail $ "Unable to parse JSON String: unterminated String: " ++ context cs++  esc rs c cs = case c of+   '\\' -> parse ('\\' : rs) cs+   '"'  -> parse ('"'  : rs) cs+   'n'  -> parse ('\n' : rs) cs+   'r'  -> parse ('\r' : rs) cs+   't'  -> parse ('\t' : rs) cs+   'f'  -> parse ('\f' : rs) cs+   'b'  -> parse ('\b' : rs) cs+   '/'  -> parse ('/'  : rs) cs+   'u'  -> case cs of+             d1 : d2 : d3 : d4 : cs' ->+               case readHex [d1,d2,d3,d4] of+                 [(n,"")] -> parse (toEnum n : rs) cs'++                 x -> fail $ "Unable to parse JSON String: invalid hex: " ++ context (show x)+             _ -> fail $ "Unable to parse JSON String: invalid hex: " ++ context cs+   _ ->  fail $ "Unable to parse JSON String: invalid escape char: " ++ show c+++-- | Read an Integer or Double in JSON format, returning a Rational+readJSRational :: GetJSON Rational+readJSRational = do+  cs <- getInput+  case (reads cs, readSigned readFloat cs) of+    ([(x,_)], _)+      | isInfinite (x :: Double) ->+          fail ("JSON Rational out of range: " ++ context cs)+    (_, [(y,cs')]) -> setInput cs' >> return y+    _ -> fail ("Unable to parse JSON Rational: " ++ context cs)+++-- | Read a list in JSON format+readJSArray  :: GetJSON JSValue+readJSArray  = readSequence '[' ']' ',' >>= return . JSArray++-- | Read an object in JSON format+readJSObject :: GetJSON JSValue+readJSObject = readAssocs '{' '}' ',' >>= return . JSObject . toJSObject+++-- | Read a sequence of items+readSequence :: Char -> Char -> Char -> GetJSON [JSValue]+readSequence start end sep = do+  zs <- getInput+  case dropWhile isSpace zs of+    c : cs | c == start ->+        case dropWhile isSpace cs of+            d : ds | d == end -> setInput (dropWhile isSpace ds) >> return []+            ds                -> setInput ds >> parse []+    _ -> fail $ "Unable to parse JSON sequence: sequence stars with invalid character: " ++ context zs++  where parse rs = rs `seq` do+          a  <- readJSValue+          ds <- getInput+          case dropWhile isSpace ds of+            e : es | e == sep -> do setInput (dropWhile isSpace es)+                                    parse (a:rs)+                   | e == end -> do setInput (dropWhile isSpace es)+                                    return (reverse (a:rs))+            _ -> fail $ "Unable to parse JSON array: unterminated array: " ++ context ds+++-- | Read a sequence of JSON labelled fields+readAssocs :: Char -> Char -> Char -> GetJSON [(String,JSValue)]+readAssocs start end sep = do+  zs <- getInput+  case dropWhile isSpace zs of+    c:cs | c == start -> case dropWhile isSpace cs of+            d:ds | d == end -> setInput (dropWhile isSpace ds) >> return []+            ds              -> setInput ds >> parsePairs []+    _ -> fail "Unable to parse JSON object: unterminated object"++  where parsePairs rs = rs `seq` do+          a  <- do k  <- do x <- readJSString ; case x of+                                JSString s -> return (fromJSString s)+                                _          -> fail $ "Malformed JSON field labels: object keys must be quoted strings."+                   ds <- getInput+                   case dropWhile isSpace ds of+                       ':':es -> do setInput (dropWhile isSpace es)+                                    v <- readJSValue+                                    return (k,v)+                       _      -> fail $ "Malformed JSON labelled field: " ++ context ds++          ds <- getInput+          case dropWhile isSpace ds of+            e : es | e == sep -> do setInput (dropWhile isSpace es)+                                    parsePairs (a:rs)+                   | e == end -> do setInput (dropWhile isSpace es)+                                    return (reverse (a:rs))+            _ -> fail $ "Unable to parse JSON object: unterminated sequence: "+                            ++ context ds++-- | Read one of several possible JS types+readJSValue :: GetJSON JSValue+readJSValue = do+  cs <- getInput+  case cs of+    '"' : _ -> readJSString+    '[' : _ -> readJSArray+    '{' : _ -> readJSObject+    't' : _ -> readJSBool+    'f' : _ -> readJSBool+    (x:_) | isDigit x || x == '-' -> JSRational False <$> readJSRational+    xs -> tryJSNull+             (fail $ "Malformed JSON: invalid token in this context " ++ context xs)++-- | Top level JSON can only be Arrays or Objects+readJSTopType :: GetJSON JSValue+readJSTopType = do+  cs <- getInput+  case cs of+    '[' : _ -> readJSArray+    '{' : _ -> readJSObject+    _       -> fail "Invalid JSON: a JSON text a serialized object or array at the top level."++-- -----------------------------------------------------------------+-- | Writing JSON++-- | Show strict JSON top level types. Values not permitted+-- at the top level are wrapped in a singleton array.+showJSTopType :: JSValue -> ShowS+showJSTopType (JSArray a)    = showJSArray a+showJSTopType (JSObject o)   = showJSObject o+showJSTopType x              = showJSTopType $ JSArray [x]++-- | Show JSON values+showJSValue :: JSValue -> ShowS+showJSValue jv =+  case jv of+    JSNull{}         -> showJSNull+    JSBool b         -> showJSBool b+    JSRational asF r -> showJSRational' asF r+    JSArray a        -> showJSArray a+    JSString s       -> showJSString s+    JSObject o       -> showJSObject o++-- | Write the JSON null type+showJSNull :: ShowS+showJSNull = showString "null"++-- | Write the JSON Bool type+showJSBool :: Bool -> ShowS+showJSBool True  = showString "true"+showJSBool False = showString "false"++-- | Write the JSON String type+showJSString :: JSString -> ShowS+showJSString x xs = quote (encJSString x (quote xs))+  where+        quote = showChar '"'++-- | Show a Rational in JSON format+showJSRational :: Rational -> ShowS+showJSRational r = showJSRational' False r++showJSRational' :: Bool -> Rational -> ShowS+showJSRational' asFloat r + | denominator r == 1      = shows $ numerator r+ | isInfinite x || isNaN x = showJSNull+ | asFloat                 = shows xf+ | otherwise               = shows x+ where +   x :: Double+   x = realToFrac r+   +   xf :: Float+   xf = realToFrac r++++-- | Show a list in JSON format+showJSArray :: [JSValue] -> ShowS+showJSArray = showSequence '[' ']' ','++-- | Show an association list in JSON format+showJSObject :: JSObject JSValue -> ShowS+showJSObject = showAssocs '{' '}' ',' . fromJSObject++-- | Show a generic sequence of pairs in JSON format+showAssocs :: Char -> Char -> Char -> [(String,JSValue)] -> ShowS+showAssocs start end sep xs rest = start : go xs+  where+  go [(k,v)]     = '"' : encJSString (toJSString k)+                            ('"' : ':' : showJSValue v (go []))+  go ((k,v):kvs) = '"' : encJSString (toJSString k)+                            ('"' : ':' : showJSValue v (sep : go kvs))+  go []          = end : rest++-- | Show a generic sequence in JSON format+showSequence :: Char -> Char -> Char -> [JSValue] -> ShowS+showSequence start end sep xs rest = start : go xs+  where+  go [y]        = showJSValue y (go [])+  go (y:ys)     = showJSValue y (sep : go ys)+  go []         = end : rest++encJSString :: JSString -> ShowS+encJSString jss ss = go (fromJSString jss)+  where+  go s1 =+    case s1 of+      (x   :xs) | x < '\x20' -> '\\' : encControl x (go xs)+      ('"' :xs)              -> '\\' : '"'  : go xs+      ('\\':xs)              -> '\\' : '\\' : go xs+      (x   :xs)              -> x    : go xs+      ""                     -> ss++  encControl x xs = case x of+    '\b' -> 'b' : xs+    '\f' -> 'f' : xs+    '\n' -> 'n' : xs+    '\r' -> 'r' : xs+    '\t' -> 't' : xs+    _ | x < '\x10'   -> 'u' : '0' : '0' : '0' : hexxs+      | x < '\x100'  -> 'u' : '0' : '0' : hexxs+      | x < '\x1000' -> 'u' : '0' : hexxs+      | otherwise    -> 'u' : hexxs+      where hexxs = showHex (fromEnum x) xs+

@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveDataTypeable #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------------------++-- |+-- Copyright  : (c) 2007-2018 Galois Inc.+-- License    : BSD-3-Clause+-- Maintainer : Iavor S. Diatchki (iavor.diatchki@gmail.com)+-- Stability  : experimental+--+-- Basic support for working with JSON values.++--------------------------------------------------------------------------------++module Internal.GaloisInc.Text.JSON.Types (++    -- * JSON Types+    JSValue(..)++    -- * Wrapper Types+  , JSString({-fromJSString-}..)+  , toJSString++  , JSObject({-fromJSObject-}..)+  , toJSObject++  , get_field+  , set_field++  ) where++{- NOTE: [GHC-66111] [-Wunused-imports] The import of `Data.Typeable' is redundant++import Data.Typeable ( Typeable )++-}++import Data.String(IsString(..))++--+-- | JSON values+--+-- The type to which we encode Haskell values. There's a set+-- of primitives, and a couple of heterogenous collection types.+--+-- Objects:+--+-- An object structure is represented as a pair of curly brackets+-- surrounding zero or more name\/value pairs (or members).  A name is a+-- string.  A single colon comes after each name, separating the name+-- from the value.  A single comma separates a value from a+-- following name.+--+-- Arrays:+--+-- An array structure is represented as square brackets surrounding+-- zero or more values (or elements).  Elements are separated by commas.+--+-- Only valid JSON can be constructed this way+--+data JSValue+    = JSNull+    | JSBool     !Bool+    | JSRational Bool{-as Float?-} !Rational+    | JSString   JSString+    | JSArray    [JSValue]+    | JSObject   (JSObject JSValue)+    +    {- NOTE: [GHC-90584] [-Wderiving-typeable] Deriving `Typeable' has no effect: all+       types now auto-derive Typeable++    deriving (Show, Read, Eq, Ord, Typeable)++    -}++    deriving (Show, Read, Eq, Ord)++-- | Strings can be represented a little more efficiently in JSON+newtype JSString   = JSONString { fromJSString :: String }+    +    {- NOTE: [GHC-90584] [-Wderiving-typeable] Deriving `Typeable' has no effect: all+       types now auto-derive Typeable++    deriving (Show, Read, Eq, Ord, Typeable)++    -}+                   +    deriving (Eq, Ord, Show, Read)++-- | Turn a Haskell string into a JSON string.+toJSString :: String -> JSString+toJSString = JSONString+  -- Note: we don't encode the string yet, that's done when serializing.++instance IsString JSString where+  fromString = toJSString++instance IsString JSValue where+  fromString = JSString . fromString++-- | As can association lists+newtype JSObject e = JSONObject { fromJSObject :: [(String, e)] }+    +    {- NOTE: [GHC-90584] [-Wderiving-typeable] Deriving `Typeable' has no effect: all+       types now auto-derive Typeable++    deriving (Show, Read, Eq, Ord, Typeable)++    -}+                   +    deriving (Eq, Ord, Show, Read)++-- | Make JSON object out of an association list.+toJSObject :: [(String,a)] -> JSObject a+toJSObject = JSONObject++-- | Get the value of a field, if it exist.+get_field :: JSObject a -> String -> Maybe a+get_field (JSONObject xs) x = lookup x xs++-- | Set the value of a field.  Previous values are overwritten.+set_field :: JSObject a -> String -> a -> JSObject a+set_field (JSONObject xs) k v = JSONObject ((k,v) : filter ((/= k).fst) xs)

@@ -0,0 +1,754 @@+{-# LANGUAGE RankNTypes, CPP #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Aliases+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the LICENSE file)+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (local universal quantification)+--+-- This module provides a number of declarations for typical generic+-- function types, corresponding type case, and others.+--+-----------------------------------------------------------------------------++module Internal.GlasgowUniversity.Data.Generics.Aliases (++        -- * Combinators which create generic functions via cast+        --+        -- $castcombinators++        -- ** Transformations+        mkT,+        extT,+        -- ** Queries+        mkQ,+        extQ,+        -- ** Monadic transformations+        mkM,+        extM,+        -- ** MonadPlus transformations+        mkMp,+        extMp,+        -- ** Readers+        mkR,+        extR,+        -- ** Builders+        extB,+        -- ** Other+        ext0,+        -- * Types for generic functions+        -- ** Transformations+        GenericT,+        GenericT'(..),+        -- ** Queries+        GenericQ,+        GenericQ'(..),+        -- ** Monadic transformations+        GenericM,+        GenericM'(..),+        -- ** Readers+        GenericR,+        GenericR'(..),+        -- ** Builders+        GenericB,+        GenericB'(..),+        -- ** Other+        Generic,+        Generic'(..),++        -- * Ingredients of generic functions+        orElse,++        -- * Function combinators on generic functions+        recoverMp,+        recoverQ,+        choiceMp,+        choiceQ,++        -- * Type extension for unary type constructors+        ext1,+        ext1T,+        ext1M,+        ext1Q,+        ext1R,+        ext1B,++        -- * Type extension for binary type constructors+        ext2,+        ext2T,+        ext2M,+        ext2Q,+        ext2R,+        ext2B++  ) where++#ifdef __HADDOCK__+import Prelude+#endif+import Control.Monad+import Data.Data++------------------------------------------------------------------------------+--+--      Combinators to "make" generic functions+--      We use type-safe cast in a number of ways to make generic functions.+--+------------------------------------------------------------------------------++-- $castcombinators+--+-- Other programming languages sometimes provide an operator @instanceof@ which+-- can check whether an expression is an instance of a given type. This operator+-- allows programmers to implement a function @f :: forall a. a -> a@ which exhibits+-- a different behaviour depending on whether a `Bool` or a `Char` is passed.+-- In Haskell this is not the case: A function with type @forall a. a -> a@+-- can only be the identity function or a function which loops indefinitely+-- or throws an exception. That is, it must implement exactly the same behaviour+-- for any type at which it is used. But sometimes it is very useful to have+-- a function which can accept (almost) any type and exhibit a different behaviour+-- for different types. Haskell provides this functionality with the 'Typeable'+-- typeclass, whose instances can be automatically derived by GHC for almost all+-- types. This typeclass allows the definition of a functon 'cast' which has type+-- @forall a b. (Typeable a, Typeable b) => a -> Maybe b@. The 'cast' function allows+-- to implement a polymorphic function with different behaviour at different types:+--+-- >>> cast True :: Maybe Bool+-- Just True+--+-- >>> cast True :: Maybe Int+-- Nothing+--+-- This section provides combinators which make use of 'cast' internally to+-- provide various polymorphic functions with type-specific behaviour.+++-- | Extend the identity function with a type-specific transformation.+-- The function created by @mkT ext@ behaves like the identity function on all+-- arguments which cannot be cast to type @b@, and like the function @ext@ otherwise.+-- The name 'mkT' is short for "make transformation".+--+-- === __Examples__+--+-- >>> mkT not True+-- False+--+-- >>> mkT not 'a'+-- 'a'+--+-- @since 0.1.0.0+mkT :: ( Typeable a+       , Typeable b+       )+    => (b -> b)+    -- ^ The type-specific transformation+    -> a+    -- ^ The argument we try to cast to type @b@+    -> a+mkT = extT id+++-- | The function created by @mkQ def f@ returns the default result+-- @def@ if its argument cannot be cast to type @b@, otherwise it returns+-- the result of applying @f@ to its argument.+-- The name 'mkQ' is short for "make query".+--+-- === __Examples__+--+-- >>> mkQ "default" (show :: Bool -> String) True+-- "True"+--+-- >>> mkQ "default" (show :: Bool -> String) ()+-- "default"+--+-- @since 0.1.0.0+mkQ :: ( Typeable a+       , Typeable b+       )+    => r+    -- ^ The default result+    -> (b -> r)+    -- ^ The transformation to apply if the cast is successful+    -> a+    -- ^ The argument we try to cast to type @b@+    -> r+(r `mkQ` br) a = case cast a of+                        Just b  -> br b+                        Nothing -> r+++-- | Extend the default monadic action @pure :: Monad m => a -> m a@ by a type-specific+-- monadic action. The function created by @mkM act@ behaves like 'pure' if its+-- argument cannot be cast to type @b@, and like the monadic action @act@ otherwise.+-- The name 'mkM' is short for "make monadic transformation".+--+-- === __Examples__+--+-- >>> mkM (\x -> [x, not x]) True+-- [True,False]+--+-- >>> mkM (\x -> [x, not x]) (5 :: Int)+-- [5]+--+-- @since 0.1.0.0+mkM :: ( Monad m+       , Typeable a+       , Typeable b+       )+    => (b -> m b)+    -- ^ The type-specific monadic transformation+    -> a+    -- ^ The argument we try to cast to type @b@+    -> m a+mkM = extM return++-- | Extend the default 'MonadPlus' action @const mzero@ by a type-specific 'MonadPlus'+-- action. The function created by @mkMp act@ behaves like @const mzero@ if its argument+-- cannot be cast to type @b@, and like the monadic action @act@ otherwise.+-- The name 'mkMp' is short for "make MonadPlus transformation".+--+-- === __Examples__+--+-- >>> mkMp (\x -> Just (not x)) True+-- Just False+--+-- >>> mkMp (\x -> Just (not x)) 'a'+-- Nothing+--+-- @since 0.1.0.0+mkMp :: ( MonadPlus m+        , Typeable a+        , Typeable b+        )+     => (b -> m b)+     -- ^ The type-specific MonadPlus action+     -> a+     -- ^ The argument we try to cast to type @b@+     -> m a+mkMp = extM (const mzero)+++-- | Make a generic reader from a type-specific case.+-- The function created by @mkR f@ behaves like the reader @f@ if an expression+-- of type @a@ can be cast to type @b@, and like the expression @mzero@ otherwise.+-- The name 'mkR' is short for "make reader".+--+-- === __Examples__+--+-- >>> mkR (Just True) :: Maybe Bool+-- Just True+--+-- >>> mkR (Just True) :: Maybe Int+-- Nothing+--+-- @since 0.1.0.0+mkR :: ( MonadPlus m+       , Typeable a+       , Typeable b+       )+    => m b+    -- ^ The type-specific reader+    -> m a+mkR f = mzero `extR` f+++-- | Flexible type extension+--+-- === __Examples__+--+-- >>> ext0 [1 :: Int, 2, 3] [True, False] :: [Int]+-- [1,2,3]+--+-- >>> ext0 [1 :: Int, 2, 3] [4 :: Int, 5, 6] :: [Int]+-- [4,5,6]+--+-- @since 0.1.0.0+ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a+ext0 def ext = maybe def id (gcast ext)+++-- | Extend a generic transformation by a type-specific transformation.+-- The function created by @extT def ext@ behaves like the generic transformation+-- @def@ if its argument cannot be cast to the type @b@, and like the type-specific+-- transformation @ext@ otherwise.+-- The name 'extT' is short for "extend transformation".+--+-- === __Examples__+--+-- >>> extT id not True+-- False+--+-- >>> extT id not 'a'+-- 'a'+--+-- @since 0.1.0.0+extT :: ( Typeable a+        , Typeable b+        )+     => (a -> a)+     -- ^ The transformation we want to extend+     -> (b -> b)+     -- ^ The type-specific transformation+     -> a+     -- ^ The argument we try to cast to type @b@+     -> a+extT def ext = unT ((T def) `ext0` (T ext))+++-- | Extend a generic query by a type-specific query. The function created by @extQ def ext@ behaves+-- like the generic query @def@ if its argument cannot be cast to the type @b@, and like the type-specific+-- query @ext@ otherwise.+-- The name 'extQ' is short for "extend query".+--+-- === __Examples__+--+-- >>> extQ (const True) not True+-- False+--+-- >>> extQ (const True) not 'a'+-- True+--+-- @since 0.1.0.0+extQ :: ( Typeable a+        , Typeable b+        )+     => (a -> r)+     -- ^ The query we want to extend+     -> (b -> r)+     -- ^ The type-specific query+     -> a+     -- ^ The argument we try to cast to type @b@+     -> r+extQ f g a = maybe (f a) g (cast a)+++-- | Extend a generic monadic transformation by a type-specific case.+-- The function created by @extM def ext@ behaves like the monadic transformation+-- @def@ if its argument cannot be cast to type @b@, and like the monadic transformation+-- @ext@ otherwise.+-- The name 'extM' is short for "extend monadic transformation".+--+-- === __Examples__+--+-- >>> extM (\x -> [x,x])(\x -> [not x, x]) True+-- [False,True]+--+-- >>> extM (\x -> [x,x])(\x -> [not x, x]) (5 :: Int)+-- [5,5]+--+-- @since 0.1.0.0+extM :: ( Monad m+        , Typeable a+        , Typeable b+        )+     => (a -> m a)+     -- ^ The monadic transformation we want to extend+     -> (b -> m b)+     -- ^ The type-specific monadic transformation+     -> a+     -- ^ The argument we try to cast to type @b@+     -> m a+extM def ext = unM ((M def) `ext0` (M ext))+++-- | Extend a generic MonadPlus transformation by a type-specific case.+-- The function created by @extMp def ext@ behaves like 'MonadPlus' transformation @def@+-- if its argument cannot be cast to type @b@, and like the transformation @ext@ otherwise.+-- Note that 'extMp' behaves exactly like 'extM'.+-- The name 'extMp' is short for "extend MonadPlus transformation".+--+-- === __Examples__+--+-- >>> extMp (\x -> [x,x])(\x -> [not x, x]) True+-- [False,True]+--+-- >>> extMp (\x -> [x,x])(\x -> [not x, x]) (5 :: Int)+-- [5,5]+--+-- @since 0.1.0.0+extMp :: ( MonadPlus m+         , Typeable a+         , Typeable b+         )+      => (a -> m a)+      -- ^ The 'MonadPlus' transformation we want to extend+      -> (b -> m b)+      -- ^ The type-specific 'MonadPlus' transformation+      -> a+      -- ^ The argument we try to cast to type @b@+      -> m a+extMp = extM+++-- | Extend a generic builder by a type-specific case.+-- The builder created by @extB def ext@ returns @def@ if @ext@ cannot be cast+-- to type @a@, and like @ext@ otherwise.+-- The name 'extB' is short for "extend builder".+--+-- === __Examples__+--+-- >>> extB True 'a'+-- True+--+-- >>> extB True False+-- False+--+-- @since 0.1.0.0+extB :: ( Typeable a+        , Typeable b+        )+     => a+     -- ^ The default result+     -> b+     -- ^ The argument we try to cast to type @a@+     -> a+extB a = maybe a id . cast+++-- | Extend a generic reader by a type-specific case.+-- The reader created by @extR def ext@ behaves like the reader @def@+-- if expressions of type @b@ cannot be cast to type @a@, and like the+-- reader @ext@ otherwise.+-- The name 'extR' is short for "extend reader".+--+-- === __Examples__+--+-- >>> extR (Just True) (Just 'a')+-- Just True+--+-- >>> extR (Just True) (Just False)+-- Just False+--+-- @since 0.1.0.0+extR :: ( Monad m+        , Typeable a+        , Typeable b+        )+     => m a+     -- ^ The generic reader we want to extend+     -> m b+     -- ^ The type-specific reader+     -> m a+extR def ext = unR ((R def) `ext0` (R ext))++++------------------------------------------------------------------------------+--+--      Types for generic functions+--+------------------------------------------------------------------------------+++-- | Generic transformations,+--   i.e., take an \"a\" and return an \"a\"+--+-- @since 0.1.0.0+type GenericT = forall a. Data a => a -> a++-- | The type synonym `GenericT` has a polymorphic type, and can therefore not+--   appear in places where monomorphic types are expected, for example in a list.+--   The newtype `GenericT'` wraps `GenericT` in a newtype to lift this restriction.+--+-- @since 0.1.0.0+newtype GenericT' = GT { unGT :: GenericT }++-- | Generic queries of type \"r\",+--   i.e., take any \"a\" and return an \"r\"+--+-- @since 0.1.0.0+type GenericQ r = forall a. Data a => a -> r++-- | The type synonym `GenericQ` has a polymorphic type, and can therefore not+--   appear in places where monomorphic types are expected, for example in a list.+--   The newtype `GenericQ'` wraps `GenericQ` in a newtype to lift this restriction.+--+-- @since 0.1.0.0+newtype GenericQ' r = GQ { unGQ :: GenericQ r }++-- | Generic monadic transformations,+--   i.e., take an \"a\" and compute an \"a\"+--+-- @since 0.1.0.0+type GenericM m = forall a. Data a => a -> m a++-- | The type synonym `GenericM` has a polymorphic type, and can therefore not+--   appear in places where monomorphic types are expected, for example in a list.+--   The newtype `GenericM'` wraps `GenericM` in a newtype to lift this restriction.+--+-- @since 0.1.0.0+newtype GenericM' m = GM { unGM :: GenericM m }++-- | Generic builders+--   i.e., produce an \"a\".+--+-- @since 0.1.0.0+type GenericB = forall a. Data a => a++-- | The type synonym `GenericB` has a polymorphic type, and can therefore not+--   appear in places where monomorphic types are expected, for example in a list.+--   The data type `GenericB'` wraps `GenericB` in a data type to lift this restriction.+--+-- @since 0.7.3+newtype GenericB' = GenericB' { unGenericB' :: GenericB }++-- | Generic readers, say monadic builders,+--   i.e., produce an \"a\" with the help of a monad \"m\".+--+-- @since 0.1.0.0+type GenericR m = forall a. Data a => m a++-- | The type synonym `GenericR` has a polymorphic type, and can therefore not+--   appear in places where monomorphic types are expected, for example in a list.+--   The data type `GenericR'` wraps `GenericR` in a data type to lift this restriction.+--+-- @since 0.7.3+newtype GenericR' m = GenericR' { unGenericR' :: GenericR m }++-- | The general scheme underlying generic functions+--   assumed by gfoldl; there are isomorphisms such as+--   GenericT = Generic T.+--+-- @since 0.1.0.0+type Generic c = forall a. Data a => a -> c a+++-- | The type synonym `Generic` has a polymorphic type, and can therefore not+--   appear in places where monomorphic types are expected, for example in a list.+--   The data type `Generic'` wraps `Generic` in a data type to lift this restriction.+--+-- @since 0.1.0.0+newtype Generic' c = Generic' { unGeneric' :: Generic c }++------------------------------------------------------------------------------+--+-- Ingredients of generic functions+--+------------------------------------------------------------------------------++-- | Left-biased choice on maybes+--+-- === __Examples__+--+-- >>> orElse Nothing Nothing+-- Nothing+--+-- >>> orElse Nothing (Just 'a')+-- Just 'a'+--+-- >>> orElse (Just 'a') Nothing+-- Just 'a'+--+-- >>> orElse (Just 'a') (Just 'b')+-- Just 'a'+--+-- @since 0.1.0.0+orElse :: Maybe a -> Maybe a -> Maybe a+x `orElse` y = case x of+                 Just _  -> x+                 Nothing -> y+++------------------------------------------------------------------------------+--+-- Function combinators on generic functions+--+------------------------------------------------------------------------------+{-++The following variations take "orElse" to the function+level. Furthermore, we generalise from "Maybe" to any+"MonadPlus". This makes sense for monadic transformations and+queries. We say that the resulting combinators modell choice. We also+provide a prime example of choice, that is, recovery from failure. In+the case of transformations, we recover via return whereas for+queries a given constant is returned.++-}++-- | Choice for monadic transformations+--+-- @since 0.1.0.0+choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m+choiceMp f g x = f x `mplus` g x+++-- | Choice for monadic queries+--+-- @since 0.1.0.0+choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r)+choiceQ f g x = f x `mplus` g x+++-- | Recover from the failure of monadic transformation by identity+--+-- @since 0.1.0.0+recoverMp :: MonadPlus m => GenericM m -> GenericM m+recoverMp f = f `choiceMp` return+++-- | Recover from the failure of monadic query by a constant+--+-- @since 0.1.0.0+recoverQ :: MonadPlus m => r -> GenericQ (m r) -> GenericQ (m r)+recoverQ r f = f `choiceQ` const (return r)++++------------------------------------------------------------------------------+--      Type extension for unary type constructors+------------------------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 707+#define Typeable1 Typeable+#define Typeable2 Typeable+#endif++-- | Flexible type extension+--+-- @since 0.3+ext1 :: (Data a, Typeable1 t)+     => c a+     -> (forall d. Data d => c (t d))+     -> c a+ext1 def ext = maybe def id (dataCast1 ext)+++-- | Type extension of transformations for unary type constructors+--+-- @since 0.1.0.0+ext1T :: (Data d, Typeable1 t)+      => (forall e. Data e => e -> e)+      -> (forall f. Data f => t f -> t f)+      -> d -> d+ext1T def ext = unT ((T def) `ext1` (T ext))+++-- | Type extension of monadic transformations for type constructors+--+-- @since 0.1.0.0+ext1M :: (Monad m, Data d, Typeable1 t)+      => (forall e. Data e => e -> m e)+      -> (forall f. Data f => t f -> m (t f))+      -> d -> m d+ext1M def ext = unM ((M def) `ext1` (M ext))+++-- | Type extension of queries for type constructors+--+-- @since 0.1.0.0+ext1Q :: (Data d, Typeable1 t)+      => (d -> q)+      -> (forall e. Data e => t e -> q)+      -> d -> q+ext1Q def ext = unQ ((Q def) `ext1` (Q ext))+++-- | Type extension of readers for type constructors+--+-- @since 0.1.0.0+ext1R :: (Monad m, Data d, Typeable1 t)+      => m d+      -> (forall e. Data e => m (t e))+      -> m d+ext1R def ext = unR ((R def) `ext1` (R ext))+++-- | Type extension of builders for type constructors+--+-- @since 0.2+ext1B :: (Data a, Typeable1 t)+      => a+      -> (forall b. Data b => (t b))+      -> a+ext1B def ext = unB ((B def) `ext1` (B ext))++------------------------------------------------------------------------------+--      Type extension for binary type constructors+------------------------------------------------------------------------------++-- | Flexible type extension+ext2 :: (Data a, Typeable2 t)+     => c a+     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))+     -> c a+ext2 def ext = maybe def id (dataCast2 ext)+++-- | Type extension of transformations for unary type constructors+--+-- @since 0.3+ext2T :: (Data d, Typeable2 t)+      => (forall e. Data e => e -> e)+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> t d1 d2)+      -> d -> d+ext2T def ext = unT ((T def) `ext2` (T ext))+++-- | Type extension of monadic transformations for type constructors+--+-- @since 0.3+ext2M :: (Monad m, Data d, Typeable2 t)+      => (forall e. Data e => e -> m e)+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2))+      -> d -> m d+ext2M def ext = unM ((M def) `ext2` (M ext))+++-- | Type extension of queries for type constructors+--+-- @since 0.3+ext2Q :: (Data d, Typeable2 t)+      => (d -> q)+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)+      -> d -> q+ext2Q def ext = unQ ((Q def) `ext2` (Q ext))+++-- | Type extension of readers for type constructors+--+-- @since 0.3+ext2R :: (Monad m, Data d, Typeable2 t)+      => m d+      -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))+      -> m d+ext2R def ext = unR ((R def) `ext2` (R ext))+++-- | Type extension of builders for type constructors+--+-- @since 0.3+ext2B :: (Data a, Typeable2 t)+      => a+      -> (forall d1 d2. (Data d1, Data d2) => (t d1 d2))+      -> a+ext2B def ext = unB ((B def) `ext2` (B ext))++------------------------------------------------------------------------------+--+--      Type constructors for type-level lambdas+--+------------------------------------------------------------------------------+++-- | The type constructor for transformations+newtype T x = T { unT :: x -> x }++-- | The type constructor for transformations+newtype M m x = M { unM :: x -> m x }++-- | The type constructor for queries+newtype Q q x = Q { unQ :: x -> q }++-- | The type constructor for readers+newtype R m x = R { unR :: m x }++-- | The type constructor for builders+newtype B x = B {unB :: x}

@@ -3,6 +3,8 @@ {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe                         #-} +{-# LANGUAGE DeriveDataTypeable           #-}+ --------------------------------------------------------------------------------  -- |@@ -16,36 +18,112 @@ --------------------------------------------------------------------------------  module Test.QuickCheck.Silent-  ( -- * Property without IO-    SilentProp ()+  ( -- * Declaring tests+    Test (Case, Group)+  , Label+    -- * Property without IO+  , SilentProp ()+  , property   , silent-  , Test.QuickCheck.Silent.withNumTests+  , withNumTests     -- * Running tests+  , JSON+  , Status(..)   , Result(..)   , quickCheckSilent+  , quickCheckSilentSuite+  , quickCheckSilentSuiteJSON+  , isSuccess   ) where  -------------------------------------------------------------------------------- +import           Data.Data                            ( Data )+import           Data.List                            ( isPrefixOf )++import qualified Test.QuickCheck                      as QC import           Test.QuickCheck   ( Property-  , Result (..)   , Testable   , chatty-  , property-  , quickCheckWithResult   , stdArgs-  , withNumTests   ) +import           Internal.GaloisInc.Text.JSON.Generic ( encodeJSON )+ --------------------------------------------------------------------------------  -- | A `Testable` silent property.-newtype SilentProp = SilentProp { prop :: Property }+newtype SilentProp =+  SilentProp+    { property :: Property+      -- ^ Unwrap the the silent property.+    }  -------------------------------------------------------------------------------- +-- | A name or description for a case or a subtree of the @Test@s.+type Label = String++-- | The basic structure used to create an annotated tree of test cases.+data Test+  -- | A set of @Test@s sharing the same level in the hierarchy.+  = Group !Label ![Test]+  -- | A single, independent test case composed.+  | Case  !Label !SilentProp++--------------------------------------------------------------------------------++-- | Status represents the outcome of a test+data Status+  -- | A successful test run+  = Success+  -- | A failed test run+  | Failure+  -- | Given up+  | Desisted+  -- | A property that should have failed did not+  | NoFailure+  deriving Data++instance Show Status where+  show Desisted  = "desisted"+  show Failure   = "failure"+  show NoFailure = "nofailure"+  show Success   = "success"++-- | Result represents the test result+data Result =+  Result+    { status       :: !Status+      -- ^ Outcome of the test+    , numTests     :: !Int+      -- ^ Number of tests performed+    , numDiscarded :: !Int+      -- ^ Number of tests skipped+    , output       :: !String+      -- ^ Non-printed output+    , reason       :: !String+      -- ^ If the property failed, why?+    }+  deriving (Data, Show)++data LabelResultJSON =+  LabelResultJSON+    { label  :: !Label+    , result :: !Result+    }+  deriving (Data, Show)++-- | A 'JSON' payload string that represents the test 'Result' with its+-- respective 'Label'+--+-- > { "label": "…", "result": { "status": "…", …, "reason": "…" } }+type JSON = String++--------------------------------------------------------------------------------+ -- | Convert a `Testable` thing, without 'System.IO.IO' effects, to a silent -- property. silent@@ -53,11 +131,7 @@   => prop   -> SilentProp silent =-  SilentProp . property--{----}+  SilentProp . QC.property  -- | Configures how many times a silent property will be tested. --@@ -72,7 +146,7 @@   -> prop   -> SilentProp withNumTests n =-  SilentProp . Test.QuickCheck.withNumTests n+  SilentProp . QC.withNumTests n  -------------------------------------------------------------------------------- @@ -82,7 +156,124 @@   :: [SilentProp]   -> IO [Result] quickCheckSilent =-  mapM (aux . prop)+  mapM (\ p -> (aux . property) p >>= pure . result_)   where     aux =-      quickCheckWithResult $ stdArgs { chatty = False }+      QC.quickCheckWithResult $ stdArgs { chatty = False }++-- | Tests a suite of silent properties, producing a list of results with their+-- respective labels and without printing them to 'System.IO.stdout'.+--+-- For example,+--+-- > check =+-- >   quickCheckSilentSuite sep pat tcs+-- >   where+-- >     sep = '.'+-- >     pat = "Test.QuickCheck.Silent"+-- >     tcs =+-- >       Group "Test"+-- >         [ Group "QuickCheck"+-- >           [ Group "Silent"+-- >             [ Case "foo" (withNumTests  100 p)+-- >             , Case "bar" (withNumTests 1000 q)+-- >             ]+-- >           , Group "OtherModule"+-- >             [ Case "baz" (withNumTests   10 r)+-- >             ]+-- >           ]+-- >         ]+--+-- will test both @p@ and @q@, but not @r@.+--+-- The provided @pattern@, will be checked if it 'Data.List.isPrefixOf' of each+-- @label@:+--+-- > pattern `isPrefixOf` label+--+-- @NOTE@: To test all cases, just provide an empty string as @pattern@ as it's+-- a prefix for all possible @labels@.+quickCheckSilentSuite+  :: Char+  -> String+  -> Test+  -> IO [(Label, Result)]+quickCheckSilentSuite sep pat suite =+  mapM+    ( \ (l, sp) ->+        (aux . property) sp >>= \ r ->+        pure (l, result_ r)+    )+  $ filter ( \(l, _) -> pat `isPrefixOf` l)+  $ dfs [] suite+  where+    dfs [ ] (Group l ts) = concatMap (dfs (                l)) ts+    dfs acc (Group l ts) = concatMap (dfs (acc ++ [sep] ++ l)) ts+    dfs [ ] (Case  l p)  = [              (                l, p)]+    dfs acc (Case  l p)  = [              (acc ++ [sep] ++ l, p)]+    aux =+      QC.quickCheckWithResult $ stdArgs { chatty = False }++-- | Same behavior as 'quickCheckSilentSuite', but, producing a 'JSON' data+-- payload instead.+quickCheckSilentSuiteJSON+  :: Char+  -> String+  -> Test+  -> IO [JSON]+quickCheckSilentSuiteJSON sep pat suite =+  ( \ lrs ->+      map+      ( \ (l, r) ->+          encodeJSON $ LabelResultJSON l r+      )+      lrs+  )+  <$> quickCheckSilentSuite sep pat suite++-- | Check if the test run result was a success+isSuccess :: Result -> Bool+isSuccess Result { status = Success } = True+isSuccess ___________________________ = False++--------------------------------------------------------------------------------++-- HELPERS++result_+  :: QC.Result+  -> Result+result_ res =+  case res of+    QC.Success t d _ _ _ o ->+      Result+        { status                              = Success+        , Test.QuickCheck.Silent.numTests     = t+        , Test.QuickCheck.Silent.numDiscarded = d+        , Test.QuickCheck.Silent.output       = o+        , Test.QuickCheck.Silent.reason       = []+        }+    QC.GaveUp t d _ _ _ o ->+      Result+        { status                              = Desisted+        , Test.QuickCheck.Silent.numTests     = t+        , Test.QuickCheck.Silent.numDiscarded = d+        , Test.QuickCheck.Silent.output       = o+        , Test.QuickCheck.Silent.reason       = []+        }+    QC.Failure t d _ _ _ _ _ r _ o _ _ _ _ ->+      Result+        { status                              = Failure+        , Test.QuickCheck.Silent.numTests     = t+        , Test.QuickCheck.Silent.numDiscarded = d+        , Test.QuickCheck.Silent.output       = o+        , Test.QuickCheck.Silent.reason       = r+        }+    QC.NoExpectedFailure t d _ _ _ o ->+      Result+        { status                              = NoFailure+        , Test.QuickCheck.Silent.numTests     = t+        , Test.QuickCheck.Silent.numDiscarded = d+        , Test.QuickCheck.Silent.output       = o+        , Test.QuickCheck.Silent.reason       = []+        }