contrib/haskell/src/Hkl/C/Sample.hsc

   1 {-# LANGUAGE ForeignFunctionInterface #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE CPP #-}
   4
   5 module Hkl.C.Sample
   6        ( HklSample
   7        , newSample
   8        , withSample
   9        ) where
  10
  11 import Prelude hiding (min, max)
  12
  13 import Control.Monad (void)
  14 import Foreign ( ForeignPtr
  15                , FunPtr
  16                , Ptr
  17                , nullPtr
  18                , newForeignPtr
  19                , withForeignPtr)
  20 import Foreign.C (CInt(..), CString, withCString)
  21 import Foreign.Storable
  22
  23 import Hkl.C.Lattice
  24 import Hkl.Types
  25
  26 #include "hkl.h"
  27
  28 -- private types
  29
  30 data HklSample
  31
  32 -- Sample
  33
  34 withSample :: Sample a -> (Ptr HklSample -> IO r) -> IO r
  35 withSample s fun = do
  36   fptr <- newSample s
  37   withForeignPtr fptr fun
  38
  39 newSample :: Sample a -> IO (ForeignPtr HklSample)
  40 newSample (Sample name l ux uy uz) =
  41     withCString name $ \cname -> do
  42       sample <- c_hkl_sample_new cname
  43       withLattice l $ \lattice -> do
  44           c_hkl_sample_lattice_set sample lattice
  45           go sample ux c_hkl_sample_ux_get c_hkl_sample_ux_set
  46           go sample uy c_hkl_sample_uy_get c_hkl_sample_uy_set
  47           go sample uz c_hkl_sample_uz_get c_hkl_sample_uz_set
  48           newForeignPtr c_hkl_sample_free sample
  49             where
  50               go s p getter setter = do
  51                 fptr <- copyParameter =<< (getter s)
  52                 withForeignPtr fptr $ \ptr -> do
  53                   poke ptr p
  54                   void $ setter s ptr nullPtr
  55
  56 foreign import ccall unsafe "hkl.h hkl_sample_new"
  57   c_hkl_sample_new:: CString -> IO (Ptr HklSample)
  58
  59 foreign import ccall unsafe "hkl.h hkl_sample_lattice_set"
  60   c_hkl_sample_lattice_set :: Ptr HklSample -> Ptr HklLattice -> IO ()
  61
  62 foreign import ccall unsafe "hkl.h &hkl_sample_free"
  63   c_hkl_sample_free :: FunPtr (Ptr HklSample -> IO ())
  64
  65 foreign import ccall unsafe "hkl.h hkl_sample_ux_get"
  66   c_hkl_sample_ux_get :: Ptr HklSample
  67                       -> IO (Ptr Parameter)
  68
  69 foreign import ccall unsafe "hkl.h hkl_sample_uy_get"
  70   c_hkl_sample_uy_get :: Ptr HklSample
  71                       -> IO (Ptr Parameter)
  72
  73 foreign import ccall unsafe "hkl.h hkl_sample_uz_get"
  74   c_hkl_sample_uz_get :: Ptr HklSample
  75                       -> IO (Ptr Parameter)
  76
  77 foreign import ccall unsafe "hkl.h hkl_sample_ux_set"
  78   c_hkl_sample_ux_set :: Ptr HklSample
  79                       -> Ptr Parameter
  80                       -> Ptr ()
  81                       -> IO CInt
  82
  83 foreign import ccall unsafe "hkl.h hkl_sample_uy_set"
  84   c_hkl_sample_uy_set :: Ptr HklSample
  85                       -> Ptr Parameter
  86                       -> Ptr ()
  87                       -> IO CInt
  88
  89 foreign import ccall unsafe "hkl.h hkl_sample_uz_set"
  90   c_hkl_sample_uz_set :: Ptr HklSample
  91                       -> Ptr Parameter
  92                       -> Ptr ()
  93                       -> IO CInt