{- |
Custom class for storing tuples
and wrapper for storing tuples in standard 'Foreign.Storable' class.
These two solutions do not need orphan instances.
The package @storable-tuple@ makes use of this implementation.
-}
module Foreign.Storable.Record.Tuple (
   Storable(..),
   Tuple(..),
   ) where

import qualified Foreign.Storable.Record as Record
import qualified Foreign.Storable as Store
import Foreign.Ptr (Ptr, castPtr)

import qualified Control.Applicative.HT as App
import Data.Tuple.HT (fst3, snd3, thd3)

import qualified Test.QuickCheck as QC


newtype Tuple a = Tuple {forall a. Tuple a -> a
getTuple :: a}
   deriving (Tuple a -> Tuple a -> Bool
forall a. Eq a => Tuple a -> Tuple a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tuple a -> Tuple a -> Bool
$c/= :: forall a. Eq a => Tuple a -> Tuple a -> Bool
== :: Tuple a -> Tuple a -> Bool
$c== :: forall a. Eq a => Tuple a -> Tuple a -> Bool
Eq, Int -> Tuple a -> ShowS
forall a. Show a => Int -> Tuple a -> ShowS
forall a. Show a => [Tuple a] -> ShowS
forall a. Show a => Tuple a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tuple a] -> ShowS
$cshowList :: forall a. Show a => [Tuple a] -> ShowS
show :: Tuple a -> String
$cshow :: forall a. Show a => Tuple a -> String
showsPrec :: Int -> Tuple a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Tuple a -> ShowS
Show)


instance (QC.Arbitrary a) => QC.Arbitrary (Tuple a) where
   arbitrary :: Gen (Tuple a)
arbitrary = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Tuple a
Tuple forall a. Arbitrary a => Gen a
QC.arbitrary
   shrink :: Tuple a -> [Tuple a]
shrink (Tuple a
a) = forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Tuple a
Tuple forall a b. (a -> b) -> a -> b
$ forall a. Arbitrary a => a -> [a]
QC.shrink a
a


