From dca88928cc4595dfdd8ea62da45b1f94864ab4e3 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Picca=20Fr=C3=83=C2=A9d=C3=83=C2=A9ric-Emmanuel?= Date: Wed, 5 Apr 2017 14:56:33 +0200 Subject: [PATCH] [contrib][haskell] add the Hkl.C.Lattice module --- contrib/haskell/hkl.cabal | 1 + contrib/haskell/src/Hkl/C.hsc | 78 +----------------------- contrib/haskell/src/Hkl/C/Geometry.hsc | 4 +- contrib/haskell/src/Hkl/C/Lattice.hsc | 106 +++++++++++++++++++++++++++++++++ 4 files changed, 111 insertions(+), 78 deletions(-) create mode 100644 contrib/haskell/src/Hkl/C/Lattice.hsc diff --git a/contrib/haskell/hkl.cabal b/contrib/haskell/hkl.cabal index 7d13a7ea..3a4d4000 100644 --- a/contrib/haskell/hkl.cabal +++ b/contrib/haskell/hkl.cabal @@ -96,6 +96,7 @@ library , Hkl.C , Hkl.C.DArray , Hkl.C.Geometry + , Hkl.C.Lattice , Hkl.DataSource , Hkl.Detector , Hkl.Edf diff --git a/contrib/haskell/src/Hkl/C.hsc b/contrib/haskell/src/Hkl/C.hsc index cd86477b..c1170e45 100644 --- a/contrib/haskell/src/Hkl/C.hsc +++ b/contrib/haskell/src/Hkl/C.hsc @@ -30,14 +30,12 @@ import Foreign.C (CInt(..), CDouble(..), CSize(..), CString, peekCString, withCString) import Foreign.Storable -import Numeric.Units.Dimensional.Prelude ( meter, degree, radian, nano - , (*~), (/~)) import Pipes (Pipe, await, lift, yield) import Hkl.C.DArray as X import Hkl.C.Geometry as X +import Hkl.C.Lattice as X import Hkl.Detector -import Hkl.Lattice import Hkl.Types #include "hkl.h" @@ -48,7 +46,6 @@ data HklEngine data HklEngineList data HklGeometryList data HklGeometryListItem -data HklLattice data HklSample -- Engine @@ -358,79 +355,6 @@ foreign import ccall unsafe "hkl.h hkl_engine_list_init" foreign import ccall unsafe "hkl.h hkl_engine_list_get" c_hkl_engine_list_get:: Ptr HklEngineList -> IO () --- 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 ()) - -- Sample withSample :: Sample a -> (Ptr HklSample -> IO r) -> IO r diff --git a/contrib/haskell/src/Hkl/C/Geometry.hsc b/contrib/haskell/src/Hkl/C/Geometry.hsc index 86957a6a..b90c3700 100644 --- a/contrib/haskell/src/Hkl/C/Geometry.hsc +++ b/contrib/haskell/src/Hkl/C/Geometry.hsc @@ -1,7 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE CPP #-} module Hkl.C.Geometry ( Geometry(..) @@ -77,7 +77,9 @@ 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 diff --git a/contrib/haskell/src/Hkl/C/Lattice.hsc b/contrib/haskell/src/Hkl/C/Lattice.hsc new file mode 100644 index 00000000..5cb1d309 --- /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 ()) -- 2.11.4.GIT