Ticket #5054: TestCase2.hs

File TestCase2.hs, 1.4 KB (added by arsenm, 4 years ago)

Second test case

Line 
1{-# OPTIONS_GHC -W #-}
2
3import Data.Int
4import Data.Packed
5import Data.Packed.ST
6import Control.Monad.ST
7import Foreign.Storable
8import Foreign.Ptr
9import Foreign.Marshal.Utils
10
11
12
13data ComputeElement = Constant !Double
14                    | Value !Double
15                    deriving (Eq)
16
17isConstant (Constant _) = True
18isConstant _            = False
19
20instance Element ComputeElement
21
22fromComputeElement (Constant v) = v
23fromComputeElement (Value v) = v
24
25sizeofDouble = sizeOf (undefined :: Double)
26sizeofInt64 = sizeOf (undefined :: Int64)
27
28
29{-
30typedef struct
31{
32    double v;
33    int64_t c;
34} ComputeElement;
35-}
36
37instance Storable ComputeElement where
38  sizeOf _ = sizeofDouble + sizeofInt64
39  alignment _ = 16
40
41  peek p = do v <- peek (castPtr p)
42              c <- peek (castPtr (p `plusPtr` sizeofDouble))
43              return $ if toBool (c :: Int64)
44                         then Constant v
45                         else Value v
46
47  poke p v = do let c :: Int64
48                    c = fromBool (isConstant v)
49                poke (castPtr p) (fromComputeElement v)
50                poke (castPtr p `plusPtr` sizeofDouble) c
51
52
53arst mat v = runST $ do
54  mat' <- thawMatrix mat
55  writeMatrix mat' 1 2 v
56  x <- fromComputeElement `fmap` readMatrix mat' 1 9
57  return (x > 0)
58
59
60zeroMatrix m n = buildMatrix m n (const (Value 0))
61
62
63main = print $ arst (zeroMatrix 10 10) (Constant 9)
64
65