Vector.hs

-- |
-- Copyright: (C) 2013 Amgen, Inc.
--            (C) 2015 Tweag I/O Limited.
--
-- Tests for the "Data.Vector.SEXP" module.

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Test.Vector where

import Data.AEq
import Data.Int
import Data.Singletons
import qualified Data.Vector.SEXP
import qualified Data.Vector.SEXP as V
import qualified Data.Vector.SEXP.Mutable as VM
#if MIN_VERSION_vector(0,11,0)
import qualified Data.Vector.Fusion.Bundle as S
#else
import qualified Data.Vector.Fusion.Stream as S
#endif
import qualified Foreign.R as R
import H.Prelude
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.HUnit
import Test.QuickCheck.Assertions

instance (Arbitrary a, V.SVECTOR ty a) => Arbitrary (V.Vector ty a) where
  arbitrary = fmap (\x -> V.fromListN (length x) x) arbitrary

#if MIN_VERSION_vector(0,11,0)
instance Arbitrary a => Arbitrary (S.Bundle v a) where
  arbitrary = fmap (\x -> S.fromListN (length x) x) arbitrary
#else
instance Arbitrary a => Arbitrary (S.Stream a) where
  arbitrary = fmap (\x -> S.fromListN (length x) x) arbitrary
#endif

instance (AEq a, V.SVECTOR ty a) => AEq (V.Vector ty a) where
  a ~== b   = all (uncurry (~==)) $ zip (V.toList a) (V.toList b)

testIdentity :: (Eq a, Show a, Arbitrary a, V.SVECTOR ty a, AEq a) => V.Vector ty a -> TestTree
testIdentity dummy = testGroup "Test identities"
    [ testProperty "fromList.toList == id" (prop_fromList_toList dummy)
    , testProperty "toList.fromList == id" (prop_toList_fromList dummy)
--    , testProperty "unstream.stream == id" (prop_unstream_stream dummy)
--    , testProperty "stream.unstream == id" (prop_stream_unstream dummy)
    ]
  where
    prop_fromList_toList (_:: V.Vector ty a) (v :: V.Vector ty a)
      = (V.fromList . V.toList) v ?~== v
    prop_toList_fromList (_ :: V.Vector ty a) (l :: [a])
      = ((V.toList :: V.Vector ty a -> [a]) . V.fromList) l ?~== l
--    prop_unstream_stream (_ :: V.Vector s ty a) (v :: V.Vector s ty a)
--      = (G.unstream . G.stream) v ?~== v
--    prop_stream_unstream (_ :: V.Vector ty a) (s :: S.Stream a)
--      = ((G.stream :: V.Vector ty a -> S.Stream a) . G.unstream) s == s


testPolymorphicFunctions :: (Eq a, Show a, Arbitrary a, V.SVECTOR ty a, AEq a) => V.Vector ty a -> TestTree
testPolymorphicFunctions dummy = testGroup "Polymorphic functions."
    [ -- Length information
      testProperty "prop_length" (prop_length dummy)
    , testProperty "prop_null"   (prop_null dummy)
    , testProperty "prop_index"  (prop_index dummy)
    , testProperty "prop_head"   (prop_head dummy)
    , testProperty "prop_last"   (prop_last dummy)
    ]
  where
    prop_length (_:: V.Vector ty a) (v :: V.Vector ty a)
      = (length . V.toList) v ~==? V.length v
    prop_null (_:: V.Vector ty a) (v :: V.Vector ty a)
      = (null . V.toList) v ~==? V.null v
    prop_index (_:: V.Vector ty a) (v :: V.Vector ty a, j::Int)
      | V.length v == 0 = True
      | otherwise       = let i = j `mod` V.length v in ((\w -> w !! i) . V.toList) v == (v V.! i)
    prop_head (_:: V.Vector ty a) (v :: V.Vector ty a)
      | V.length v == 0 = True
      | otherwise = (head . V.toList) v == V.head v
    prop_last (_:: V.Vector ty a) (v :: V.Vector ty a)
      | V.length v == 0 = True
      | otherwise = (last . V.toList) v == V.last v

testGeneralSEXPVector :: (Eq a, Show a, Arbitrary a, V.SVECTOR ty a, AEq a) => V.Vector ty a -> TestTree
testGeneralSEXPVector dummy = testGroup "General Vector"
  [ testIdentity dummy
  , testPolymorphicFunctions dummy
  ]

testNumericSEXPVector :: (Eq a, Show a, Arbitrary a, V.SVECTOR ty a, AEq a) => V.Vector ty a -> TestTree
testNumericSEXPVector dummy = testGroup "Test Numeric Vector"
  [ testGeneralSEXPVector dummy
  ]

fromListLength :: TestTree
fromListLength = testCase "fromList should have correct length" $ runRegion $ do
    let lst = [-1.9, -0.1, -2.9]
    let vn = idVec $ V.fromListN 3 lst
    let v  = idVec $ V.fromList lst
    io $ assertEqual "Length should be equal to list length" 3 (V.length vn)
    io $ assertEqual "Length should be equal to list length" 3 (V.length v)
    io $ assertBool "Vectors should be almost equal" (vn ~== v)
    io $ assertEqual "i0" (lst !!0) =<< (V.unsafeIndexM vn 0)
    io $ assertEqual "i1" (lst !!1) =<< (V.unsafeIndexM vn 1)
    io $ assertEqual "i2" (lst !!2) =<< (V.unsafeIndexM vn 2)
    io $ assertEqual "Convertion back to list works" lst (V.toList vn)
    io $ assertEqual "Convertion back to list works 2" lst (V.toList v)
    return ()
  where
    idVec :: V.Vector 'R.Real Double -> V.Vector 'R.Real Double
    idVec = id

vectorIsImmutable :: TestTree
vectorIsImmutable = testCase "immutable vector, should not be affected by SEXP changes" $ do
    i <- runRegion $ do
           s <- fmap (R.cast (sing :: R.SSEXPTYPE 'R.Real)) [r| c(1.0,2.0,3.0) |]
           !mutV <- return $ VM.fromSEXP s
           !immV <- return $ V.fromSEXP s
           VM.unsafeWrite mutV 0 (7::Double)
           return $ immV V.! 0
    i @?= 1

vectorCopy :: TestTree
vectorCopy = testCase "Copying vector of doubles works" $ runRegion $ do
  let vs1 = V.toSEXP (V.fromList [1..3::Double]) :: R.SEXP s 'R.Real
      vs2 = V.unsafeToSEXP (V.fromList [1..3::Double]) :: R.SEXP s 'R.Real
  R.SomeSEXP (hexp -> Logical [R.TRUE]) <- [r| identical(vs1_hs, vs2_hs) |]
  return ()

tests :: TestTree
tests = testGroup "Tests."
  [ testGroup "Data.Vector.Storable.Vector (Int32)"
      [testNumericSEXPVector (undefined :: Data.Vector.SEXP.Vector 'R.Int Int32)]
  , testGroup "Data.Vector.Storable.Vector (Double)"
      [testNumericSEXPVector (undefined :: Data.Vector.SEXP.Vector 'R.Real Double)]
  , testGroup "Regression tests" [fromListLength
                                 ,vectorIsImmutable
                                 ,vectorCopy
                                 ]
  ]