« back to all changes in this revision
Viewing changes to c2hs/lib/C2HSDeprecated.hs
- browse files at revision 4
- compare with another revision
- download diff
- download tarball
- view history from revision 4
- Committer: Bazaar Package Importer
- Author(s): Arjan Oosting
- Date: 2006-12-14 00:06:12 UTC
- mfrom: (3.1.5 feisty)
- Revision ID: james.westby@ubuntu.com-20061214000612-s7mds83cxqkgv1bj
Tags: 0.14.5-6
* debian/patches/09_replace-deprecated-withObject: Replace all
occurrences of 'withObject' with 'with' as the deprecated 'withObject'
was removed with GHC 6.6. (Closes: #402979)
* Set the urgency to medium as the above bug decreases c2hs usefulness
with GHC 6.6 dramatically.
occurrences of 'withObject' with 'with' as the deprecated 'withObject'
was removed with GHC 6.6. (Closes: #402979)
* Set the urgency to medium as the above bug decreases c2hs usefulness
with GHC 6.6 dramatically.
- files added:
- ChangeLog
- debian/patches
- files removed:
- COPYING.LIB
- base/sysdep
- c2hs/mk
- mk
- files modified:
- AUTHORS
- install-sh *
added
removed
c2hs/lib/C2HSDeprecated.hs
1
-- marshaling library
2
--
3
--
4
--
5
--
6
--
7
--
8
--- DESCRIPTION ---------------------------------------------------------------
9
--
10
--
11
--
12
--- DOCU ----------------------------------------------------------------------
13
--
14
--
15
--- TODO ----------------------------------------------------------------------
16
--
17
18
module C2HSDeprecated (
19
-- the `Addr' module is gone in the New FFI
20
Addr, nullAddr, plusAddr, alignAddr, minusAddr,
21
-- the names of theses types did change
22
CSInt, CLInt, CLLInt, CUSInt, CULInt, CULLInt,
23
-- old C2HS-style Storable support PLUS the methods of the new Storable
24
Storable(..), assignOff, derefOff, assign_, deref_,
25
assignOff_, derefOff_,
26
-- these have different names now
27
mallocBySize, malloc,
28
-- old conversion interface
29
cToChar, cFromChar, cToInt, cFromInt, cToFloat, cFromFloat, cToDouble,
30
cFromDouble,
31
-- old serialisation interface
32
ToAddr(stdAddr), FromAddr(addrStdKeep), addrStd,
33
-- exception handling is now part of the standard FFI
34
ifRaise, ifNegRaise, ifNegRaise_, ifNullRaise,
35
-- old (de)serilisation of lists
36
listToAddrWithLen, addrWithLenToList, listToAddrWithMarker,
37
addrWithMarkerToList,
38
-- marshalling templates
39
Marsh(..), marsh1, marsh1_, marsh2, marsh2_, marsh3, marsh3_, use, forget,
40
void, ref, toAddr, toAddrKeep, toFromAddr,
41
--
42
-- we ex-export all of the new interface that doesn't clash with any of the
43
-- old definitions (namespace-wise)
44
--
45
module C2HS
46
) where
47
48
import Monad (liftM, when)
49
import C2HS hiding
50
(Storable(..), malloc, void)
51
import qualified
52
C2HS (Storable(..), malloc)
53
54
55
56
--
57
type Addr = Ptr ()
58
nullAddr = nullPtr :: Addr
59
plusAddr = plusPtr
60
alignAddr = alignPtr
61
minusAddr = minusPtr
62
63
64
65
--
66
type CSInt = CShort
67
type CLInt = CLong
68
type CLLInt = CLLong
69
type CUSInt = CUShort
70
type CULInt = CULong
71
type CULLInt = CULLong
72
73
74
75
--
76
mallocBySize :: Int -> IO Addr
77
mallocBySize = C2HS.mallocBytes
78
79
--
80
malloc :: Storable a => a -> IO Addr
81
malloc = mallocBySize . sizeof
82
83
--
84
class Storable a where
85
sizeof :: a -> Int
86
assign :: Addr -> a -> IO Addr
87
deref :: Addr -> IO (a, Addr)
88
89
-- new methods
90
alignment :: a -> Int
91
peekElemOff :: Ptr a -> Int -> IO a
92
pokeElemOff :: Ptr a -> Int -> a -> IO ()
93
peekByteOff :: Ptr b -> Int -> IO a
94
pokeByteOff :: Ptr b -> Int -> a -> IO ()
95
peek :: Ptr a -> IO a
96
poke :: Ptr a -> a -> IO ()
97
98
sizeOf :: Storable a => a -> Int
99
sizeOf = sizeof
100
101
instance Storable Char where
102
sizeof = C2HS.sizeOf
103
assign addr v = do
104
C2HS.poke (castPtr addr) v
105
return (addr `plusPtr` sizeof v)
106
deref addr = do
107
v <- C2HS.peek (castPtr addr)
108
return (v, addr `plusPtr` sizeof v)
109
--
110
alignment = C2HS.alignment
111
peekElemOff = C2HS.peekElemOff
112
pokeElemOff = C2HS.pokeElemOff
113
peekByteOff = C2HS.peekByteOff
114
pokeByteOff = C2HS.pokeByteOff
115
peek = C2HS.peek
116
poke = C2HS.poke
117
instance Storable Int where
118
sizeof = C2HS.sizeOf
119
assign addr v = do
120
C2HS.poke (castPtr addr) v
121
return (addr `plusPtr` sizeof v)
122
deref addr = do
123
v <- C2HS.peek (castPtr addr)
124
return (v, addr `plusPtr` sizeof v)
125
--
126
alignment = C2HS.alignment
127
peekElemOff = C2HS.peekElemOff
128
pokeElemOff = C2HS.pokeElemOff
129
peekByteOff = C2HS.peekByteOff
130
pokeByteOff = C2HS.pokeByteOff
131
peek = C2HS.peek
132
poke = C2HS.poke
133
instance Storable Int8 where
134
sizeof = C2HS.sizeOf
135
assign addr v = do
136
C2HS.poke (castPtr addr) v
137
return (addr `plusPtr` sizeof v)
138
deref addr = do
139
v <- C2HS.peek (castPtr addr)
140
return (v, addr `plusPtr` sizeof v)
141
--
142
alignment = C2HS.alignment
143
peekElemOff = C2HS.peekElemOff
144
pokeElemOff = C2HS.pokeElemOff
145
peekByteOff = C2HS.peekByteOff
146
pokeByteOff = C2HS.pokeByteOff
147
peek = C2HS.peek
148
poke = C2HS.poke
149
instance Storable Int16 where
150
sizeof = C2HS.sizeOf
151
assign addr v = do
152
C2HS.poke (castPtr addr) v
153
return (addr `plusPtr` sizeof v)
154
deref addr = do
155
v <- C2HS.peek (castPtr addr)
156
return (v, addr `plusPtr` sizeof v)
157
--
158
alignment = C2HS.alignment
159
peekElemOff = C2HS.peekElemOff
160
pokeElemOff = C2HS.pokeElemOff
161
peekByteOff = C2HS.peekByteOff
162
pokeByteOff = C2HS.pokeByteOff
163
peek = C2HS.peek
164
poke = C2HS.poke
165
instance Storable Int32 where
166
sizeof = C2HS.sizeOf
167
assign addr v = do
168
C2HS.poke (castPtr addr) v
169
return (addr `plusPtr` sizeof v)
170
deref addr = do
171
v <- C2HS.peek (castPtr addr)
172
return (v, addr `plusPtr` sizeof v)
173
--
174
alignment = C2HS.alignment
175
peekElemOff = C2HS.peekElemOff
176
pokeElemOff = C2HS.pokeElemOff
177
peekByteOff = C2HS.peekByteOff
178
pokeByteOff = C2HS.pokeByteOff
179
peek = C2HS.peek
180
poke = C2HS.poke
181
instance Storable Int64 where
182
sizeof = C2HS.sizeOf
183
assign addr v = do
184
C2HS.poke (castPtr addr) v
185
return (addr `plusPtr` sizeof v)
186
deref addr = do
187
v <- C2HS.peek (castPtr addr)
188
return (v, addr `plusPtr` sizeof v)
189
--
190
alignment = C2HS.alignment
191
peekElemOff = C2HS.peekElemOff
192
pokeElemOff = C2HS.pokeElemOff
193
peekByteOff = C2HS.peekByteOff
194
pokeByteOff = C2HS.pokeByteOff
195
peek = C2HS.peek
196
poke = C2HS.poke
197
instance Storable Word8 where
198
sizeof = C2HS.sizeOf
199
assign addr v = do
200
C2HS.poke (castPtr addr) v
201
return (addr `plusPtr` sizeof v)
202
deref addr = do
203
v <- C2HS.peek (castPtr addr)
204
return (v, addr `plusPtr` sizeof v)
205
--
206
alignment = C2HS.alignment
207
peekElemOff = C2HS.peekElemOff
208
pokeElemOff = C2HS.pokeElemOff
209
peekByteOff = C2HS.peekByteOff
210
pokeByteOff = C2HS.pokeByteOff
211
peek = C2HS.peek
212
poke = C2HS.poke
213
instance Storable Word16 where
214
sizeof = C2HS.sizeOf
215
assign addr v = do
216
C2HS.poke (castPtr addr) v
217
return (addr `plusPtr` sizeof v)
218
deref addr = do
219
v <- C2HS.peek (castPtr addr)
220
return (v, addr `plusPtr` sizeof v)
221
--
222
alignment = C2HS.alignment
223
peekElemOff = C2HS.peekElemOff
224
pokeElemOff = C2HS.pokeElemOff
225
peekByteOff = C2HS.peekByteOff
226
pokeByteOff = C2HS.pokeByteOff
227
peek = C2HS.peek
228
poke = C2HS.poke
229
instance Storable Word32 where
230
sizeof = C2HS.sizeOf
231
assign addr v = do
232
C2HS.poke (castPtr addr) v
233
return (addr `plusPtr` sizeof v)
234
deref addr = do
235
v <- C2HS.peek (castPtr addr)
236
return (v, addr `plusPtr` sizeof v)
237
--
238
alignment = C2HS.alignment
239
peekElemOff = C2HS.peekElemOff
240
pokeElemOff = C2HS.pokeElemOff
241
peekByteOff = C2HS.peekByteOff
242
pokeByteOff = C2HS.pokeByteOff
243
peek = C2HS.peek
244
poke = C2HS.poke
245
instance Storable Word64 where
246
sizeof = C2HS.sizeOf
247
assign addr v = do
248
C2HS.poke (castPtr addr) v
249
return (addr `plusPtr` sizeof v)
250
deref addr = do
251
v <- C2HS.peek (castPtr addr)
252
return (v, addr `plusPtr` sizeof v)
253
--
254
alignment = C2HS.alignment
255
peekElemOff = C2HS.peekElemOff
256
pokeElemOff = C2HS.pokeElemOff
257
peekByteOff = C2HS.peekByteOff
258
pokeByteOff = C2HS.pokeByteOff
259
peek = C2HS.peek
260
poke = C2HS.poke
261
instance Storable Float where
262
sizeof = C2HS.sizeOf
263
assign addr v = do
264
C2HS.poke (castPtr addr) v
265
return (addr `plusPtr` sizeof v)
266
deref addr = do
267
v <- C2HS.peek (castPtr addr)
268
return (v, addr `plusPtr` sizeof v)
269
--
270
alignment = C2HS.alignment
271
peekElemOff = C2HS.peekElemOff
272
pokeElemOff = C2HS.pokeElemOff
273
peekByteOff = C2HS.peekByteOff
274
pokeByteOff = C2HS.pokeByteOff
275
peek = C2HS.peek
276
poke = C2HS.poke
277
instance Storable Double where
278
sizeof = C2HS.sizeOf
279
assign addr v = do
280
C2HS.poke (castPtr addr) v
281
return (addr `plusPtr` sizeof v)
282
deref addr = do
283
v <- C2HS.peek (castPtr addr)
284
return (v, addr `plusPtr` sizeof v)
285
--
286
alignment = C2HS.alignment
287
peekElemOff = C2HS.peekElemOff
288
pokeElemOff = C2HS.pokeElemOff
289
peekByteOff = C2HS.peekByteOff
290
pokeByteOff = C2HS.pokeByteOff
291
peek = C2HS.peek
292
poke = C2HS.poke
293
instance Storable Addr where
294
sizeof = C2HS.sizeOf
295
assign addr v = do
296
C2HS.poke (castPtr addr) v
297
return (addr `plusPtr` sizeof v)
298
deref addr = do
299
v <- C2HS.peek (castPtr addr)
300
return (v, addr `plusPtr` sizeof v)
301
--
302
alignment = C2HS.alignment
303
peekElemOff = C2HS.peekElemOff
304
pokeElemOff = C2HS.pokeElemOff
305
peekByteOff = C2HS.peekByteOff
306
pokeByteOff = C2HS.pokeByteOff
307
peek = C2HS.peek
308
poke = C2HS.poke
309
310
instance Storable CChar where
311
sizeof = C2HS.sizeOf
312
assign addr v = do
313
C2HS.poke (castPtr addr) v
314
return (addr `plusPtr` sizeof v)
315
deref addr = do
316
v <- C2HS.peek (castPtr addr)
317
return (v, addr `plusPtr` sizeof v)
318
--
319
alignment = C2HS.alignment
320
peekElemOff = C2HS.peekElemOff
321
pokeElemOff = C2HS.pokeElemOff
322
peekByteOff = C2HS.peekByteOff
323
pokeByteOff = C2HS.pokeByteOff
324
peek = C2HS.peek
325
poke = C2HS.poke
326
instance Storable CSChar where
327
sizeof = C2HS.sizeOf
328
assign addr v = do
329
C2HS.poke (castPtr addr) v
330
return (addr `plusPtr` sizeof v)
331
deref addr = do
332
v <- C2HS.peek (castPtr addr)
333
return (v, addr `plusPtr` sizeof v)
334
--
335
alignment = C2HS.alignment
336
peekElemOff = C2HS.peekElemOff
337
pokeElemOff = C2HS.pokeElemOff
338
peekByteOff = C2HS.peekByteOff
339
pokeByteOff = C2HS.pokeByteOff
340
peek = C2HS.peek
341
poke = C2HS.poke
342
instance Storable CUChar where
343
sizeof = C2HS.sizeOf
344
assign addr v = do
345
C2HS.poke (castPtr addr) v
346
return (addr `plusPtr` sizeof v)
347
deref addr = do
348
v <- C2HS.peek (castPtr addr)
349
return (v, addr `plusPtr` sizeof v)
350
--
351
alignment = C2HS.alignment
352
peekElemOff = C2HS.peekElemOff
353
pokeElemOff = C2HS.pokeElemOff
354
peekByteOff = C2HS.peekByteOff
355
pokeByteOff = C2HS.pokeByteOff
356
peek = C2HS.peek
357
poke = C2HS.poke
358
instance Storable CShort where
359
sizeof = C2HS.sizeOf
360
assign addr v = do
361
C2HS.poke (castPtr addr) v
362
return (addr `plusPtr` sizeof v)
363
deref addr = do
364
v <- C2HS.peek (castPtr addr)
365
return (v, addr `plusPtr` sizeof v)
366
--
367
alignment = C2HS.alignment
368
peekElemOff = C2HS.peekElemOff
369
pokeElemOff = C2HS.pokeElemOff
370
peekByteOff = C2HS.peekByteOff
371
pokeByteOff = C2HS.pokeByteOff
372
peek = C2HS.peek
373
poke = C2HS.poke
374
instance Storable CUShort where
375
sizeof = C2HS.sizeOf
376
assign addr v = do
377
C2HS.poke (castPtr addr) v
378
return (addr `plusPtr` sizeof v)
379
deref addr = do
380
v <- C2HS.peek (castPtr addr)
381
return (v, addr `plusPtr` sizeof v)
382
--
383
alignment = C2HS.alignment
384
peekElemOff = C2HS.peekElemOff
385
pokeElemOff = C2HS.pokeElemOff
386
peekByteOff = C2HS.peekByteOff
387
pokeByteOff = C2HS.pokeByteOff
388
peek = C2HS.peek
389
poke = C2HS.poke
390
instance Storable CInt where
391
sizeof = C2HS.sizeOf
392
assign addr v = do
393
C2HS.poke (castPtr addr) v
394
return (addr `plusPtr` sizeof v)
395
deref addr = do
396
v <- C2HS.peek (castPtr addr)
397
return (v, addr `plusPtr` sizeof v)
398
--
399
alignment = C2HS.alignment
400
peekElemOff = C2HS.peekElemOff
401
pokeElemOff = C2HS.pokeElemOff
402
peekByteOff = C2HS.peekByteOff
403
pokeByteOff = C2HS.pokeByteOff
404
peek = C2HS.peek
405
poke = C2HS.poke
406
instance Storable CUInt where
407
sizeof = C2HS.sizeOf
408
assign addr v = do
409
C2HS.poke (castPtr addr) v
410
return (addr `plusPtr` sizeof v)
411
deref addr = do
412
v <- C2HS.peek (castPtr addr)
413
return (v, addr `plusPtr` sizeof v)
414
--
415
alignment = C2HS.alignment
416
peekElemOff = C2HS.peekElemOff
417
pokeElemOff = C2HS.pokeElemOff
418
peekByteOff = C2HS.peekByteOff
419
pokeByteOff = C2HS.pokeByteOff
420
peek = C2HS.peek
421
poke = C2HS.poke
422
instance Storable CLong where
423
sizeof = C2HS.sizeOf
424
assign addr v = do
425
C2HS.poke (castPtr addr) v
426
return (addr `plusPtr` sizeof v)
427
deref addr = do
428
v <- C2HS.peek (castPtr addr)
429
return (v, addr `plusPtr` sizeof v)
430
--
431
alignment = C2HS.alignment
432
peekElemOff = C2HS.peekElemOff
433
pokeElemOff = C2HS.pokeElemOff
434
peekByteOff = C2HS.peekByteOff
435
pokeByteOff = C2HS.pokeByteOff
436
peek = C2HS.peek
437
poke = C2HS.poke
438
instance Storable CULong where
439
sizeof = C2HS.sizeOf
440
assign addr v = do
441
C2HS.poke (castPtr addr) v
442
return (addr `plusPtr` sizeof v)
443
deref addr = do
444
v <- C2HS.peek (castPtr addr)
445
return (v, addr `plusPtr` sizeof v)
446
--
447
alignment = C2HS.alignment
448
peekElemOff = C2HS.peekElemOff
449
pokeElemOff = C2HS.pokeElemOff
450
peekByteOff = C2HS.peekByteOff
451
pokeByteOff = C2HS.pokeByteOff
452
peek = C2HS.peek
453
poke = C2HS.poke
454
instance Storable CLLong where
455
sizeof = C2HS.sizeOf
456
assign addr v = do
457
C2HS.poke (castPtr addr) v
458
return (addr `plusPtr` sizeof v)
459
deref addr = do
460
v <- C2HS.peek (castPtr addr)
461
return (v, addr `plusPtr` sizeof v)
462
--
463
alignment = C2HS.alignment
464
peekElemOff = C2HS.peekElemOff
465
pokeElemOff = C2HS.pokeElemOff
466
peekByteOff = C2HS.peekByteOff
467
pokeByteOff = C2HS.pokeByteOff
468
peek = C2HS.peek
469
poke = C2HS.poke
470
instance Storable CULLong where
471
sizeof = C2HS.sizeOf
472
assign addr v = do
473
C2HS.poke (castPtr addr) v
474
return (addr `plusPtr` sizeof v)
475
deref addr = do
476
v <- C2HS.peek (castPtr addr)
477
return (v, addr `plusPtr` sizeof v)
478
--
479
alignment = C2HS.alignment
480
peekElemOff = C2HS.peekElemOff
481
pokeElemOff = C2HS.pokeElemOff
482
peekByteOff = C2HS.peekByteOff
483
pokeByteOff = C2HS.pokeByteOff
484
peek = C2HS.peek
485
poke = C2HS.poke
486
{-
487
instance Storable CFloat where
488
sizeof = C2HS.sizeOf
489
assign addr v = do
490
C2HS.poke (castPtr addr) v
491
return (addr `plusPtr` sizeof v)
492
deref addr = do
493
v <- C2HS.peek (castPtr addr)
494
return (v, addr `plusPtr` sizeof v)
495
--
496
alignment = C2HS.alignment
497
peekElemOff = C2HS.peekElemOff
498
pokeElemOff = C2HS.pokeElemOff
499
peekByteOff = C2HS.peekByteOff
500
pokeByteOff = C2HS.pokeByteOff
501
peek = C2HS.peek
502
poke = C2HS.poke
503
instance Storable CDouble where
504
sizeof = C2HS.sizeOf
505
assign addr v = do
506
C2HS.poke (castPtr addr) v
507
return (addr `plusPtr` sizeof v)
508
deref addr = do
509
v <- C2HS.peek (castPtr addr)
510
return (v, addr `plusPtr` sizeof v)
511
--
512
alignment = C2HS.alignment
513
peekElemOff = C2HS.peekElemOff
514
pokeElemOff = C2HS.pokeElemOff
515
peekByteOff = C2HS.peekByteOff
516
pokeByteOff = C2HS.pokeByteOff
517
peek = C2HS.peek
518
poke = C2HS.poke
519
instance Storable CLDouble where
520
sizeof = C2HS.sizeOf
521
assign addr v = do
522
C2HS.poke (castPtr addr) v
523
return (addr `plusPtr` sizeof v)
524
deref addr = do
525
v <- C2HS.peek (castPtr addr)
526
return (v, addr `plusPtr` sizeof v)
527
--
528
alignment = C2HS.alignment
529
peekElemOff = C2HS.peekElemOff
530
pokeElemOff = C2HS.pokeElemOff
531
peekByteOff = C2HS.peekByteOff
532
pokeByteOff = C2HS.pokeByteOff
533
peek = C2HS.peek
534
poke = C2HS.poke
535
-}
536
537
--
538
assignOff :: Storable a => Addr -> Int -> a -> IO Addr
539
assignOff loc off val = (loc `plusAddr` off) `assign` val
540
541
--
542
derefOff :: Storable a => Addr -> Int -> IO (a, Addr)
543
derefOff loc off = deref (loc `plusAddr` off)
544
545
--
546
assign_ :: Storable a => Addr -> a -> IO ()
547
assign_ adr x = assign adr x >> return ()
548
549
--
550
deref_ :: Storable a => Addr -> IO a
551
deref_ = liftM fst . deref
552
553
--
554
assignOff_ :: Storable a => Addr -> Int -> a -> IO ()
555
assignOff_ loc x off = assignOff loc x off >> return ()
556
557
--
558
derefOff_ :: Storable a => Addr -> Int -> IO a
559
derefOff_ loc off = liftM fst $ derefOff loc off
560
561
--
562
cToChar :: CChar -> Char
563
cToChar = castCCharToChar
564
--
565
cFromChar :: Char -> CChar
566
cFromChar = castCharToCChar
567
568
--
569
-- original one. The latter did not require the converted type to be
570
-- an instance of `Integral' - in particular, an instance for `Char'
571
-- was supported.
572
--
573
cToInt :: Integral a => a -> Int
574
cToInt = cIntConv
575
--
576
cFromInt :: Integral a => Int -> a
577
cFromInt = cIntConv
578
579
--
580
cToFloat :: RealFloat a => a -> Float
581
cToFloat = cFloatConv
582
--
583
cFromFloat :: RealFloat a => Float -> a
584
cFromFloat = cFloatConv
585
586
--
587
cToDouble :: RealFloat a => a -> Double
588
cToDouble = cFloatConv
589
--
590
cFromDouble :: RealFloat a => Double -> a
591
cFromDouble = cFloatConv
592
593
--
594
-- original one. The instance `Char' for cToBool/cFromBool is no
595
-- longer supported.
596
597
598
599
--
600
class Storable a => ToAddr a where
601
stdAddr :: a -> IO Addr
602
stdAddr x = do
603
box <- malloc x
604
box `assign` x
605
return box
606
607
instance ToAddr Char
608
instance ToAddr Int8
609
instance ToAddr Int16
610
instance ToAddr Int32
611
instance ToAddr Word8
612
instance ToAddr Word16
613
instance ToAddr Word32
614
instance ToAddr Float
615
instance ToAddr Double
616
instance ToAddr Addr
617
618
instance ToAddr CChar
619
instance ToAddr CSChar
620
instance ToAddr CUChar
621
instance ToAddr CShort
622
instance ToAddr CUShort
623
instance ToAddr CInt
624
instance ToAddr CUInt
625
instance ToAddr CLong
626
instance ToAddr CULong
627
instance ToAddr CLLong
628
instance ToAddr CULLong
629
630
instance ToAddr String where
631
stdAddr = listToAddrWithMarker (toEnum 0 :: CChar) . map castCharToCChar
632
633
--
634
class Storable a => FromAddr a where
635
addrStdKeep :: Addr -> IO a
636
addrStdKeep = deref_
637
638
instance FromAddr Char
639
instance FromAddr Int8
640
instance FromAddr Int16
641
instance FromAddr Int32
642
instance FromAddr Word8
643
instance FromAddr Word16
644
instance FromAddr Word32
645
instance FromAddr Float
646
instance FromAddr Double
647
instance FromAddr Addr
648
649
instance FromAddr CChar
650
instance FromAddr CSChar
651
instance FromAddr CUChar
652
instance FromAddr CShort
653
instance FromAddr CUShort
654
instance FromAddr CInt
655
instance FromAddr CUInt
656
instance FromAddr CLong
657
instance FromAddr CULong
658
instance FromAddr CLLong
659
instance FromAddr CULLong
660
661
instance FromAddr String where
662
addrStdKeep = liftM (map castCCharToChar) .
663
addrWithMarkerToList (toEnum 0 :: CChar)
664
665
--
666
addrStd :: FromAddr a => Addr -> IO a
667
addrStd adr = do
668
res <- addrStdKeep adr
669
free adr
670
return res
671
672
--
673
--
674
ifRaise :: (a -> (b, c)) -- selector
675
-> (b -> Bool) -- test for error condition
676
-> IO a -- foreign call
677
-> (b -> String) -- produce exception message
678
-> IO c
679
ifRaise sel p op errfct = do
680
(errval, res) <- liftM sel op
681
when (p errval) $
682
(ioError . userError) (errfct errval)
683
return res
684
685
--
686
infix 8 `ifNegRaise`
687
ifNegRaise :: Integral i => IO i -> String -> IO Int
688
ifNegRaise op errmsg = ifRaise cToInt2 (< 0) op (const errmsg)
689
where
690
cToInt2 x = let y = cIntConv x
691
in
692
(y, y)
693
694
--
695
infix 8 `ifNegRaise_`
696
ifNegRaise_ :: Integral i => IO i -> String -> IO ()
697
ifNegRaise_ op errmsg = liftM (const ()) $ ifNegRaise op errmsg
698
699
infix 8 `ifNullRaise`
700
ifNullRaise :: IO Addr -> String -> IO Addr
701
ifNullRaise op errmsg = ifRaise (\x -> (x, x)) (== nullAddr) op (const errmsg)
702
703
--
704
--
705
listToAddrWithLen :: Storable a => [a] -> IO (Addr, Int)
706
listToAddrWithLen str = do
707
mem <- malloc str
708
mem `assign` str
709
return (mem, length str)
710
711
--
712
--
713
addrWithLenToList :: Storable a => Addr -> Int -> IO [a]
714
addrWithLenToList adr len = liftM fst $ readListFromAddr len adr
715
716
--
717
--
718
--
719
listToAddrWithMarker :: Storable a => a -> [a] -> IO Addr
720
listToAddrWithMarker marker str =
721
liftM fst $ listToAddrWithLen (str ++ [marker])
722
723
--
724
--
725
--
726
addrWithMarkerToList :: (Storable a, Eq a) => a -> Addr -> IO [a]
727
addrWithMarkerToList marker adr =
728
do
729
(x, adr') <- deref adr
730
if (x == marker) then return []
731
else do
732
xs <- addrWithMarkerToList marker adr'
733
return $ x : xs
734
735
736
737
instance Storable a => Storable [a] where
738
sizeof = sum . map sizeof
739
assign = writeListToAddr
740
deref = error "C2HSMarsh: Cannot generically deserialise a list!"
741
742
--
743
writeListToAddr :: Storable a => Addr -> [a] -> IO Addr
744
writeListToAddr adr [] = return adr
745
writeListToAddr adr (x:xs) = do
746
adr' <- adr `assign` x
747
writeListToAddr adr' xs
748
749
--
750
readListFromAddr :: Storable a => Int -> Addr -> IO ([a], Addr)
751
readListFromAddr 0 adr = return ([], adr)
752
readListFromAddr n adr = do
753
(x, adr') <- deref adr
754
(xs, adr'') <- readListFromAddr (n - 1) adr'
755
return (x : xs, adr'')
756
757
{-
758
--
759
--
760
--
761
readListFromAddr' :: Storable a => Addr -> IO [(a, Addr)]
762
readListFromAddr' adr =
763
do
764
(x, adr') <- deref adr
765
xs <- unsafePerformIO $ readListFromAddr' adr'
766
return $ (x, adr') : xs
767
-}
768
769
770
771
--
772
--
773
--
774
data Marsh a b = (IO b) :> (b -> IO a)
775
776
--
777
--
778
779
marsh1 :: (a' -> IO r) -> (Marsh a a') -> IO (r, a)
780
marsh1 f (pre :> post) =
781
do
782
x <- pre
783
r <- f x
784
x' <- post x
785
return (r, x')
786
787
marsh1_ :: (a' -> IO r) -> (Marsh a a') -> IO r
788
marsh1_ f x = liftM fst $ marsh1 f x
789
790
marsh2 :: (a' -> b' -> IO r)
791
-> (Marsh a a') -> (Marsh b b')
792
-> IO (r, (a, b))
793
marsh2 f (pre1 :> post1) (pre2 :> post2) =
794
do
795
x <- pre1
796
y <- pre2
797
r <- f x y
798
x' <- post1 x
799
y' <- post2 y
800
return (r, (x', y'))
801
802
marsh2_ :: (a' -> b' -> IO c)
803
-> (Marsh a a') -> (Marsh b b')
804
-> IO c
805
marsh2_ f x y = liftM fst $ marsh2 f x y
806
807
marsh3 :: (a' -> b' -> c' -> IO r)
808
-> (Marsh a a') -> (Marsh b b') -> (Marsh c c')
809
-> IO (r, (a, b, c))
810
marsh3 f (pre1 :> post1) (pre2 :> post2) (pre3 :> post3) =
811
do
812
x <- pre1
813
y <- pre2
814
z <- pre3
815
r <- f x y z
816
x' <- post1 x
817
y' <- post2 y
818
z' <- post3 z
819
return (r, (x', y', z'))
820
821
marsh3_ :: (a' -> b' -> c' -> IO r)
822
-> (Marsh a a') -> (Marsh b b') -> (Marsh c c')
823
-> IO r
824
marsh3_ f x y z = liftM fst $ marsh3 f x y z
825
826
827
--
828
use :: a -> IO a
829
use = return
830
831
--
832
forget :: a -> IO ()
833
forget _ = use ()
834
835
--
836
void :: Monad m => m (a, b) -> m b
837
void = liftM snd
838
839
--
840
ref :: (ToAddr a, FromAddr a) => a -> Marsh a Addr
841
ref x = stdAddr x :> addrStd
842
843
--
844
845
toAddr :: ToAddr v => (Addr -> IO a) -> v -> IO a
846
toAddr f val = f `marsh1_` (stdAddr val :> free)
847
848
toAddrKeep :: ToAddr v => (Addr -> IO a) -> v -> IO a
849
toAddrKeep f val = f `marsh1_` (stdAddr val :> use)
850
851
toFromAddr :: (ToAddr v, FromAddr v) => (Addr -> IO a) -> v -> IO (a, v)
852
toFromAddr f val = f `marsh1` (stdAddr val :> addrStd)
Loggerhead is a web-based interface for Breezy
Version: 2.0.1