contrib/haskell/src/Hkl/DArray.hsc

   1 {-# LANGUAGE ForeignFunctionInterface #-}
   2 {-# LANGUAGE CPP #-}
   3
   4 module Hkl.DArray where
   5
   6 import Control.Monad
   7 import Foreign
   8 import Foreign.C
   9
  10 import Hkl.Types
  11
  12 #include "hkl.h"
  13
  14 -- helpers
  15
  16 peekParameter :: Ptr HklParameter -> IO Parameter
  17 peekParameter p =
  18     alloca $ \pmin ->
  19         alloca $ \pmax -> do
  20           cname <- c_hkl_parameter_name_get p
  21           name <- peekCString cname
  22           value <- c_hkl_parameter_value_get p unit
  23           c_hkl_parameter_min_max_get p pmin pmax unit
  24           min <- peek pmin
  25           max <- peek pmax
  26           return (Parameter name value (min, max))
  27
  28 peekDArrayString :: Ptr () -> IO [CString]
  29 peekDArrayString p = do
  30   n <- (#{peek darray_string, size} p) :: IO CSize
  31   items <- #{peek darray_string ,item} p :: IO (Ptr CString)
  32   peekArray (fromEnum n) items
  33
  34 darrayStringLen :: Ptr () -> IO (CSize)
  35 darrayStringLen p = do
  36     n <- (#{peek darray_string, size} p) :: IO CSize
  37     return n
  38
  39 -- geometry
  40
  41
  42 geometryWavelengthGet :: Geometry -> IO Double
  43 geometryWavelengthGet (Geometry g) =
  44   withForeignPtr g $ \gp -> do
  45     (CDouble d) <- c_hkl_geometry_wavelength_get gp unit
  46     return d
  47
  48 foreign import ccall unsafe "hkl.h hkl_geometry_wavelength_get"
  49   c_hkl_geometry_wavelength_get :: Ptr HklGeometry -- geometry
  50                                 -> CInt -- unit
  51                                 -> IO CDouble -- wavelength
  52
  53 geometryWavelengthSet :: Geometry -> Double -> IO ()
  54 geometryWavelengthSet (Geometry g) w =
  55   withForeignPtr g $ \gp -> do
  56     let wavelength = CDouble w
  57     c_hkl_geometry_wavelength_set gp wavelength unit nullPtr
  58
  59 foreign import ccall unsafe "hkl.h hkl_geometry_wavelength_set"
  60   c_hkl_geometry_wavelength_set :: Ptr HklGeometry -- geometry
  61                                 -> CDouble -- wavelength
  62                                 -> CInt -- unit
  63                                 -> Ptr () -- *gerror
  64                                 -> IO () -- IO CInt but for now do not deal with the errors
  65
  66 geometryAxisNamesGet' :: Geometry -> IO [CString]
  67 geometryAxisNamesGet' (Geometry g) =
  68   withForeignPtr g (c_hkl_geometry_axis_names_get >=> peekDArrayString)
  69
  70 foreign import ccall unsafe "hkl.h hkl_geometry_axis_names_get"
  71   c_hkl_geometry_axis_names_get :: Ptr HklGeometry -- goemetry
  72                                 -> IO (Ptr ()) -- darray_string
  73
  74 geometryAxisGet :: Geometry -> CString -> IO Parameter
  75 geometryAxisGet (Geometry g) n =
  76     withForeignPtr g $ \gp ->
  77         c_hkl_geometry_axis_get gp n nullPtr >>= peekParameter
  78
  79 foreign import ccall unsafe "hkl.h hkl_geometry_axis_get"
  80   c_hkl_geometry_axis_get :: Ptr HklGeometry -- geometry
  81                           -> CString -- axis name
  82                           -> Ptr () -- gerror
  83                           -> IO (Ptr HklParameter) -- parameter or nullPtr
  84
  85 geometryAxesGet :: Geometry -> IO [Parameter]
  86 geometryAxesGet g = geometryAxisNamesGet' g >>= mapM (geometryAxisGet g)
  87
  88 geometryAxisValuesGet :: Geometry -> IO [Double]
  89 geometryAxisValuesGet (Geometry g) =
  90   withForeignPtr g $ \gp -> do
  91     darray <- c_hkl_geometry_axis_names_get gp
  92     n <- darrayStringLen darray
  93     let nn = fromEnum n
  94     allocaArray nn $ \values -> do
  95       c_hkl_geometry_axis_values_get gp values n unit
  96       peekArray nn values
  97
  98 foreign import ccall unsafe "hkl.h hkl_geometry_axis_values_get"
  99   c_hkl_geometry_axis_values_get :: Ptr HklGeometry -- geometry
 100                                  -> Ptr Double -- axis values
 101                                  -> CSize -- size of axis values
 102                                  -> CInt -- unit
 103                                  -> IO () -- IO CInt but for now do not deal with the errors
 104
 105 geometryAxisValuesSet :: Geometry -> [Double] -> IO ()
 106 geometryAxisValuesSet (Geometry g) v =
 107   withForeignPtr g $ \gp -> do
 108     darray <- c_hkl_geometry_axis_names_get gp
 109     n <- darrayStringLen darray
 110     withArray v $ \values -> do
 111       c_hkl_geometry_axis_values_set gp values n unit nullPtr
 112
 113 foreign import ccall unsafe "hkl.h hkl_geometry_axis_values_set"
 114   c_hkl_geometry_axis_values_set :: Ptr HklGeometry -- geometry
 115                                  -> Ptr Double -- axis values
 116                                  -> CSize -- size of axis values
 117                                  -> CInt -- unit
 118                                  -> Ptr () -- gerror
 119                                  -> IO () -- IO CInt but for now do not deal with the errors
 120
 121 -- engine
 122
 123 enginePseudoAxisNamesGet' :: HklEngine -> IO [CString]
 124 enginePseudoAxisNamesGet' e = c_hkl_engine_pseudo_axis_names_get e >>= peekDArrayString
 125
 126 foreign import ccall unsafe "hkl.h hkl_engine_pseudo_axis_names_get"
 127   c_hkl_engine_pseudo_axis_names_get:: HklEngine -> IO (Ptr ()) -- darray_string
 128
 129 enginePseudoAxisNamesGet :: HklEngine -> IO [String]
 130 enginePseudoAxisNamesGet e = enginePseudoAxisNamesGet' e >>= mapM peekCString
 131
 132 enginePseudoAxisGet :: HklEngine -> CString -> IO Parameter
 133 enginePseudoAxisGet e n = c_hkl_engine_pseudo_axis_get e n nullPtr >>= peekParameter
 134
 135 foreign import ccall unsafe "hkl.h hkl_engine_pseudo_axis_get"
 136   c_hkl_engine_pseudo_axis_get:: HklEngine -> CString -> Ptr () -> IO (Ptr HklParameter)
 137
 138 foreign import ccall unsafe "hkl.h hkl_parameter_name_get"
 139   c_hkl_parameter_name_get:: Ptr HklParameter -> IO CString
 140
 141 foreign import ccall unsafe "hkl.h hkl_parameter_value_get"
 142   c_hkl_parameter_value_get:: Ptr HklParameter -> CInt -> IO Double
 143
 144 foreign import ccall unsafe "hkl.h hkl_parameter_min_max_get"
 145         c_hkl_parameter_min_max_get :: Ptr HklParameter -> Ptr Double -> Ptr Double -> CInt -> IO ()
 146
 147 enginePseudoAxesGet :: HklEngine -> IO [Parameter]
 148 enginePseudoAxesGet e = enginePseudoAxisNamesGet' e >>= mapM (enginePseudoAxisGet e)
 149
 150 -- engineList
 151
 152 engineListEnginesGet :: EngineList -> IO [HklEngine]
 153 engineListEnginesGet (EngineList e) = withForeignPtr e $ \ep -> do
 154   pdarray <- c_hkl_engine_list_engines_get ep
 155   n <- (#{peek darray_engine, size} pdarray) :: IO CSize
 156   engines <- #{peek darray_engine ,item} pdarray :: IO (Ptr HklEngine)
 157   peekArray (fromEnum n) engines
 158
 159 foreign import ccall unsafe "hkl.h hkl_engine_list_engines_get"
 160   c_hkl_engine_list_engines_get:: Ptr HklEngineList -> IO (Ptr ())
 161
 162 engineListPseudoAxesGet :: EngineList -> IO [[Parameter]]
 163 engineListPseudoAxesGet l@(EngineList e) =
 164   withForeignPtr e $ \ep ->
 165       engineListEnginesGet l >>= mapM enginePseudoAxesGet