module Data.PrimitiveArray.Index.Class where
import Control.Applicative
import Control.DeepSeq (NFData(..))
import Control.Lens hiding (Index, (:>))
import Control.Monad.Except
import Control.Monad (liftM2)
import Data.Aeson
import Data.Binary
import Data.Data
import Data.Hashable (Hashable)
import Data.Proxy
import Data.Serialize
import Data.Typeable
import Data.Vector.Fusion.Stream.Monadic (Stream)
import Data.Vector.Unboxed.Deriving
import Data.Vector.Unboxed (Unbox(..))
import GHC.Generics
import GHC.TypeNats
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import Test.QuickCheck
import Text.Printf
import Data.Type.Equality
infixl 3 :.
data a :. b = !a :. !b
deriving (Eq,Ord,Show,Generic,Data,Typeable)
derivingUnbox "StrictPair"
[t| forall a b . (Unbox a, Unbox b) => (a:.b) -> (a,b) |]
[| \(a:.b) -> (a, b) |]
[| \(a,b) -> (a:.b) |]
instance (Binary a, Binary b) => Binary (a:.b)
instance (Serialize a, Serialize b) => Serialize (a:.b)
instance (ToJSON a, ToJSON b) => ToJSON (a:.b)
instance (FromJSON a, FromJSON b) => FromJSON (a:.b)
instance (Hashable a, Hashable b) => Hashable (a:.b)
instance (ToJSON a , ToJSONKey a, ToJSON b , ToJSONKey b) => ToJSONKey (a:.b)
instance (FromJSON a, FromJSONKey a, FromJSON b, FromJSONKey b) => FromJSONKey (a:.b)
deriving instance (Read a, Read b) => Read (a:.b)
instance (NFData a, NFData b) => NFData (a:.b) where
rnf (a:.b) = rnf a `seq` rnf b
{-# Inline rnf #-}
instance (Arbitrary a, Arbitrary b) => Arbitrary (a :. b) where
arbitrary = liftM2 (:.) arbitrary arbitrary
shrink (a:.b) = [ (a':.b) | a' <- shrink a ] ++ [ (a:.b') | b' <- shrink b ]
infixr 3 :>
data a :> b = !a :> !b
deriving (Eq,Ord,Show,Generic,Data,Typeable)
derivingUnbox "StrictIxPair"
[t| forall a b . (Unbox a, Unbox b) => (a:>b) -> (a,b) |]
[| \(a:>b) -> (a, b) |]
[| \(a,b) -> (a:>b) |]
instance (Binary a, Binary b) => Binary (a:>b)
instance (Serialize a, Serialize b) => Serialize (a:>b)
instance (ToJSON a, ToJSON b) => ToJSON (a:>b)
instance (FromJSON a, FromJSON b) => FromJSON (a:>b)
instance (Hashable a, Hashable b) => Hashable (a:>b)
deriving instance (Read a, Read b) => Read (a:>b)
instance (NFData a, NFData b) => NFData (a:>b) where
rnf (a:>b) = rnf a `seq` rnf b
{-# Inline rnf #-}
data Z = Z
deriving (Eq,Ord,Read,Show,Generic,Data,Typeable)
derivingUnbox "Z"
[t| Z -> () |]
[| const () |]
[| const Z |]
instance Binary Z
instance Serialize Z
instance ToJSON Z
instance FromJSON Z
instance Hashable Z
instance Arbitrary Z where
arbitrary = return Z
instance NFData Z where
rnf Z = ()
{-# Inline rnf #-}
class Index i where
data LimitType i ∷ *
linearIndex ∷ LimitType i → i → Int
size ∷ LimitType i → Int
inBounds ∷ LimitType i → i → Bool
zeroBound ∷ i
zeroBound' ∷ LimitType i
totalSize ∷ LimitType i → [Integer]
sizeIsValid ∷ Monad m ⇒ Word → [[Integer]] → ExceptT SizeError m CellSize
sizeIsValid maxCells cells = do
let ps = map product cells
s = sum ps
when (fromIntegral maxCells <= s) $
throwError . SizeError
$ printf "PrimitiveArrays would be larger than maximal cell size. The given limit is %d, but the requested size is %d, with size %s for each array. (Debug hint: %s)"
maxCells s (show ps) (show s)
return . CellSize $ fromIntegral s
{-# Inlinable sizeIsValid #-}
newtype SizeError = SizeError String
deriving (Eq,Ord,Show)
newtype CellSize = CellSize Word
deriving (Eq,Ord,Show,Num,Bounded,Integral,Real,Enum)
class (Index i) ⇒ IndexStream i where
streamUp ∷ Monad m ⇒ LimitType i → LimitType i → Stream m i
streamDown ∷ Monad m ⇒ LimitType i → LimitType i → Stream m i
instance Index Z where
data LimitType Z = ZZ
linearIndex _ _ = 0
{-# INLINE linearIndex #-}
size _ = 1
{-# INLINE size #-}
inBounds _ _ = True
{-# INLINE inBounds #-}
zeroBound = Z
{-# Inline zeroBound #-}
zeroBound' = ZZ
{-# Inline zeroBound' #-}
totalSize ZZ = [1]
{-# Inline [1] totalSize #-}
instance IndexStream Z where
streamUp ZZ ZZ = SM.singleton Z
{-# Inline streamUp #-}
streamDown ZZ ZZ = SM.singleton Z
{-# Inline streamDown #-}
instance (Index zs, Index z) => Index (zs:.z) where
data LimitType (zs:.z) = !(LimitType zs) :.. !(LimitType z)
linearIndex (hs:..h) (zs:.z) = linearIndex hs zs * size h + linearIndex h z
{-# INLINE linearIndex #-}
size (hs:..h) = size hs * size h
{-# INLINE size #-}
inBounds (hs:..h) (zs:.z) = inBounds hs zs && inBounds h z
{-# INLINE inBounds #-}
zeroBound = zeroBound :. zeroBound
{-# Inline zeroBound #-}
zeroBound' = zeroBound' :.. zeroBound'
{-# Inline zeroBound' #-}
totalSize (hs:..h) =
let tshs = totalSize hs
tsh = totalSize h
in tshs ++ tsh
{-# Inline totalSize #-}
deriving instance Eq (LimitType Z)
deriving instance Generic (LimitType Z)
deriving instance Read (LimitType Z)
deriving instance Show (LimitType Z)
deriving instance Data (LimitType Z)
deriving instance Typeable (LimitType Z)
deriving instance (Eq (LimitType zs) , Eq (LimitType z) ) ⇒ Eq (LimitType (zs:.z))
deriving instance (Generic (LimitType zs), Generic (LimitType z)) ⇒ Generic (LimitType (zs:.z))
deriving instance (Read (LimitType zs) , Read (LimitType z) ) ⇒ Read (LimitType (zs:.z))
deriving instance (Show (LimitType zs) , Show (LimitType z) ) ⇒ Show (LimitType (zs:.z))
deriving instance
( Data zs, Data (LimitType zs), Typeable zs
, Data z , Data (LimitType z) , Typeable z
) ⇒ Data (LimitType (zs:.z))
instance Field1 (Z:.a) (Z:.a') a a' where
{-# Inline _1 #-}
_1 = lens (\(Z:.a) → a) (\(Z:._) a → (Z:.a))
instance Field1 (Z:.a:.b) (Z:.a':.b) a a' where
{-# Inline _1 #-}
_1 = lens (\(Z:.a:.b) → a) (\(Z:._:.b) a → (Z:.a:.b))
instance Field1 (Z:.a:.b:.c) (Z:.a':.b:.c) a a' where
{-# Inline _1 #-}
_1 = lens (\(Z:.a:.b:.c) → a) (\(Z:._:.b:.c) a → (Z:.a:.b:.c))
instance Field2 (Z:.a:.b) (Z:.a:.b') b b' where
{-# Inline _2 #-}
_2 = lens (\(Z:.a:.b) → b) (\(Z:.a:._) b → (Z:.a:.b))
instance Field2 (Z:.a:.b:.c) (Z:.a:.b':.c) b b' where
{-# Inline _2 #-}
_2 = lens (\(Z:.a:.b:.c) → b) (\(Z:.a:._:.c) b → (Z:.a:.b:.c))
instance Field3 (Z:.a:.b:.c) (Z:.a:.b:.c') c c' where
{-# Inline _3 #-}
_3 = lens (\(Z:.a:.b:.c) → c) (\(Z:.a:.b:._) c → (Z:.a:.b:.c))