Ticket #2422: Lib.hs

File Lib.hs, 2.6 KB (added by sedillard, 6 years ago)
Line 
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FunctionalDependencies #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE NoMonomorphismRestriction #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeSynonymInstances #-}
10
11module Lib where
12
13import Foreign
14
15data (:.) a b = !a :. !b
16infixr :.
17
18type Vec4 a = a:.a:.a:.a:.()
19
20
21
22
23instance Storable a => Storable (a:.()) where
24  sizeOf _ = sizeOf (undefined::a)
25  alignment _ = alignment (undefined::a)
26  peek !p = peek (castPtr p) >>= \a -> return (a:.())
27  peekByteOff !p !o = peek (p`plusPtr`o)
28  peekElemOff !p !i = peek (p`plusPtr`(i*sizeOf(undefined::a)))
29  poke !p (a:._) = poke (castPtr p) a
30  pokeByteOff !p !o !x = poke (p`plusPtr`o) x
31  pokeElemOff !p !i !x = poke (p`plusPtr`(i*sizeOf(undefined::a))) x
32  {-# INLINE sizeOf #-}
33  {-# INLINE alignment #-}
34  {-# INLINE peek #-}
35  {-# INLINE peekByteOff #-}
36  {-# INLINE peekElemOff #-}
37  {-# INLINE poke #-}
38  {-# INLINE pokeByteOff #-}
39  {-# INLINE pokeElemOff #-}
40
41instance (Storable a, Storable (a:.v)) 
42  => Storable (a:.a:.v) 
43  where
44  sizeOf _ = sizeOf (undefined::a) + sizeOf (undefined::(a:.v))
45  alignment _ = alignment (undefined::a)
46  peek !p = 
47    peek (castPtr p) >>= \a -> 
48    peek (castPtr (p`plusPtr`sizeOf(undefined::a))) >>= \v -> 
49    return (a:.v)
50  peekByteOff !p !o = peek (p`plusPtr`o)
51  peekElemOff !p !i = peek (p`plusPtr`(i*sizeOf(undefined::(a:.a:.v))))
52  poke !p (a:.v) = 
53    poke (castPtr p) a >> 
54    poke (castPtr (p`plusPtr`sizeOf(undefined::a))) v
55  pokeByteOff !p !o !x = poke (p`plusPtr`o) x
56  pokeElemOff !p !i !x = poke (p`plusPtr`(i*sizeOf(undefined::(a:.a:.v)))) x
57  {-# INLINE sizeOf #-}
58  {-# INLINE alignment #-}
59  {-# INLINE peek #-}
60  {-# INLINE peekByteOff #-}
61  {-# INLINE peekElemOff #-}
62  {-# INLINE poke #-}
63  {-# INLINE pokeByteOff #-}
64  {-# INLINE pokeElemOff #-}
65
66data Vec4D = Vec4D {-# UNPACK #-} !Double
67                   {-# UNPACK #-} !Double
68                   {-# UNPACK #-} !Double
69                   {-# UNPACK #-} !Double
70
71
72class Packed v pv | pv -> v where
73  pack   :: v -> pv
74  unpack :: pv -> v
75
76instance Packed (Vec4 Double) Vec4D where
77  pack (a:.b:.c:.d:.()) = Vec4D a b c d
78  unpack (Vec4D a b c d) = a:.b:.c:.d:.()
79
80{- Uncomment this to see Storable dictionary in Main.loop
81instance Storable Vec4D where
82  sizeOf _ = sizeOf (undefined::Vec4 Double)
83  alignment _ = alignment (undefined::Vec4 Double)
84  peek !p = peek (castPtr p) >>= return . pack
85  poke !p = poke (castPtr p) . unpack
86  peekElemOff !p !i = peekElemOff (castPtr p) i >>= return . pack
87  pokeElemOff !p !i = pokeElemOff (castPtr p) i . unpack
88-}