{- |
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 {Tuple a -> a
getTuple :: a}
   deriving (Tuple a -> Tuple a -> Bool
(Tuple a -> Tuple a -> Bool)
-> (Tuple a -> Tuple a -> Bool) -> Eq (Tuple a)
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
[Tuple a] -> ShowS
Tuple a -> String
(Int -> Tuple a -> ShowS)
-> (Tuple a -> String) -> ([Tuple a] -> ShowS) -> Show (Tuple a)
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 = (a -> Tuple a) -> Gen a -> Gen (Tuple a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Tuple a
forall a. a -> Tuple a
Tuple Gen a
forall a. Arbitrary a => Gen a
QC.arbitrary
   shrink :: Tuple a -> [Tuple a]
shrink (Tuple a
a) = (a -> Tuple a) -> [a] -> [Tuple a]
forall a b. (a -> b) -> [a] -> [b]
map a -> Tuple a
forall a. a -> Tuple a
Tuple ([a] -> [Tuple a]) -> [a] -> [Tuple a]
forall a b. (a -> b) -> a -> b
$ a -> [a]
forall a. Arbitrary a => a -> [a]
QC.shrink a
a


instance Storable a => Store.Storable (Tuple a) where
   sizeOf :: Tuple a -> Int
sizeOf = a -> Int
forall a. Storable a => a -> Int
sizeOf (a -> Int) -> (Tuple a -> a) -> Tuple a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tuple a -> a
forall a. Tuple a -> a
getTuple
   alignment :: Tuple a -> Int
alignment = a -> Int
forall a. Storable a => a -> Int
alignment (a -> Int) -> (Tuple a -> a) -> Tuple a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tuple a -> a
forall a. Tuple a -> a
getTuple
   peek :: Ptr (Tuple a) -> IO (Tuple a)
peek = (a -> Tuple a) -> IO a -> IO (Tuple a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Tuple a
forall a. a -> Tuple a
Tuple (IO a -> IO (Tuple a))
-> (Ptr (Tuple a) -> IO a) -> Ptr (Tuple a) -> IO (Tuple a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek (Ptr a -> IO a)
-> (Ptr (Tuple a) -> Ptr a) -> Ptr (Tuple a) -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr (Tuple a) -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr
   poke :: Ptr (Tuple a) -> Tuple a -> IO ()
poke Ptr (Tuple a)
ptr = Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr (Tuple a) -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr (Tuple a)
ptr) (a -> IO ()) -> (Tuple a -> a) -> Tuple a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tuple a -> a
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
   sizeOf :: (a, b) -> Int
sizeOf    = Dictionary (a, b) -> (a, b) -> Int
forall r. Dictionary r -> r -> Int
Record.sizeOf Dictionary (a, b)
forall a b. (Storable a, Storable b) => Dictionary (a, b)
storePair
   alignment :: (a, b) -> Int
alignment = Dictionary (a, b) -> (a, b) -> Int
forall r. Dictionary r -> r -> Int
Record.alignment Dictionary (a, b)
forall a b. (Storable a, Storable b) => Dictionary (a, b)
storePair
   peek :: Ptr (a, b) -> IO (a, b)
peek      = Dictionary (a, b) -> Ptr (a, b) -> IO (a, b)
forall r. Dictionary r -> Ptr r -> IO r
Record.peek Dictionary (a, b)
forall a b. (Storable a, Storable b) => Dictionary (a, b)
storePair
   poke :: Ptr (a, b) -> (a, b) -> IO ()
poke      = Dictionary (a, b) -> Ptr (a, b) -> (a, b) -> IO ()
forall r. Dictionary r -> Ptr r -> r -> IO ()
Record.poke Dictionary (a, b)
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 :: Dictionary (a, b)
storePair =
   Access (a, b) (a, b) -> Dictionary (a, b)
forall r. Access r r -> Dictionary r
Record.run (Access (a, b) (a, b) -> Dictionary (a, b))
-> Access (a, b) (a, b) -> Dictionary (a, b)
forall a b. (a -> b) -> a -> b
$
   (a -> b -> (a, b))
-> Access (a, b) a -> Access (a, b) b -> Access (a, b) (a, b)
forall (m :: * -> *) a b r.
Applicative m =>
(a -> b -> r) -> m a -> m b -> m r
App.lift2 (,)
      (((a, b) -> a) -> Access (a, b) a
forall a r. Storable a => (r -> a) -> Access r a
Record.element (a, b) -> a
forall a b. (a, b) -> a
fst)
      (((a, b) -> b) -> Access (a, b) b
forall a r. Storable a => (r -> a) -> Access r a
Record.element (a, b) -> b
forall a b. (a, b) -> b
snd)


instance
   (Store.Storable a, Store.Storable b, Store.Storable c) =>
      Storable (a,b,c) where
   sizeOf :: (a, b, c) -> Int
sizeOf    = Dictionary (a, b, c) -> (a, b, c) -> Int
forall r. Dictionary r -> r -> Int
Record.sizeOf Dictionary (a, b, c)
forall a b c.
(Storable a, Storable b, Storable c) =>
Dictionary (a, b, c)
storeTriple
   alignment :: (a, b, c) -> Int
alignment = Dictionary (a, b, c) -> (a, b, c) -> Int
forall r. Dictionary r -> r -> Int
Record.alignment Dictionary (a, b, c)
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      = Dictionary (a, b, c) -> Ptr (a, b, c) -> IO (a, b, c)
forall r. Dictionary r -> Ptr r -> IO r
Record.peek Dictionary (a, b, c)
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      = Dictionary (a, b, c) -> Ptr (a, b, c) -> (a, b, c) -> IO ()
forall r. Dictionary r -> Ptr r -> r -> IO ()
Record.poke Dictionary (a, b, c)
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 :: Dictionary (a, b, c)
storeTriple =
   Access (a, b, c) (a, b, c) -> Dictionary (a, b, c)
forall r. Access r r -> Dictionary r
Record.run (Access (a, b, c) (a, b, c) -> Dictionary (a, b, c))
-> Access (a, b, c) (a, b, c) -> Dictionary (a, b, c)
forall a b. (a -> b) -> a -> b
$
   (a -> b -> c -> (a, b, c))
-> Access (a, b, c) a
-> Access (a, b, c) b
-> Access (a, b, c) c
-> Access (a, b, c) (a, b, c)
forall (m :: * -> *) a b c r.
Applicative m =>
(a -> b -> c -> r) -> m a -> m b -> m c -> m r
App.lift3 (,,)
      (((a, b, c) -> a) -> Access (a, b, c) a
forall a r. Storable a => (r -> a) -> Access r a
Record.element (a, b, c) -> a
forall a b c. (a, b, c) -> a
fst3)
      (((a, b, c) -> b) -> Access (a, b, c) b
forall a r. Storable a => (r -> a) -> Access r a
Record.element (a, b, c) -> b
forall a b c. (a, b, c) -> b
snd3)
      (((a, b, c) -> c) -> Access (a, b, c) c
forall a r. Storable a => (r -> a) -> Access r a
Record.element (a, b, c) -> c
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
   sizeOf :: (a, b, c, d) -> Int
sizeOf    = Dictionary (a, b, c, d) -> (a, b, c, d) -> Int
forall r. Dictionary r -> r -> Int
Record.sizeOf Dictionary (a, b, c, d)
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 = Dictionary (a, b, c, d) -> (a, b, c, d) -> Int
forall r. Dictionary r -> r -> Int
Record.alignment Dictionary (a, b, c, d)
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      = Dictionary (a, b, c, d) -> Ptr (a, b, c, d) -> IO (a, b, c, d)
forall r. Dictionary r -> Ptr r -> IO r
Record.peek Dictionary (a, b, c, d)
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      = Dictionary (a, b, c, d)
-> Ptr (a, b, c, d) -> (a, b, c, d) -> IO ()
forall r. Dictionary r -> Ptr r -> r -> IO ()
Record.poke Dictionary (a, b, c, d)
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 :: Dictionary (a, b, c, d)
storeQuadruple =
   Access (a, b, c, d) (a, b, c, d) -> Dictionary (a, b, c, d)
forall r. Access r r -> Dictionary r
Record.run (Access (a, b, c, d) (a, b, c, d) -> Dictionary (a, b, c, d))
-> Access (a, b, c, d) (a, b, c, d) -> Dictionary (a, b, c, d)
forall a b. (a -> b) -> a -> b
$
   (a -> b -> c -> d -> (a, b, c, d))
-> Access (a, b, c, d) a
-> Access (a, b, c, d) b
-> Access (a, b, c, d) c
-> Access (a, b, c, d) d
-> Access (a, b, c, d) (a, b, c, d)
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 (,,,)
      (((a, b, c, d) -> a) -> Access (a, b, c, d) a
forall a r. Storable a => (r -> a) -> Access r a
Record.element (((a, b, c, d) -> a) -> Access (a, b, c, d) a)
-> ((a, b, c, d) -> a) -> Access (a, b, c, d) a
forall a b. (a -> b) -> a -> b
$ \(a
x,b
_,c
_,d
_) -> a
x)
      (((a, b, c, d) -> b) -> Access (a, b, c, d) b
forall a r. Storable a => (r -> a) -> Access r a
Record.element (((a, b, c, d) -> b) -> Access (a, b, c, d) b)
-> ((a, b, c, d) -> b) -> Access (a, b, c, d) b
forall a b. (a -> b) -> a -> b
$ \(a
_,b
x,c
_,d
_) -> b
x)
      (((a, b, c, d) -> c) -> Access (a, b, c, d) c
forall a r. Storable a => (r -> a) -> Access r a
Record.element (((a, b, c, d) -> c) -> Access (a, b, c, d) c)
-> ((a, b, c, d) -> c) -> Access (a, b, c, d) c
forall a b. (a -> b) -> a -> b
$ \(a
_,b
_,c
x,d
_) -> c
x)
      (((a, b, c, d) -> d) -> Access (a, b, c, d) d
forall a r. Storable a => (r -> a) -> Access r a
Record.element (((a, b, c, d) -> d) -> Access (a, b, c, d) d)
-> ((a, b, c, d) -> d) -> Access (a, b, c, d) d
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
-}