Update upstream source from tag 'upstream/5.0.0.2456'

Update to upstream version '5.0.0.2456'
with Debian dir fdd1364b79a1292c1ac74d5d36b9b54742d56b0b

1 files changed, 91 insertions, 0 deletions

diff --git a/contrib/haskell/src/Hkl/C/Sample.hsc b/contrib/haskell/src/Hkl/C/Sample.hsc
new file mode 100644
index 0000000..d9c106c
--- /dev/null
+++ b/contrib/haskell/src/Hkl/C/Sample.hsc
@@ -0,0 +1,91 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE CPP #-}
+
+module Hkl.C.Sample
+       ( HklSample
+       , newSample
+       , withSample
+       ) where
+
+import Control.Monad (void)
+import Foreign ( ForeignPtr
+               , FunPtr
+               , Ptr
+               , nullPtr
+               , newForeignPtr
+               , withForeignPtr)
+import Foreign.C (CInt(..), CString, withCString)
+import Foreign.Storable
+
+import Hkl.C.Lattice
+import Hkl.Types
+
+#include "hkl.h"
+
+-- private types
+
+data HklSample
+
+-- Sample
+
+withSample :: Sample a -> (Ptr HklSample -> IO r) -> IO r
+withSample s fun = do
+  fptr <- newSample s
+  withForeignPtr fptr fun
+
+newSample :: Sample a -> IO (ForeignPtr HklSample)
+newSample (Sample name l ux uy uz) =
+    withCString name $ \cname -> do
+      sample <- c_hkl_sample_new cname
+      withLattice l $ \lattice -> do
+          c_hkl_sample_lattice_set sample lattice
+          go sample ux c_hkl_sample_ux_get c_hkl_sample_ux_set
+          go sample uy c_hkl_sample_uy_get c_hkl_sample_uy_set
+          go sample uz c_hkl_sample_uz_get c_hkl_sample_uz_set
+          newForeignPtr c_hkl_sample_free sample
+            where
+              go s p getter setter = do
+                fptr <- copyParameter =<< (getter s)
+                withForeignPtr fptr $ \ptr -> do
+                  poke ptr p
+                  void $ setter s ptr nullPtr
+
+foreign import ccall unsafe "hkl.h hkl_sample_new"
+  c_hkl_sample_new:: CString -> IO (Ptr HklSample)
+
+foreign import ccall unsafe "hkl.h hkl_sample_lattice_set"
+  c_hkl_sample_lattice_set :: Ptr HklSample -> Ptr HklLattice -> IO ()
+
+foreign import ccall unsafe "hkl.h &hkl_sample_free"
+  c_hkl_sample_free :: FunPtr (Ptr HklSample -> IO ())
+
+foreign import ccall unsafe "hkl.h hkl_sample_ux_get"
+  c_hkl_sample_ux_get :: Ptr HklSample
+                      -> IO (Ptr Parameter)
+
+foreign import ccall unsafe "hkl.h hkl_sample_uy_get"
+  c_hkl_sample_uy_get :: Ptr HklSample
+                      -> IO (Ptr Parameter)
+
+foreign import ccall unsafe "hkl.h hkl_sample_uz_get"
+  c_hkl_sample_uz_get :: Ptr HklSample
+                      -> IO (Ptr Parameter)
+
+foreign import ccall unsafe "hkl.h hkl_sample_ux_set"
+  c_hkl_sample_ux_set :: Ptr HklSample
+                      -> Ptr Parameter
+                      -> Ptr ()
+                      -> IO CInt
+
+foreign import ccall unsafe "hkl.h hkl_sample_uy_set"
+  c_hkl_sample_uy_set :: Ptr HklSample
+                      -> Ptr Parameter
+                      -> Ptr ()
+                      -> IO CInt
+
+foreign import ccall unsafe "hkl.h hkl_sample_uz_set"
+  c_hkl_sample_uz_set :: Ptr HklSample
+                      -> Ptr Parameter
+                      -> Ptr ()
+                      -> IO CInt