instance Storable a => Store.Storable (Tuple a) where
   {-# INLINABLE sizeOf #-}
   {-# INLINABLE alignment #-}
   {-# INLINABLE peek #-}
   {-# INLINABLE poke #-}
   sizeOf :: Tuple a -> Int
sizeOf = forall a. Storable a => a -> Int
sizeOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tuple a -> a
getTuple
   alignment :: Tuple a -> Int
alignment = forall a. Storable a => a -> Int
alignment forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tuple a -> a
getTuple
   peek :: Ptr (Tuple a) -> IO (Tuple a)
peek = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Tuple a
Tuple forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => Ptr a -> IO a
peek forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Ptr a -> Ptr b
castPtr
   poke :: Ptr (Tuple a) -> Tuple a -> IO ()
poke Ptr (Tuple a)
ptr = forall a. Storable a => Ptr a -> a -> IO ()
poke (forall a b. Ptr a -> Ptr b
castPtr Ptr (Tuple a)
ptr) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tuple a -> a
getTuple


class Storable a where
   sizeOf :: a -> Int
   alignment :: a -> Int
   peek :: Ptr a -> IO a
   poke :: Ptr a -> a -> IO ()

instance (Store.Storable a, Store.Storable b) => Storable (a,b) where
   {-# INLINABLE sizeOf #-}
   {-# INLINABLE alignment #-}
   {-# INLINABLE peek #-}
   {-# INLINABLE poke #-}
   sizeOf :: (a, b) -> Int
sizeOf    = forall r. Dictionary r -> r -> Int
Record.sizeOf forall a b. (Storable a, Storable b) => Dictionary (a, b)
storePair
   alignment :: (a, b) -> Int
alignment = forall r. Dictionary r -> r -> Int
Record.alignment forall a b. (Storable a, Storable b) => Dictionary (a, b)
storePair
   peek :: Ptr (a, b) -> IO (a, b)
peek      = forall r. Dictionary r -> Ptr r -> IO r
Record.peek forall a b. (Storable a, Storable b) => Dictionary (a, b)
storePair
   poke :: Ptr (a, b) -> (a, b) -> IO ()
poke      = forall r. Dictionary r -> Ptr r -> r -> IO ()
Record.poke forall a b. (Storable a, Storable b) => Dictionary (a, b)
storePair

{-# INLINE storePair #-}
storePair ::
   (Store.Storable a, Store.Storable b) =>
   Record.Dictionary (a,b)
storePair :: forall a b. (Storable a, Storable b) => Dictionary (a, b)
storePair =
   forall r. Access r r -> Dictionary r
Record.run forall a b. (a -> b) -> a -> b
$
   forall (m :: * -> *) a b r.
Applicative m =>
(a -> b -> r) -> m a -> m b -> m r
App.lift2 (,)
      (forall a r. Storable a => (r -> a) -> Access r a
Record.element forall a b. (a, b) -> a
fst)
      (forall a r. Storable a => (r -> a) -> Access r a
Record.element forall a b. (a, b) -> b
snd)


instance
   (Store.Storable a, Store.Storable b, Store.Storable c) =>
      Storable (a,b,c) where
   {-# INLINABLE sizeOf #-}
   {-# INLINABLE alignment #-}
   {-# INLINABLE peek #-}
   {-# INLINABLE poke #-}
   sizeOf :: (a, b, c) -> Int
sizeOf    = forall r. Dictionary r -> r -> Int
Record.sizeOf forall a b c.
(Storable a, Storable b, Storable c) =>
Dictionary (a, b, c)
storeTriple
   alignment :: (a, b, c) -> Int
alignment = forall r. Dictionary r -> r -> Int
Record.alignment forall a b c.
(Storable a, Storable b, Storable c) =>
Dictionary (a, b, c)
storeTriple
   peek :: Ptr (a, b, c) -> IO (a, b, c)
peek      = forall r. Dictionary r -> Ptr r -> IO r
Record.peek forall a b c.
(Storable a, Storable b, Storable c) =>
Dictionary (a, b, c)
storeTriple
   poke :: Ptr (a, b, c) -> (a, b, c) -> IO ()
poke      = forall r. Dictionary r -> Ptr r -> r -> IO ()
Record.poke forall a b c.
(Storable a, Storable b, Storable c) =>
Dictionary (a, b, c)
storeTriple

{-# INLINE storeTriple #-}
storeTriple ::
   (Store.Storable a, Store.Storable b, Store.Storable c) =>
   Record.Dictionary (a,b,c)
storeTriple :: forall a b c.
(Storable a, Storable b, Storable c) =>
Dictionary (a, b, c)
storeTriple =
   forall r. Access r r -> Dictionary r
Record.run forall a b. (a -> b) -> a -> b
$
   forall (m :: * -> *) a b c r.
Applicative m =>
(a -> b -> c -> r) -> m a -> m b -> m c -> m r
App.lift3 (,,)
      (forall a r. Storable a => (r -> a) -> Access r a
Record.element forall a b c. (a, b, c) -> a
fst3)
      (forall a r. Storable a => (r -> a) -> Access r a
Record.element forall a b c. (a, b, c) -> b
snd3)
      (forall a r. Storable a => (r -> a) -> Access r a
Record.element forall a b c. (a, b, c) -> c
thd3)

instance
   (Store.Storable a, Store.Storable b, Store.Storable c, Store.Storable d) =>
      Storable (a,b,c,d) where
   {-# INLINABLE sizeOf #-}
   {-# INLINABLE alignment #-}
   {-# INLINABLE peek #-}
   {-# INLINABLE poke #-}
   sizeOf :: (a, b, c, d) -> Int
sizeOf    = forall r. Dictionary r -> r -> Int
Record.sizeOf forall a b c d.
(Storable a, Storable b, Storable c, Storable d) =>
Dictionary (a, b, c, d)
storeQuadruple
   alignment :: (a, b, c, d) -> Int
alignment = forall r. Dictionary r -> r -> Int
Record.alignment forall a b c d.
(Storable a, Storable b, Storable c, Storable d) =>
Dictionary (a, b, c, d)
storeQuadruple
   peek :: Ptr (a, b, c, d) -> IO (a, b, c, d)
peek      = forall r. Dictionary r -> Ptr r -> IO r
Record.peek forall a b c d.
(Storable a, Storable b, Storable c, Storable d) =>
Dictionary (a, b, c, d)
storeQuadruple
   poke :: Ptr (a, b, c, d) -> (a, b, c, d) -> IO ()
poke      = forall r. Dictionary r -> Ptr r -> r -> IO ()
Record.poke forall a b c d.
(Storable a, Storable b, Storable c, Storable d) =>
Dictionary (a, b, c, d)
storeQuadruple

{-# INLINE storeQuadruple #-}
storeQuadruple ::
   (Store.Storable a, Store.Storable b, Store.Storable c, Store.Storable d) =>
   Record.Dictionary (a,b,c,d)
storeQuadruple :: forall a b c d.
(Storable a, Storable b, Storable c, Storable d) =>
Dictionary (a, b, c, d)
storeQuadruple =
   forall r. Access r r -> Dictionary r
Record.run forall a b. (a -> b) -> a -> b
$
   forall (m :: * -> *) a b c d r.
Applicative m =>
(a -> b -> c -> d -> r) -> m a -> m b -> m c -> m d -> m r
App.lift4 (,,,)
      (forall a r. Storable a => (r -> a) -> Access r a
Record.element forall a b. (a -> b) -> a -> b
$ \(a
x,b
_,c
_,d
_) -> a
x)
      (forall a r. Storable a => (r -> a) -> Access r a
Record.element forall a b. (a -> b) -> a -> b
$ \(a
_,b
x,c
_,d
_) -> b
x)
      (forall a r. Storable a => (r -> a) -> Access r a
Record.element forall a b. (a -> b) -> a -> b
$ \(a
_,b
_,c
x,d
_) -> c
x)
      (forall a r. Storable a => (r -> a) -> Access r a
Record.element forall a b. (a -> b) -> a -> b
$ \(a
_,b
_,c
_,d
x) -> d
x)


{-
{- Why is this allowed? -}
test :: Char
test = const 'a' undefined

{- Why is type defaulting applied here? The type of 'c' should be fixed. -}
test1 :: (Integral a, RealField.C a) => a
test1 =
   let c = undefined
   in  asTypeOf (round c) c
-}