{-# LANGUAGE CPP, MultiParamTypeClasses,
             FlexibleInstances, TypeSynonymInstances #-}
--
-- Uses multi-param type classes
--
module QuickCheckUtils where

import Test.QuickCheck
import Text.Show.Functions

import Control.Monad        ( liftM2 )
import Control.Monad.Instances
import Data.Char
import Data.List
import Data.Word
import Data.Int
import System.Random
import System.IO
import Foreign.C (CChar)

import qualified Data.ByteString      as P
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Internal as L (checkInvariant,ByteString(..))

import qualified Data.ByteString.Char8      as PC
import qualified Data.ByteString.Lazy.Char8 as LC

------------------------------------------------------------------------

adjustSize :: Testable prop => (Int -> Int) -> prop -> Property
adjustSize f p = sized $ \sz -> resize (f sz) (property p)

------------------------------------------------------------------------

{-

-- HUGS needs: 

instance Functor ((->) r) where
        fmap = (.)

instance (Arbitrary a) => Arbitrary (Maybe a) where
  arbitrary            = sized arbMaybe
   where
    arbMaybe 0 = return Nothing
    arbMaybe n = fmap Just (resize (n-1) arbitrary)
  coarbitrary Nothing  = variant 0
  coarbitrary (Just x) = variant 1 . coarbitrary x

instance Monad ((->) r) where
        return = const
        f >>= k = \ r -> k (f r) r

instance Functor ((,) a) where
        fmap f (x,y) = (x, f y)

instance Functor (Either a) where
        fmap _ (Left x) = Left x
        fmap f (Right y) = Right (f y)

-}

------------------------------------------------------------------------

integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
integralRandomR  (a,b) g = case randomR (fromIntegral a :: Integer,
                                         fromIntegral b :: Integer) g of
                            (x,g) -> (fromIntegral x, g)

instance Arbitrary L.ByteString where
  arbitrary = return . L.checkInvariant
                     . L.fromChunks
                     . filter (not. P.null)  -- maintain the invariant.
                   =<< arbitrary

instance CoArbitrary L.ByteString where
  coarbitrary s = coarbitrary (L.unpack s)

instance Arbitrary P.ByteString where
  arbitrary = do
    bs <- P.pack `fmap` arbitrary
    n  <- choose (0, 2)
    return (P.drop n bs) -- to give us some with non-0 offset

instance CoArbitrary P.ByteString where
  coarbitrary s = coarbitrary (P.unpack s)


newtype CByteString = CByteString P.ByteString
  deriving Show

instance Arbitrary CByteString where
  arbitrary = fmap (CByteString . P.pack . map fromCChar) arbitrary
    where
      fromCChar :: CChar -> Word8
      fromCChar = fromIntegral

instance Arbitrary CChar where
  arbitrary = fmap (fromIntegral :: Int -> CChar)
            $ oneof [choose (-128,-1), choose (1,127)]

------------------------------------------------------------------------
--
-- We're doing two forms of testing here. Firstly, model based testing.
-- For our Lazy and strict bytestring types, we have model types:
--
--  i.e.    Lazy    ==   Byte
--              \\      //
--                 List 
--
-- That is, the Lazy type can be modeled by functions in both the Byte
-- and List type. For each of the 3 models, we have a set of tests that
-- check those types match.
--
-- The Model class connects a type and its model type, via a conversion
-- function. 
--
--
class Model a b where
  model :: a -> b  -- get the abstract vale from a concrete value

--
-- Connecting our Lazy and Strict types to their models. We also check
-- the data invariant on Lazy types.
--
-- These instances represent the arrows in the above diagram
--
instance Model B P      where model = abstr . checkInvariant
instance Model P [W]    where model = P.unpack
instance Model P [Char] where model = PC.unpack
instance Model B [W]    where model = L.unpack  . checkInvariant
instance Model B [Char] where model = LC.unpack . checkInvariant
instance Model Char Word8 where model = fromIntegral . ord

-- Types are trivially modeled by themselves
instance Model Bool  Bool         where model = id
instance Model Int   Int          where model = id
instance Model P     P            where model = id
instance Model B     B            where model = id
instance Model Int64 Int64        where model = id
instance Model Word8 Word8        where model = id
instance Model Ordering Ordering  where model = id
instance Model Char Char  where model = id

-- More structured types are modeled recursively, using the NatTrans class from Gofer.
class (Functor f, Functor g) => NatTrans f g where
    eta :: f a -> g a

-- The transformation of the same type is identity
instance NatTrans [] []             where eta = id
instance NatTrans Maybe Maybe       where eta = id
instance NatTrans ((->) X) ((->) X) where eta = id
instance NatTrans ((->) Char) ((->) Char) where eta = id

instance NatTrans ((->) W) ((->) W) where eta = id

-- We have a transformation of pairs, if the pairs are in Model
instance Model f g => NatTrans ((,) f) ((,) g) where eta (f,a) = (model f, a)

-- And finally, we can take any (m a) to (n b), if we can Model m n, and a b
instance (NatTrans m n, Model a b) => Model (m a) (n b) where model x = fmap model (eta x)

------------------------------------------------------------------------

-- In a form more useful for QC testing (and it's lazy)
checkInvariant :: L.ByteString -> L.ByteString
checkInvariant = L.checkInvariant

abstr :: L.ByteString -> P.ByteString
abstr = P.concat . L.toChunks 

-- Some short hand.
type X = Int
type W = Word8
type P = P.ByteString
type B = L.ByteString

------------------------------------------------------------------------
--
-- These comparison functions handle wrapping and equality.
--
-- A single class for these would be nice, but note that they differe in
-- the number of arguments, and those argument types, so we'd need HList
-- tricks. See here: http://okmij.org/ftp/Haskell/vararg-fn.lhs
--

eq1 f g = \a         ->
    model (f a)         == g (model a)
eq2 f g = \a b       ->
    model (f a b)       == g (model a) (model b)
eq3 f g = \a b c     ->
    model (f a b c)     == g (model a) (model b) (model c)

--
-- And for functions that take non-null input
--
eqnotnull1 f g = \x     -> (not (isNull x)) ==> eq1 f g x
eqnotnull2 f g = \x y   -> (not (isNull y)) ==> eq2 f g x y
eqnotnull3 f g = \x y z -> (not (isNull z)) ==> eq3 f g x y z

class    IsNull t            where isNull :: t -> Bool
instance IsNull L.ByteString where isNull = L.null
instance IsNull P.ByteString where isNull = P.null