content: {-# LANGUAGE FlexibleInstances, GADTs #-}
  module Utilities where
  
  import Test.QuickCheck
  
  import qualified Data.Vector as DV
  import qualified Data.Vector.Generic as DVG
  import qualified Data.Vector.Primitive as DVP
  import qualified Data.Vector.Storable as DVS
  import qualified Data.Vector.Unboxed as DVU
  import qualified Data.Vector.Fusion.Stream as S
  
  import Data.List ( sortBy )
  
  
  instance Show a => Show (S.Stream a) where
      show s = "Data.Vector.Fusion.Stream.fromList " ++ show (S.toList s)
  
  
  instance Arbitrary a => Arbitrary (DV.Vector a) where
      arbitrary = fmap DV.fromList arbitrary
  
  instance CoArbitrary a => CoArbitrary (DV.Vector a) where
      coarbitrary = coarbitrary . DV.toList
  
  instance (Arbitrary a, DVP.Prim a) => Arbitrary (DVP.Vector a) where
      arbitrary = fmap DVP.fromList arbitrary
  
  instance (CoArbitrary a, DVP.Prim a) => CoArbitrary (DVP.Vector a) where
      coarbitrary = coarbitrary . DVP.toList
  
  instance (Arbitrary a, DVS.Storable a) => Arbitrary (DVS.Vector a) where
      arbitrary = fmap DVS.fromList arbitrary
  
  instance (CoArbitrary a, DVS.Storable a) => CoArbitrary (DVS.Vector a) where
      coarbitrary = coarbitrary . DVS.toList
  
  instance (Arbitrary a, DVU.Unbox a) => Arbitrary (DVU.Vector a) where
      arbitrary = fmap DVU.fromList arbitrary
  
  instance (CoArbitrary a, DVU.Unbox a) => CoArbitrary (DVU.Vector a) where
      coarbitrary = coarbitrary . DVU.toList
  
  instance Arbitrary a => Arbitrary (S.Stream a) where
      arbitrary = fmap S.fromList arbitrary
  
  instance CoArbitrary a => CoArbitrary (S.Stream a) where
      coarbitrary = coarbitrary . S.toList
  
  class (Testable (EqTest a), Conclusion (EqTest a)) => TestData a where
    type Model a
    model :: a -> Model a
    unmodel :: Model a -> a
  
    type EqTest a
    equal :: a -> a -> EqTest a
  
  instance Eq a => TestData (S.Stream a) where
    type Model (S.Stream a) = [a]
    model = S.toList
    unmodel = S.fromList
  
    type EqTest (S.Stream a) = Property
    equal x y = property (x == y)
  
  instance Eq a => TestData (DV.Vector a) where
    type Model (DV.Vector a) = [a]
    model = DV.toList
    unmodel = DV.fromList
  
    type EqTest (DV.Vector a) = Property
    equal x y = property (x == y)
  
  instance (Eq a, DVP.Prim a) => TestData (DVP.Vector a) where
    type Model (DVP.Vector a) = [a]
    model = DVP.toList
    unmodel = DVP.fromList
  
    type EqTest (DVP.Vector a) = Property
    equal x y = property (x == y)
  
  instance (Eq a, DVS.Storable a) => TestData (DVS.Vector a) where
    type Model (DVS.Vector a) = [a]
    model = DVS.toList
    unmodel = DVS.fromList
  
    type EqTest (DVS.Vector a) = Property
    equal x y = property (x == y)
  
  instance (Eq a, DVU.Unbox a) => TestData (DVU.Vector a) where
    type Model (DVU.Vector a) = [a]
    model = DVU.toList
    unmodel = DVU.fromList
  
    type EqTest (DVU.Vector a) = Property
    equal x y = property (x == y)
  
  #define id_TestData(ty) \
  instance TestData ty where { \
    type Model ty = ty;        \
    model = id;                \
    unmodel = id;              \
                               \
    type EqTest ty = Property; \
    equal x y = property (x == y) }
  
  id_TestData(())
  id_TestData(Bool)
  id_TestData(Int)
  id_TestData(Float)
  id_TestData(Double)
  id_TestData(Ordering)
  
  -- Functorish models
  -- All of these need UndecidableInstances although they are actually well founded. Oh well.
  instance (Eq a, TestData a) => TestData (Maybe a) where
    type Model (Maybe a) = Maybe (Model a)
    model = fmap model
    unmodel = fmap unmodel
  
    type EqTest (Maybe a) = Property
    equal x y = property (x == y)
  
  instance (Eq a, TestData a) => TestData [a] where
    type Model [a] = [Model a]
    model = fmap model
    unmodel = fmap unmodel
  
    type EqTest [a] = Property
    equal x y = property (x == y)
  
  instance (Eq a, Eq b, TestData a, TestData b) => TestData (a,b) where
    type Model (a,b) = (Model a, Model b)
    model (a,b) = (model a, model b)
    unmodel (a,b) = (unmodel a, unmodel b)
  
    type EqTest (a,b) = Property
    equal x y = property (x == y)
  
  instance (Eq a, Eq b, Eq c, TestData a, TestData b, TestData c) => TestData (a,b,c) where
    type Model (a,b,c) = (Model a, Model b, Model c)
    model (a,b,c) = (model a, model b, model c)
    unmodel (a,b,c) = (unmodel a, unmodel b, unmodel c)
  
    type EqTest (a,b,c) = Property
    equal x y = property (x == y)
  
  instance (Arbitrary a, Show a, TestData a, TestData b) => TestData (a -> b) where
    type Model (a -> b) = Model a -> Model b
    model f = model . f . unmodel
    unmodel f = unmodel . f . model
  
    type EqTest (a -> b) = a -> EqTest b
    equal f g x = equal (f x) (g x)
  
  newtype P a = P { unP :: EqTest a }
  
  instance TestData a => Testable (P a) where
    property (P a) = property a
  
  infix 4 `eq`
  eq :: TestData a => a -> Model a -> P a
  eq x y = P (equal x (unmodel y))
  
  class Conclusion p where
    type Predicate p
  
    predicate :: Predicate p -> p -> p
  
  instance Conclusion Property where
    type Predicate Property = Bool
  
    predicate = (==>)
  
  instance Conclusion p => Conclusion (a -> p) where
    type Predicate (a -> p) = a -> Predicate p
  
    predicate f p = \x -> predicate (f x) (p x)
  
  infixr 0 ===>
  (===>) :: TestData a => Predicate (EqTest a) -> P a -> P a
  p ===> P a = P (predicate p a)
  
  notNull2 _ xs = not $ DVG.null xs
  notNullS2 _ s = not $ S.null s
  
  -- Generators
  index_value_pairs :: Arbitrary a => Int -> Gen [(Int,a)]
  index_value_pairs 0 = return [] 
  index_value_pairs m = sized $ \n ->
    do
      len <- choose (0,n)
      is <- sequence [choose (0,m-1) | i <- [1..len]]
      xs <- vector len
      return $ zip is xs
  
  indices :: Int -> Gen [Int]
  indices 0 = return []
  indices m = sized $ \n ->
    do
      len <- choose (0,n)
      sequence [choose (0,m-1) | i <- [1..len]]
  
  
  -- Additional list functions
  singleton x = [x]
  snoc xs x = xs ++ [x]
  generate n f = [f i | i <- [0 .. n-1]]
  slice i n xs = take n (drop i xs)
  backpermute xs is = map (xs!!) is
  prescanl f z = init . scanl f z
  postscanl f z = tail . scanl f z
  prescanr f z = tail . scanr f z
  postscanr f z = init . scanr f z
  
  accum :: (a -> b -> a) -> [a] -> [(Int,b)] -> [a]
  accum f xs ps = go xs ps' 0
    where
      ps' = sortBy (\p q -> compare (fst p) (fst q)) ps
  
      go (x:xs) ((i,y) : ps) j
        | i == j     = go (f x y : xs) ps j
      go (x:xs) ps j = x : go xs ps (j+1)
      go [] _ _      = []  
  
  (//) :: [a] -> [(Int, a)] -> [a]
  xs // ps = go xs ps' 0
    where
      ps' = sortBy (\p q -> compare (fst p) (fst q)) ps
  
      go (x:xs) ((i,y) : ps) j
        | i == j     = go (y:xs) ps j
      go (x:xs) ps j = x : go xs ps (j+1)
      go [] _ _      = []
  
  imap :: (Int -> a -> a) -> [a] -> [a]
  imap f = map (uncurry f) . zip [0..]
  
  izipWith :: (Int -> a -> a -> a) -> [a] -> [a] -> [a]
  izipWith f = zipWith (uncurry f) . zip [0..]
  
  izipWith3 :: (Int -> a -> a -> a -> a) -> [a] -> [a] -> [a] -> [a]
  izipWith3 f = zipWith3 (uncurry f) . zip [0..]
  
  ifilter :: (Int -> a -> Bool) -> [a] -> [a]
  ifilter f = map snd . filter (uncurry f) . zip [0..]
  
  ifoldl :: (a -> Int -> a -> a) -> a -> [a] -> a
  ifoldl f z = foldl (uncurry . f) z . zip [0..]
  
  ifoldr :: (Int -> a -> b -> b) -> b -> [a] -> b
  ifoldr f z = foldr (uncurry f) z . zip [0..]
  
  minIndex :: Ord a => [a] -> Int
  minIndex = fst . foldr1 imin . zip [0..]
    where
      imin (i,x) (j,y) | x <= y    = (i,x)
                       | otherwise = (j,y)
  
  maxIndex :: Ord a => [a] -> Int
  maxIndex = fst . foldr1 imax . zip [0..]
    where
      imax (i,x) (j,y) | x >= y    = (i,x)
                       | otherwise = (j,y)
  
  