contrib/haskell/src/Hkl/C.hsc

   1 {-# LANGUAGE ForeignFunctionInterface #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE CPP #-}
   4
   5 module Hkl.C
   6        ( compute
   7        , computePipe
   8        , solve
   9        , solveTraj
  10        , solveTrajPipe
  11        , module X
  12        ) where
  13
  14 import Prelude hiding (min, max)
  15
  16 import Control.Monad (forever)
  17 import Control.Monad.Trans.State.Strict
  18 import Foreign ( ForeignPtr
  19                , FunPtr
  20                , Ptr
  21                , nullPtr
  22                , newForeignPtr
  23                , withForeignPtr
  24                , peekArray
  25                , withArray)
  26 import Foreign.C (CInt(..), CSize(..), CString,
  27                  peekCString, withCString)
  28 import Foreign.Storable
  29
  30 import Pipes (Pipe, await, lift, yield)
  31
  32 import Hkl.C.DArray as X
  33 import Hkl.C.Detector as X
  34 import Hkl.C.Geometry as X
  35 import Hkl.C.GeometryList as X
  36 import Hkl.C.Lattice as X
  37 import Hkl.C.Sample as X
  38 import Hkl.Detector
  39 import Hkl.Types
  40
  41 #include "hkl.h"
  42
  43 -- private types
  44
  45 data HklEngine
  46 data HklEngineList
  47
  48 -- Engine
  49
  50 solve' :: Ptr HklEngine -> Engine -> IO (ForeignPtr HklGeometryList)
  51 solve' engine (Engine _ ps _) = do
  52   let positions = [v | (Parameter _ v _) <- ps]
  53   let n = toEnum (length positions)
  54   withArray positions $ \values ->
  55       c_hkl_engine_pseudo_axis_values_set engine values n unit nullPtr
  56       >>= newForeignPtr c_hkl_geometry_list_free
  57
  58 solve :: Geometry -> Detector a -> Sample b -> Engine -> IO [Geometry]
  59 solve g@(Geometry f _ _ _) d s e@(Engine name _ _) = do
  60   withSample s $ \sample ->
  61       withDetector d $ \detector ->
  62           withGeometry g $ \geometry ->
  63               withEngineList f $ \engines ->
  64                   withCString name $ \cname -> do
  65                   c_hkl_engine_list_init engines geometry detector sample
  66                   engine <- c_hkl_engine_list_engine_get_by_name engines cname nullPtr
  67                   solve' engine e >>= peekHklGeometryList
  68
  69 engineName :: Engine -> String
  70 engineName (Engine name _ _) = name
  71
  72 solveTraj :: Geometry -> Detector a -> Sample b -> [Engine] -> IO [Geometry]
  73 solveTraj g@(Geometry f _ _ _) d s es = do
  74   let name = engineName (head es)
  75   withSample s $ \sample ->
  76       withDetector d $ \detector ->
  77           withGeometry g $ \geometry ->
  78               withEngineList f $ \engines ->
  79                 withCString name $ \cname -> do
  80                   c_hkl_engine_list_init engines geometry detector sample
  81                   engine <- c_hkl_engine_list_engine_get_by_name engines cname nullPtr
  82                   mapM (\e -> solve' engine e >>= getSolution0) es
  83
  84 -- Pipe
  85
  86 data Diffractometer = Diffractometer { difEngineList :: (ForeignPtr HklEngineList)
  87                                      , difGeometry :: (ForeignPtr Geometry)
  88                                      , difDetector :: (ForeignPtr HklDetector)
  89                                      , difSample :: (ForeignPtr HklSample)
  90                                      }
  91                     deriving (Show)
  92
  93 withDiffractometer :: Diffractometer -> (Ptr HklEngineList -> IO b) -> IO b
  94 withDiffractometer d fun = do
  95   let f_engines = difEngineList d
  96   withForeignPtr f_engines fun
  97
  98 newDiffractometer :: Geometry -> Detector a -> Sample b -> IO Diffractometer
  99 newDiffractometer g@(Geometry f _ _ _) d s = do
 100   f_engines <- newEngineList f
 101   f_geometry <- newGeometry g
 102   f_detector <- newDetector d
 103   f_sample <- newSample s
 104   withForeignPtr f_sample $ \sample ->
 105     withForeignPtr f_detector $ \detector ->
 106     withForeignPtr f_geometry $ \geometry ->
 107     withForeignPtr f_engines $ \engines -> do
 108       c_hkl_engine_list_init engines geometry detector sample
 109       return $ Diffractometer { difEngineList = f_engines
 110                               , difGeometry = f_geometry
 111                               , difDetector = f_detector
 112                               , difSample = f_sample
 113                               }
 114
 115 computePipe :: Detector a -> Sample b -> Pipe Geometry [Engine] IO ()
 116 computePipe d s = forever $ do
 117   g <- await
 118   e <- lift $ compute g d s
 119   yield e
 120
 121 solveTrajPipe :: Geometry -> Detector a -> Sample b -> Pipe Engine Geometry IO ()
 122 solveTrajPipe g d s = do
 123   dif <- lift $ newDiffractometer g d s
 124   solveTrajPipe' dif
 125
 126 solveTrajPipe' :: Diffractometer -> Pipe Engine Geometry IO ()
 127 solveTrajPipe' dif = flip evalStateT dif $ forever $ do
 128     -- Inside here we are using `StateT Diffractometer (Pipe Engine Geometry IO ()) r`
 129     e <- lift await
 130     dif_ <- get
 131     let name = engineName e
 132     solutions <- lift . lift $ withDiffractometer dif_ $ \engines ->
 133      withCString name $ \cname -> do
 134        engine <- c_hkl_engine_list_engine_get_by_name engines cname nullPtr
 135        solve' engine e >>= getSolution0
 136     put dif_
 137     lift $ yield solutions
 138
 139 foreign import ccall unsafe "hkl.h hkl_engine_list_engine_get_by_name"
 140   c_hkl_engine_list_engine_get_by_name :: Ptr HklEngineList --engine list
 141                                        -> CString -- engine name
 142                                        -> Ptr () --  gerror need to deal about this
 143                                        -> IO (Ptr HklEngine) -- the returned HklEngine
 144
 145 foreign import ccall unsafe "hkl.h hkl_engine_pseudo_axis_values_set"
 146   c_hkl_engine_pseudo_axis_values_set :: Ptr HklEngine
 147                                       -> Ptr Double --values
 148                                       -> CSize -- n_values
 149                                       -> CInt -- unit_type
 150                                       -> Ptr () --  GError **error
 151                                       -> IO (Ptr HklGeometryList)
 152
 153 foreign import ccall unsafe "hkl.h &hkl_geometry_list_free"
 154   c_hkl_geometry_list_free :: FunPtr (Ptr HklGeometryList -> IO ())
 155
 156 -- Engine
 157
 158 peekMode :: Ptr HklEngine -> IO Mode
 159 peekMode e = do
 160   name <- c_hkl_engine_current_mode_get e >>= peekCString
 161   (DArray _ ns) <- peek =<< c_hkl_engine_parameters_names_get e
 162   parameters <- mapM f ns
 163   return (Mode name parameters)
 164   where
 165     f n = (c_hkl_engine_parameter_get e n nullPtr >>= peek)
 166
 167 foreign import ccall unsafe "hkl.h hkl_engine_current_mode_get"
 168   c_hkl_engine_current_mode_get :: Ptr HklEngine -> IO CString
 169
 170 foreign import ccall unsafe "hkl.h hkl_engine_parameters_names_get"
 171   c_hkl_engine_parameters_names_get:: Ptr HklEngine -> IO (Ptr (DArray CString))
 172
 173 foreign import ccall unsafe "hkl.h hkl_engine_parameter_get"
 174   c_hkl_engine_parameter_get:: Ptr HklEngine -> CString -> Ptr () -> IO (Ptr Parameter) -- darray_string
 175
 176
 177 peekEngine :: Ptr HklEngine -> IO Engine
 178 peekEngine e = do
 179   name <- peekCString =<< c_hkl_engine_name_get e
 180   ps <- enginePseudoAxesGet e
 181   mode <- peekMode e
 182   return (Engine name ps mode)
 183
 184 -- engineNameGet :: Ptr HklEngine -> IO String
 185 -- engineNameGet engine = c_hkl_engine_name_get engine >>= peekCString
 186
 187 foreign import ccall unsafe "hkl.h hkl_engine_name_get"
 188   c_hkl_engine_name_get :: Ptr HklEngine -> IO CString
 189
 190 foreign import ccall unsafe "hkl.h hkl_engine_pseudo_axis_names_get"
 191   c_hkl_engine_pseudo_axis_names_get:: Ptr HklEngine -> IO (Ptr (DArray CString))
 192
 193 -- enginePseudoAxisNamesGet :: Ptr HklEngine -> IO [String]
 194 -- enginePseudoAxisNamesGet e = enginePseudoAxisNamesGet' e >>= mapM peekCString
 195
 196 enginePseudoAxisGet :: Ptr HklEngine -> CString -> IO Parameter
 197 enginePseudoAxisGet e n = c_hkl_engine_pseudo_axis_get e n nullPtr >>= peek
 198
 199 foreign import ccall unsafe "hkl.h hkl_engine_pseudo_axis_get"
 200   c_hkl_engine_pseudo_axis_get:: Ptr HklEngine -> CString -> Ptr () -> IO (Ptr Parameter)
 201
 202 enginePseudoAxesGet :: Ptr HklEngine -> IO [Parameter]
 203 enginePseudoAxesGet ptr = do
 204   (DArray _ ns) <- peek =<< c_hkl_engine_pseudo_axis_names_get ptr
 205   mapM (enginePseudoAxisGet ptr) ns
 206
 207 -- EngineList
 208
 209 withEngineList :: Factory -> (Ptr HklEngineList -> IO b) -> IO b
 210 withEngineList f func = do
 211   fptr <- newEngineList f
 212   withForeignPtr fptr func
 213
 214 newEngineList :: Factory -> IO (ForeignPtr HklEngineList)
 215 newEngineList f = newFactory f
 216                   >>= c_hkl_factory_create_new_engine_list
 217                   >>= newForeignPtr c_hkl_engine_list_free
 218
 219 foreign import ccall unsafe "hkl.h hkl_factory_create_new_engine_list"
 220   c_hkl_factory_create_new_engine_list:: Ptr HklFactory -> IO (Ptr HklEngineList)
 221
 222 foreign import ccall unsafe "hkl.h &hkl_engine_list_free"
 223   c_hkl_engine_list_free :: FunPtr (Ptr HklEngineList -> IO ())
 224
 225 engineListEnginesGet :: Ptr HklEngineList -> IO [Engine]
 226 engineListEnginesGet e = do
 227   pdarray <- c_hkl_engine_list_engines_get e
 228   n <- (#{peek darray_engine, size} pdarray) :: IO CSize
 229   engines <- #{peek darray_engine ,item} pdarray :: IO (Ptr (Ptr HklEngine))
 230   enginess <- peekArray (fromEnum n) engines
 231   mapM peekEngine enginess
 232
 233 foreign import ccall unsafe "hkl.h hkl_engine_list_engines_get"
 234   c_hkl_engine_list_engines_get:: Ptr HklEngineList -> IO (Ptr ())
 235
 236 compute :: Geometry -> Detector a -> Sample b -> IO [Engine]
 237 compute g@(Geometry f _ _ _) d s = do
 238   withSample s $ \sample ->
 239       withDetector d $ \detector ->
 240           withGeometry g $ \geometry ->
 241               withEngineList f $ \engines -> do
 242                     c_hkl_engine_list_init engines geometry detector sample
 243                     c_hkl_engine_list_get engines
 244                     engineListEnginesGet engines
 245
 246 foreign import ccall unsafe "hkl.h hkl_engine_list_init"
 247   c_hkl_engine_list_init:: Ptr HklEngineList -> Ptr Geometry -> Ptr HklDetector -> Ptr HklSample -> IO ()
 248
 249 foreign import ccall unsafe "hkl.h hkl_engine_list_get"
 250   c_hkl_engine_list_get:: Ptr HklEngineList -> IO ()