1 {-# LANGUAGE CPP, MultiParamTypeClasses,
    2              FlexibleInstances, TypeSynonymInstances #-}
    3 --
    4 -- Uses multi-param type classes
    5 --
    6 module QuickCheckUtils where
    7 
    8 import Test.QuickCheck
    9 import Text.Show.Functions
   10 
   11 import Control.Monad        ( liftM2 )
   12 import Control.Monad.Instances
   13 import Data.Char
   14 import Data.List
   15 import Data.Word
   16 import Data.Int
   17 import System.Random
   18 import System.IO
   19 import Foreign.C (CChar)
   20 
   21 import qualified Data.ByteString      as P
   22 import qualified Data.ByteString.Lazy as L
   23 import qualified Data.ByteString.Lazy.Internal as L (checkInvariant,ByteString(..))
   24 
   25 import qualified Data.ByteString.Char8      as PC
   26 import qualified Data.ByteString.Lazy.Char8 as LC
   27 
   28 ------------------------------------------------------------------------
   29 
   30 integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
   31 integralRandomR  (a,b) g = case randomR (fromIntegral a :: Integer,
   32                                          fromIntegral b :: Integer) g of
   33                             (x,g) -> (fromIntegral x, g)
   34 
   35 sizedByteString n = do m <- choose(0, n)
   36                        fmap P.pack $ vectorOf m arbitrary
   37 
   38 instance Arbitrary P.ByteString where
   39   arbitrary = do
   40     bs <- sized sizedByteString
   41     n  <- choose (0, 2)
   42     return (P.drop n bs) -- to give us some with non-0 offset
   43 
   44 instance CoArbitrary P.ByteString where
   45   coarbitrary s = coarbitrary (P.unpack s)
   46 
   47 instance Arbitrary L.ByteString where
   48   arbitrary = sized $ \n -> do numChunks <- choose (0, n)
   49                                if numChunks == 0
   50                                    then return L.empty
   51                                    else fmap (L.checkInvariant .
   52                                               L.fromChunks .
   53                                               filter (not . P.null)) $
   54                                             vectorOf numChunks
   55                                                      (sizedByteString
   56                                                           (n `div` numChunks))
   57 
   58 instance CoArbitrary L.ByteString where
   59   coarbitrary s = coarbitrary (L.unpack s)
   60 
   61 newtype CByteString = CByteString P.ByteString
   62   deriving Show
   63 
   64 instance Arbitrary CByteString where
   65   arbitrary = fmap (CByteString . P.pack . map fromCChar) arbitrary
   66     where
   67       fromCChar :: CChar -> Word8
   68       fromCChar = fromIntegral
   69 
   70 instance Arbitrary CChar where
   71   arbitrary = fmap (fromIntegral :: Int -> CChar)
   72             $ oneof [choose (-128,-1), choose (1,127)]
   73 
   74 ------------------------------------------------------------------------
   75 --
   76 -- We're doing two forms of testing here. Firstly, model based testing.
   77 -- For our Lazy and strict bytestring types, we have model types:
   78 --
   79 --  i.e.    Lazy    ==   Byte
   80 --              \\      //
   81 --                 List 
   82 --
   83 -- That is, the Lazy type can be modeled by functions in both the Byte
   84 -- and List type. For each of the 3 models, we have a set of tests that
   85 -- check those types match.
   86 --
   87 -- The Model class connects a type and its model type, via a conversion
   88 -- function. 
   89 --
   90 --
   91 class Model a b where
   92   model :: a -> b  -- get the abstract vale from a concrete value
   93 
   94 --
   95 -- Connecting our Lazy and Strict types to their models. We also check
   96 -- the data invariant on Lazy types.
   97 --
   98 -- These instances represent the arrows in the above diagram
   99 --
  100 instance Model B P      where model = abstr . checkInvariant
  101 instance Model P [W]    where model = P.unpack
  102 instance Model P [Char] where model = PC.unpack
  103 instance Model B [W]    where model = L.unpack  . checkInvariant
  104 instance Model B [Char] where model = LC.unpack . checkInvariant
  105 instance Model Char Word8 where model = fromIntegral . ord
  106 
  107 -- Types are trivially modeled by themselves
  108 instance Model Bool  Bool         where model = id
  109 instance Model Int   Int          where model = id
  110 instance Model P     P            where model = id
  111 instance Model B     B            where model = id
  112 instance Model Int64 Int64        where model = id
  113 instance Model Word8 Word8        where model = id
  114 instance Model Ordering Ordering  where model = id
  115 instance Model Char Char  where model = id
  116 
  117 -- More structured types are modeled recursively, using the NatTrans class from Gofer.
  118 class (Functor f, Functor g) => NatTrans f g where
  119     eta :: f a -> g a
  120 
  121 -- The transformation of the same type is identity
  122 instance NatTrans [] []             where eta = id
  123 instance NatTrans Maybe Maybe       where eta = id
  124 instance NatTrans ((->) X) ((->) X) where eta = id
  125 instance NatTrans ((->) Char) ((->) Char) where eta = id
  126 
  127 instance NatTrans ((->) W) ((->) W) where eta = id
  128 
  129 -- We have a transformation of pairs, if the pairs are in Model
  130 instance Model f g => NatTrans ((,) f) ((,) g) where eta (f,a) = (model f, a)
  131 
  132 -- And finally, we can take any (m a) to (n b), if we can Model m n, and a b
  133 instance (NatTrans m n, Model a b) => Model (m a) (n b) where model x = fmap model (eta x)
  134 
  135 ------------------------------------------------------------------------
  136 
  137 -- In a form more useful for QC testing (and it's lazy)
  138 checkInvariant :: L.ByteString -> L.ByteString
  139 checkInvariant = L.checkInvariant
  140 
  141 abstr :: L.ByteString -> P.ByteString
  142 abstr = P.concat . L.toChunks 
  143 
  144 -- Some short hand.
  145 type X = Int
  146 type W = Word8
  147 type P = P.ByteString
  148 type B = L.ByteString
  149 
  150 ------------------------------------------------------------------------
  151 --
  152 -- These comparison functions handle wrapping and equality.
  153 --
  154 -- A single class for these would be nice, but note that they differe in
  155 -- the number of arguments, and those argument types, so we'd need HList
  156 -- tricks. See here: http://okmij.org/ftp/Haskell/vararg-fn.lhs
  157 --
  158 
  159 eq1 f g = \a         ->
  160     model (f a)         == g (model a)
  161 eq2 f g = \a b       ->
  162     model (f a b)       == g (model a) (model b)
  163 eq3 f g = \a b c     ->
  164     model (f a b c)     == g (model a) (model b) (model c)
  165 
  166 --
  167 -- And for functions that take non-null input
  168 --
  169 eqnotnull1 f g = \x     -> (not (isNull x)) ==> eq1 f g x
  170 eqnotnull2 f g = \x y   -> (not (isNull y)) ==> eq2 f g x y
  171 eqnotnull3 f g = \x y z -> (not (isNull z)) ==> eq3 f g x y z
  172 
  173 class    IsNull t            where isNull :: t -> Bool
  174 instance IsNull L.ByteString where isNull = L.null
  175 instance IsNull P.ByteString where isNull = P.null