8 files changed, 712 insertions, 0 deletions
diff --git a/contrib/haskell/src/Hkl/C/DArray.hsc b/contrib/haskell/src/Hkl/C/DArray.hsc
new file mode 100644
index 0000000..82520ee
--- /dev/null
+++ b/contrib/haskell/src/Hkl/C/DArray.hsc
@@ -0,0 +1,25 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Hkl.C.DArray
+       (DArray(..)) where
+
+import Foreign (peekArray)
+import Foreign.C (CSize, CString)
+import Foreign.Storable (Storable(..))
+
+#include "hkl.h"
+
+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
+
+data DArray a = DArray CSize [a] deriving Show
+
+instance Storable (DArray CString) where
+  alignment _ = #{alignment darray_string}
+  sizeOf _ = #{size darray_string}
+  peek ptr = do
+    n <- (#{peek darray_string, size} ptr)
+    items <- #{peek darray_string ,item} ptr
+    ss <- peekArray (fromEnum n) items
+    return $ DArray n ss
diff --git a/contrib/haskell/src/Hkl/C/Detector.hsc b/contrib/haskell/src/Hkl/C/Detector.hsc
new file mode 100644
index 0000000..73c6b1d
--- /dev/null
+++ b/contrib/haskell/src/Hkl/C/Detector.hsc
@@ -0,0 +1,41 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GADTs #-}
+
+module Hkl.C.Detector
+       ( HklDetector
+       , newDetector
+       , withDetector
+       ) where
+
+import Prelude hiding (min, max)
+
+import Foreign ( ForeignPtr
+               , FunPtr
+               , Ptr
+               , newForeignPtr
+               , withForeignPtr)
+import Foreign.C (CInt(..))
+
+import Hkl.Detector
+
+#include "hkl.h"
+
+data HklDetector
+
+-- Detector
+
+withDetector :: Detector a -> (Ptr HklDetector -> IO b) -> IO b
+withDetector d func = do
+  fptr <- newDetector d
+  withForeignPtr fptr func
+
+newDetector :: Detector a -> IO (ForeignPtr HklDetector)
+newDetector ZeroD = c_hkl_detector_new 0 >>= newForeignPtr c_hkl_detector_free
+newDetector _ = error "Can not use 2D detector with the hkl library"
+
+foreign import ccall unsafe "hkl.h hkl_detector_new"
+  c_hkl_detector_new:: CInt -> IO (Ptr HklDetector)
+
+foreign import ccall unsafe "hkl.h &hkl_detector_free"
+  c_hkl_detector_free :: FunPtr (Ptr HklDetector -> IO ())
diff --git a/contrib/haskell/src/Hkl/C/Engine.hsc b/contrib/haskell/src/Hkl/C/Engine.hsc
new file mode 100644
index 0000000..9d5eced
--- /dev/null
+++ b/contrib/haskell/src/Hkl/C/Engine.hsc
@@ -0,0 +1,81 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GADTs #-}
+
+module Hkl.C.Engine
+       ( HklEngine
+       , engineName
+       , peekEngine
+       ) where
+
+import Prelude hiding (min, max)
+
+import Foreign (Ptr, nullPtr)
+import Foreign.C (CString, peekCString)
+import Foreign.Storable
+
+import Hkl.C.DArray
+import Hkl.Types
+
+#include "hkl.h"
+
+-- private types
+
+data HklEngine
+
+-- Engine
+
+engineName :: Engine -> String
+engineName (Engine name _ _) = name
+
+-- Engine
+
+peekMode :: Ptr HklEngine -> IO Mode
+peekMode e = do
+  name <- c_hkl_engine_current_mode_get e >>= peekCString
+  (DArray _ ns) <- peek =<< c_hkl_engine_parameters_names_get e
+  parameters <- mapM f ns
+  return (Mode name parameters)
+  where
+    f n = (c_hkl_engine_parameter_get e n nullPtr >>= peek)
+
+foreign import ccall unsafe "hkl.h hkl_engine_current_mode_get"
+  c_hkl_engine_current_mode_get :: Ptr HklEngine -> IO CString
+
+foreign import ccall unsafe "hkl.h hkl_engine_parameters_names_get"
+  c_hkl_engine_parameters_names_get:: Ptr HklEngine -> IO (Ptr (DArray CString))
+
+foreign import ccall unsafe "hkl.h hkl_engine_parameter_get"
+  c_hkl_engine_parameter_get:: Ptr HklEngine -> CString -> Ptr () -> IO (Ptr Parameter) -- darray_string
+
+
+peekEngine :: Ptr HklEngine -> IO Engine
+peekEngine e = do
+  name <- peekCString =<< c_hkl_engine_name_get e
+  ps <- enginePseudoAxesGet e
+  mode <- peekMode e
+  return (Engine name ps mode)
+
+-- engineNameGet :: Ptr HklEngine -> IO String
+-- engineNameGet engine = c_hkl_engine_name_get engine >>= peekCString
+
+foreign import ccall unsafe "hkl.h hkl_engine_name_get"
+  c_hkl_engine_name_get :: Ptr HklEngine -> IO CString
+
+foreign import ccall unsafe "hkl.h hkl_engine_pseudo_axis_names_get"
+  c_hkl_engine_pseudo_axis_names_get:: Ptr HklEngine -> IO (Ptr (DArray CString))
+
+-- enginePseudoAxisNamesGet :: Ptr HklEngine -> IO [String]
+-- enginePseudoAxisNamesGet e = enginePseudoAxisNamesGet' e >>= mapM peekCString
+
+enginePseudoAxisGet :: Ptr HklEngine -> CString -> IO Parameter
+enginePseudoAxisGet e n = c_hkl_engine_pseudo_axis_get e n nullPtr >>= peek
+
+foreign import ccall unsafe "hkl.h hkl_engine_pseudo_axis_get"
+  c_hkl_engine_pseudo_axis_get:: Ptr HklEngine -> CString -> Ptr () -> IO (Ptr Parameter)
+
+enginePseudoAxesGet :: Ptr HklEngine -> IO [Parameter]
+enginePseudoAxesGet ptr = do
+  (DArray _ ns) <- peek =<< c_hkl_engine_pseudo_axis_names_get ptr
+  mapM (enginePseudoAxisGet ptr) ns
+
diff --git a/contrib/haskell/src/Hkl/C/EngineList.hsc b/contrib/haskell/src/Hkl/C/EngineList.hsc
new file mode 100644
index 0000000..08232f6
--- /dev/null
+++ b/contrib/haskell/src/Hkl/C/EngineList.hsc
@@ -0,0 +1,60 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GADTs #-}
+
+module Hkl.C.EngineList
+       ( HklEngineList
+       , engineListEnginesGet
+       , newEngineList
+       , withEngineList
+       ) where
+
+import Prelude hiding (min, max)
+
+import Foreign ( ForeignPtr
+               , FunPtr
+               , Ptr
+               , newForeignPtr
+               , withForeignPtr
+               , peekArray)
+import Foreign.C ( CSize(..) )
+import Foreign.Storable
+
+import Hkl.C.Engine
+import Hkl.C.Geometry
+import Hkl.Types
+
+#include "hkl.h"
+
+-- private types
+
+data HklEngineList
+
+-- EngineList
+
+withEngineList :: Factory -> (Ptr HklEngineList -> IO b) -> IO b
+withEngineList f func = do
+  fptr <- newEngineList f
+  withForeignPtr fptr func
+
+newEngineList :: Factory -> IO (ForeignPtr HklEngineList)
+newEngineList f = newFactory f
+                  >>= c_hkl_factory_create_new_engine_list
+                  >>= newForeignPtr c_hkl_engine_list_free
+
+foreign import ccall unsafe "hkl.h hkl_factory_create_new_engine_list"
+  c_hkl_factory_create_new_engine_list:: Ptr HklFactory -> IO (Ptr HklEngineList)
+
+foreign import ccall unsafe "hkl.h &hkl_engine_list_free"
+  c_hkl_engine_list_free :: FunPtr (Ptr HklEngineList -> IO ())
+
+engineListEnginesGet :: Ptr HklEngineList -> IO [Engine]
+engineListEnginesGet e = do
+  pdarray <- c_hkl_engine_list_engines_get e
+  n <- (#{peek darray_engine, size} pdarray) :: IO CSize
+  engines <- #{peek darray_engine ,item} pdarray :: IO (Ptr (Ptr HklEngine))
+  enginess <- peekArray (fromEnum n) engines
+  mapM peekEngine enginess
+
+foreign import ccall unsafe "hkl.h hkl_engine_list_engines_get"
+  c_hkl_engine_list_engines_get:: Ptr HklEngineList -> IO (Ptr ())
diff --git a/contrib/haskell/src/Hkl/C/Geometry.hsc b/contrib/haskell/src/Hkl/C/Geometry.hsc
new file mode 100644
index 0000000..406c65d
--- /dev/null
+++ b/contrib/haskell/src/Hkl/C/Geometry.hsc
@@ -0,0 +1,188 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GADTs #-}
+
+module Hkl.C.Geometry
+       ( Geometry(..)
+       , Factory(..)
+       , HklFactory
+       , HklMatrix
+       , HklQuaternion
+       , factoryFromString
+       , newFactory
+       , newGeometry
+       , withGeometry
+       ) where
+
+import Prelude hiding (min, max)
+
+import Numeric.LinearAlgebra
+import Foreign ( ForeignPtr
+               , FunPtr
+               , Ptr
+               , nullPtr
+               , newForeignPtr
+               , withForeignPtr)
+import Foreign.C (CInt(..), CDouble(..), CSize(..), CString,
+                 peekCString, withCString)
+import Foreign.Storable
+
+import Numeric.Units.Dimensional.Prelude ( meter, nano
+                                         , (*~), (/~))
+
+import qualified Data.Vector.Storable as V
+import qualified Data.Vector.Storable.Mutable as MV
+
+import Hkl.Types
+import Hkl.C.DArray
+
+#include "hkl.h"
+
+-- | Factory
+
+data Factory = K6c | Uhv | MedH | MedV | SoleilSiriusKappa
+
+instance Show Factory where
+  show K6c = "K6C"
+  show Uhv = "ZAXIS"
+  show MedH = "todo"
+  show MedV = "todo"
+  show SoleilSiriusKappa = "SOLEIL SIRIUS KAPPA"
+
+factoryFromString :: String -> Factory
+factoryFromString s
+  | s == "K6C"  = K6c
+  | s == "ZAXIS" = Uhv
+  | s == "todo" = MedH
+  | s == "todo" = MedV
+  | s == "SOLEIL SIRIUS KAPPA" = SoleilSiriusKappa
+  | otherwise   = error $ "unknown diffractometer type:" ++ s
+
+-- | Geometry
+
+data Geometry = Geometry
+                Factory -- ^ the type of diffractometer
+                Source -- ^ source
+                (Vector Double) -- ^ axes position
+                (Maybe [Parameter]) -- ^ axes configuration
+              deriving (Show)
+
+
+-- private types
+
+data HklFactory
+data HklMatrix
+data HklQuaternion
+
+#if __GLASGOW_HASKELL__ <= 710
+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
+#endif
+
+-- Factory
+
+newFactory :: Factory -> IO (Ptr HklFactory)
+newFactory f = withCString (show f) $ \cname -> c_hkl_factory_get_by_name cname nullPtr
+
+foreign import ccall unsafe "hkl.h hkl_factory_get_by_name"
+  c_hkl_factory_get_by_name :: CString  -- ^ name
+                            -> Ptr () -- ^ GError (null for now)
+                            -> IO (Ptr HklFactory)
+-- Geometry
+
+peekSource :: Ptr Geometry -> IO (Source)
+peekSource ptr = do
+    (CDouble w) <- c_hkl_geometry_wavelength_get ptr unit
+    return (Source (w *~ nano meter))
+
+foreign import ccall unsafe "hkl.h hkl_geometry_wavelength_set"
+  c_hkl_geometry_wavelength_set :: Ptr Geometry -- geometry
+                                -> CDouble -- wavelength
+                                -> CInt -- unit
+                                -> Ptr () -- *gerror
+                                -> IO () -- IO CInt but for now do not deal with the errors
+
+pokeSource :: Ptr Geometry -> Source -> IO ()
+pokeSource ptr (Source lw) = do
+  let wavelength = CDouble (lw /~ nano meter)
+  c_hkl_geometry_wavelength_set ptr wavelength unit nullPtr
+
+foreign import ccall unsafe "hkl.h hkl_geometry_wavelength_get"
+  c_hkl_geometry_wavelength_get :: Ptr Geometry -- geometry
+                                -> CInt -- unit
+                                -> IO CDouble -- wavelength
+
+peekAxis :: Ptr Geometry -> CString -> IO Parameter
+peekAxis ptr s = c_hkl_geometry_axis_get ptr s nullPtr >>= peek
+
+instance Storable Geometry where
+  alignment _ = #{alignment int}
+
+  sizeOf _ = #{size int}
+
+  peek ptr = do
+    f_name <- c_hkl_geometry_name_get ptr >>= peekCString
+    let factory = factoryFromString f_name
+
+    source <- peekSource ptr
+
+    (DArray n axis_names) <- peek =<< c_hkl_geometry_axis_names_get ptr
+    v <- MV.new (fromEnum n)
+    MV.unsafeWith v $ \values ->
+      c_hkl_geometry_axis_values_get ptr values n unit
+    vs <- V.freeze v
+
+    ps <- mapM (peekAxis ptr) axis_names
+
+    return $ Geometry factory source vs (Just ps)
+
+  poke ptr (Geometry _ s vs _) = do
+    pokeSource ptr s
+    (DArray n _) <- peek =<< c_hkl_geometry_axis_names_get ptr
+    V.unsafeWith vs $ \values ->
+      c_hkl_geometry_axis_values_set ptr values n unit nullPtr
+
+foreign import ccall unsafe "hkl.h hkl_geometry_axis_values_get"
+  c_hkl_geometry_axis_values_get :: Ptr Geometry -- geometry
+                                 -> Ptr Double -- axis values
+                                 -> CSize -- size of axis values
+                                 -> CInt -- unit
+                                 -> IO () -- IO CInt but for now do not deal with the errors
+
+foreign import ccall unsafe "hkl.h hkl_geometry_axis_names_get"
+  c_hkl_geometry_axis_names_get :: Ptr Geometry -- goemetry
+                                -> IO (Ptr (DArray CString)) -- darray_string
+
+foreign import ccall unsafe "hkl.h hkl_geometry_axis_get"
+  c_hkl_geometry_axis_get :: Ptr Geometry -- geometry
+                          -> CString -- axis name
+                          -> Ptr () -- gerror
+                          -> IO (Ptr Parameter) -- parameter or nullPtr
+
+foreign import ccall unsafe "hkl.h hkl_geometry_name_get"
+  c_hkl_geometry_name_get :: Ptr Geometry -> IO CString
+
+foreign import ccall unsafe "hkl.h hkl_geometry_axis_values_set"
+  c_hkl_geometry_axis_values_set :: Ptr Geometry -- geometry
+                                 -> Ptr Double -- axis values
+                                 -> CSize -- size of axis values
+                                 -> CInt -- unit
+                                 -> Ptr () -- gerror
+                                 -> IO () -- IO CInt but for now do not deal with the errors
+
+withGeometry ::  Geometry -> (Ptr Geometry -> IO b) -> IO b
+withGeometry g fun = do
+  fptr <- newGeometry g
+  withForeignPtr fptr fun
+
+newGeometry :: Geometry -> IO (ForeignPtr Geometry)
+newGeometry g@(Geometry f _ _ _) = do
+  ptr <- c_hkl_factory_create_new_geometry =<< newFactory f
+  poke ptr g
+  newForeignPtr c_hkl_geometry_free ptr
+
+foreign import ccall unsafe "hkl.h hkl_factory_create_new_geometry"
+  c_hkl_factory_create_new_geometry :: Ptr HklFactory -> IO (Ptr Geometry)
+
+foreign import ccall unsafe "hkl.h &hkl_geometry_free"
+  c_hkl_geometry_free :: FunPtr (Ptr Geometry -> IO ())
diff --git a/contrib/haskell/src/Hkl/C/GeometryList.hsc b/contrib/haskell/src/Hkl/C/GeometryList.hsc
new file mode 100644
index 0000000..a51067c
--- /dev/null
+++ b/contrib/haskell/src/Hkl/C/GeometryList.hsc
@@ -0,0 +1,120 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE CPP #-}
+
+module Hkl.C.GeometryList
+       ( HklGeometryList
+       , geometryDetectorRotationGet
+       , getSolution0
+       , peekHklGeometryList
+       ) where
+
+import Prelude hiding (min, max)
+
+import Control.Monad.Loops (unfoldrM)
+import Numeric.LinearAlgebra
+import Foreign ( ForeignPtr
+               , FunPtr
+               , Ptr
+               , nullPtr
+               , newForeignPtr
+               , withForeignPtr)
+import Foreign.C (CInt(..), CDouble(..))
+import Foreign.Storable
+
+import Hkl.C.Detector
+import Hkl.C.Geometry
+import Hkl.Detector
+
+#include "hkl.h"
+
+-- private types
+
+data HklGeometryList
+data HklGeometryListItem
+
+-- | HklGeometryList
+
+getSolution0 :: ForeignPtr HklGeometryList -> IO Geometry
+getSolution0 gl = withForeignPtr gl $ \solutions ->
+                  c_hkl_geometry_list_items_first_get solutions
+                  >>= c_hkl_geometry_list_item_geometry_get
+                  >>= peek
+
+buildMatrix' :: Element a => CInt -> CInt -> ((CInt, CInt) -> IO a) -> IO (Matrix a)
+buildMatrix' rc cc f = do
+   let coordinates' = map (\ ri -> map (\ ci -> (ri, ci)) [0 .. (cc - 1)]) [0 .. (rc - 1)]
+   l <- mapM (mapM f) coordinates'
+   return $ fromLists l
+
+
+    -- fromLists $ map (map f)
+    --     $ map (\ ri -> map (\ ci -> (ri, ci)) [0 .. (cc - 1)]) [0 .. (rc - 1)]
+
+geometryDetectorRotationGet :: Geometry -> Detector a -> IO (Matrix Double)
+geometryDetectorRotationGet g d  = do
+  f_geometry <- newGeometry g
+  f_detector <- newDetector d
+  withForeignPtr f_detector $ \detector ->
+    withForeignPtr f_geometry $ \geometry -> do
+      f_q <- newForeignPtr c_hkl_quaternion_free =<< c_hkl_geometry_detector_rotation_get_binding geometry detector
+      withForeignPtr f_q $ \quaternion -> do
+        f_m <- newForeignPtr c_hkl_matrix_free =<< c_hkl_quaternion_to_matrix_binding quaternion
+        withForeignPtr f_m $ \matrix' ->
+          buildMatrix' 3 3 (getV matrix')
+          where
+            getV :: Ptr HklMatrix -> (CInt, CInt) -> IO Double
+            getV m (i', j') = do
+              (CDouble v) <- c_hkl_matrix_get m i' j'
+              return v
+
+foreign import ccall unsafe "hkl.h hkl_geometry_detector_rotation_get_binding"
+  c_hkl_geometry_detector_rotation_get_binding :: Ptr Geometry
+                                               -> Ptr HklDetector
+                                               -> IO (Ptr HklQuaternion)
+
+foreign import ccall unsafe "hkl.h hkl_quaternion_to_matrix_binding"
+  c_hkl_quaternion_to_matrix_binding :: Ptr HklQuaternion
+                                     -> IO (Ptr HklMatrix)
+
+foreign import ccall unsafe "hkl.h &hkl_quaternion_free"
+  c_hkl_quaternion_free :: FunPtr (Ptr HklQuaternion -> IO ())
+
+foreign import ccall unsafe "hkl.h &hkl_matrix_free"
+  c_hkl_matrix_free :: FunPtr (Ptr HklMatrix -> IO ())
+
+foreign import ccall unsafe "hkl.h hkl_matrix_get"
+  c_hkl_matrix_get :: Ptr HklMatrix
+                   -> CInt
+                   -> CInt
+                   -> IO CDouble
+
+
+peekItems :: Ptr HklGeometryList -> IO [Ptr HklGeometryListItem]
+peekItems l = c_hkl_geometry_list_items_first_get l >>= unfoldrM go
+   where
+      go e
+         | e == nullPtr = return Nothing
+         | otherwise    = do
+               next <- c_hkl_geometry_list_items_next_get l e
+               return (Just (e, next))
+
+peekHklGeometryList :: ForeignPtr HklGeometryList -> IO [Geometry]
+peekHklGeometryList l = withForeignPtr l $ \ls -> do
+  items <- peekItems ls
+  mapM extract items
+    where
+      extract it = c_hkl_geometry_list_item_geometry_get it >>= peek
+
+foreign import ccall unsafe "hkl.h hkl_geometry_list_items_first_get"
+  c_hkl_geometry_list_items_first_get :: Ptr HklGeometryList
+                                      -> IO (Ptr HklGeometryListItem)
+
+foreign import ccall unsafe "hkl.h hkl_geometry_list_items_next_get"
+  c_hkl_geometry_list_items_next_get :: Ptr HklGeometryList
+                                     -> Ptr HklGeometryListItem
+                                     -> IO (Ptr HklGeometryListItem)
+
+foreign import ccall unsafe "hkl.h hkl_geometry_list_item_geometry_get"
+  c_hkl_geometry_list_item_geometry_get :: Ptr HklGeometryListItem
+                                        -> IO (Ptr Geometry)
diff --git a/contrib/haskell/src/Hkl/C/Lattice.hsc b/contrib/haskell/src/Hkl/C/Lattice.hsc
new file mode 100644
index 0000000..5cb1d30
--- /dev/null
+++ b/contrib/haskell/src/Hkl/C/Lattice.hsc
@@ -0,0 +1,106 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GADTs #-}
+
+module Hkl.C.Lattice
+       ( HklLattice
+       , newLattice
+       , withLattice
+       ) where
+
+import Prelude hiding (min, max)
+
+import Foreign ( ForeignPtr
+               , FunPtr
+               , Ptr
+               , nullPtr
+               , newForeignPtr
+               , withForeignPtr)
+import Foreign.C (CDouble(..))
+
+import Numeric.Units.Dimensional.Prelude ( meter, degree, radian, nano
+                                         , (*~), (/~))
+import Hkl.Lattice
+
+#include "hkl.h"
+
+#if __GLASGOW_HASKELL__ <= 710
+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
+#endif
+
+-- private types
+
+data HklLattice
+
+-- Lattice
+
+withLattice :: Lattice a -> (Ptr HklLattice -> IO r) -> IO r
+withLattice l func = do
+  fptr <- newLattice l
+  withForeignPtr fptr func
+
+newLattice' :: CDouble
+            -> CDouble
+            -> CDouble
+            -> CDouble
+            -> CDouble
+            -> CDouble
+            -> IO (ForeignPtr HklLattice)
+newLattice' a b c alpha beta gamma = do
+  lattice <- c_hkl_lattice_new a b c alpha beta gamma nullPtr
+  newForeignPtr c_hkl_lattice_free lattice
+
+newLattice :: Lattice a -> IO (ForeignPtr HklLattice)
+newLattice  (Cubic la) = do
+  let a = CDouble (la /~ nano meter)
+  let alpha = CDouble ((90 *~ degree) /~ radian)
+  newLattice' a a a alpha alpha alpha
+newLattice (Tetragonal la lc) = do
+  let a = CDouble (la /~ nano meter)
+  let c = CDouble (lc /~ nano meter)
+  let alpha = CDouble ((90 *~ degree) /~ radian)
+  newLattice' a a c alpha alpha alpha
+newLattice  (Orthorhombic la lb lc) = do
+  let a = CDouble (la /~ nano meter)
+  let b = CDouble (lb /~ nano meter)
+  let c = CDouble (lc /~ nano meter)
+  let alpha = CDouble ((90 *~ degree) /~ radian)
+  newLattice' a b c alpha alpha alpha
+newLattice (Rhombohedral la aalpha) = do
+  let a = CDouble (la /~ nano meter)
+  let alpha = CDouble (aalpha /~ radian)
+  newLattice' a a a alpha alpha alpha
+newLattice (Hexagonal la lc) = do
+  let a = CDouble (la /~ nano meter)
+  let c = CDouble (lc /~ nano meter)
+  let alpha = CDouble ((90 *~ degree) /~ radian)
+  let gamma = CDouble ((120 *~ degree) /~ radian)
+  newLattice' a a c alpha alpha gamma
+newLattice (Monoclinic la lb lc abeta) = do
+  let a = CDouble (la /~ nano meter)
+  let b = CDouble (lb /~ nano meter)
+  let c = CDouble (lc /~ nano meter)
+  let alpha = CDouble ((90 *~ degree) /~ radian)
+  let beta = CDouble (abeta /~ radian)
+  newLattice' a b c alpha beta alpha
+newLattice (Triclinic la lb lc aalpha abeta agamma) = do
+  let a = CDouble (la /~ nano meter)
+  let b = CDouble (lb /~ nano meter)
+  let c = CDouble (lc /~ nano meter)
+  let alpha = CDouble (aalpha /~ radian)
+  let beta = CDouble (abeta /~ radian)
+  let gamma = CDouble (agamma /~ radian)
+  newLattice' a b c alpha beta gamma
+
+foreign import ccall unsafe "hkl.h hkl_lattice_new"
+  c_hkl_lattice_new :: CDouble -- a
+                    -> CDouble -- b
+                    -> CDouble -- c
+                    -> CDouble -- alpha
+                    -> CDouble -- beta
+                    -> CDouble -- gamma
+                    -> Ptr () -- *gerror
+                    -> IO (Ptr HklLattice)
+
+foreign import ccall unsafe "hkl.h &hkl_lattice_free"
+  c_hkl_lattice_free :: FunPtr (Ptr HklLattice -> IO ())
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