1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE DeriveAnyClass #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE FlexibleContexts #-}
5 {-# LANGUAGE FlexibleInstances #-}
6 {-# LANGUAGE MultiParamTypeClasses #-}
7 {-# LANGUAGE OverloadedStrings #-}
8 {-# LANGUAGE RankNTypes #-}
9 {-# LANGUAGE ScopedTypeVariables #-}
10 {-# LANGUAGE TypeFamilies #-}
12 {-# OPTIONS_GHC -fno-warn-orphans #-}
15 Copyright : Copyright (C) 2014-2024 Synchrotron SOLEIL
16 L'Orme des Merisiers Saint-Aubin
17 BP 48 91192 GIF-sur-YVETTE CEDEX
20 Maintainer : Picca Frédéric-Emmanuel <picca@synchrotron-soleil.fr>
21 Stability : Experimental
22 Portability: GHC only (not tested)
25 module Hkl
.Binoculars
.Config
.Sample
26 ( BinocularsConfig
'Sample
(..)
27 , default'BinocularsConfig
'Sample
28 , default'DataSourcePath
'Sample
29 , guess
'DataSourcePath
'Sample
30 , overload
'DataSourcePath
'Sample
31 , parse
'BinocularsConfig
'Sample
34 import Data
.Aeson
(FromJSON
, ToJSON
)
35 import Data
.HashMap
.Lazy
(fromList
)
36 import Data
.Ini
(Ini
(..))
37 import Data
.Text
(Text
)
38 import GHC
.Generics
(Generic
)
40 import Hkl
.Binoculars
.Config
41 import Hkl
.Binoculars
.Config
.Common
52 instance DataSource Sample
where
53 data DataSourcePath Sample
54 = DataSourcePath
'Sample
55 (DataSourcePath
Double) -- a
56 (DataSourcePath
Double) -- b
57 (DataSourcePath
Double) -- c
58 (DataSourcePath Degree
) -- alpha
59 (DataSourcePath Degree
) -- beta
60 (DataSourcePath Degree
) -- gamma
61 (DataSourcePath Degree
) -- ux
62 (DataSourcePath Degree
) -- uy
63 (DataSourcePath Degree
) -- uz
64 | DataSourcePath
'Sample
'Or
(DataSourcePath Sample
) (DataSourcePath Sample
)
65 deriving (FromJSON
, Generic
, Show, ToJSON
)
67 data DataSourceAcq Sample
68 = DataSourceAcq
'Sample
69 (DataSourceAcq
Double)
70 (DataSourceAcq
Double)
71 (DataSourceAcq
Double)
72 (DataSourceAcq Degree
)
73 (DataSourceAcq Degree
)
74 (DataSourceAcq Degree
)
75 (DataSourceAcq Degree
)
76 (DataSourceAcq Degree
)
77 (DataSourceAcq Degree
)
79 withDataSourceP f
(DataSourcePath
'Sample a b c alpha beta gamma ux uy uz
) g
=
80 withDataSourceP f a
$ \a' ->
81 withDataSourceP f b
$ \b' ->
82 withDataSourceP f c
$ \c
' ->
83 withDataSourceP f alpha
$ \alpha
' ->
84 withDataSourceP f beta
$ \beta
' ->
85 withDataSourceP f gamma
$ \gamma
' ->
86 withDataSourceP f ux
$ \ux
' ->
87 withDataSourceP f uy
$ \uy
' ->
88 withDataSourceP f uz
$ \uz
' -> g
(DataSourceAcq
'Sample a
' b
' c
' alpha
' beta
' gamma
' ux
' uy
' uz
')
89 withDataSourceP f
(DataSourcePath
'Sample
'Or l r
) g
= withDataSourcePOr f l r g
91 instance Is0DStreamable
(DataSourceAcq Sample
) Sample
where
92 extract0DStreamValue
(DataSourceAcq
'Sample a b c alpha beta gamma ux uy uz
) =
95 <$> extract0DStreamValue a
96 <*> extract0DStreamValue b
97 <*> extract0DStreamValue c
98 <*> extract0DStreamValue alpha
99 <*> extract0DStreamValue beta
100 <*> extract0DStreamValue gamma
)
102 <$> extract0DStreamValue ux
103 <*> pure
(Range
0 0))
105 <$> extract0DStreamValue uy
106 <*> pure
(Range
0 0))
108 <$> extract0DStreamValue uz
109 <*> pure
(Range
0 0))
111 default'DataSourcePath
'Sample
:: DataSourcePath Sample
112 default'DataSourcePath
'Sample
= DataSourcePath
'Sample
113 (DataSourcePath
'Double(hdf5p
$ grouppat
0 $ datasetp
"SIXS/I14-C-CX2__EX__DIFF-UHV__#1/A"))
114 (DataSourcePath
'Double(hdf5p
$ grouppat
0 $ datasetp
"SIXS/I14-C-CX2__EX__DIFF-UHV__#1/B"))
115 (DataSourcePath
'Double(hdf5p
$ grouppat
0 $ datasetp
"SIXS/I14-C-CX2__EX__DIFF-UHV__#1/C"))
116 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ datasetp
"SIXS/I14-C-CX2__EX__DIFF-UHV__#1/Alpha"))
117 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ datasetp
"SIXS/I14-C-CX2__EX__DIFF-UHV__#1/Beta"))
118 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ datasetp
"SIXS/I14-C-CX2__EX__DIFF-UHV__#1/Gamma"))
119 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ datasetp
"SIXS/I14-C-CX2__EX__DIFF-UHV__#1/Ux"))
120 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ datasetp
"SIXS/I14-C-CX2__EX__DIFF-UHV__#1/Uy"))
121 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ datasetp
"SIXS/I14-C-CX2__EX__DIFF-UHV__#1/Uz"))
124 overload
'DataSourcePath
'Sample
:: BinocularsConfig
'Sample
125 -> DataSourcePath Sample
126 -> DataSourcePath Sample
127 overload
'DataSourcePath
'Sample
(BinocularsConfig
'Sample ma mb mc malpha mbeta mgamma mux muy muz
) (DataSourcePath
'Sample pa pb pc palpha pbeta pgamma pux puy puz
)
128 = DataSourcePath
'Sample
129 (maybe pa DataSourcePath
'Double'Const ma
)
130 (maybe pb DataSourcePath
'Double'Const mb
)
131 (maybe pc DataSourcePath
'Double'Const mc
)
132 (maybe palpha DataSourcePath
'Degree
'Const malpha
)
133 (maybe pbeta DataSourcePath
'Degree
'Const mbeta
)
134 (maybe pgamma DataSourcePath
'Degree
'Const mgamma
)
135 (maybe pux DataSourcePath
'Degree
'Const mux
)
136 (maybe puy DataSourcePath
'Degree
'Const muy
)
137 (maybe puz DataSourcePath
'Degree
'Const muz
)
138 overload
'DataSourcePath
'Sample c
(DataSourcePath
'Sample
'Or l r
)
139 = DataSourcePath
'Sample
'Or
140 (overload
'DataSourcePath
'Sample c l
)
141 (overload
'DataSourcePath
'Sample c r
)
143 guess
'DataSourcePath
'Sample
:: BinocularsConfig
'Common
144 -> BinocularsConfig
'Sample
145 -> DataSourcePath Sample
146 guess
'DataSourcePath
'Sample common sample
=
147 do let inputType
= binocularsConfig
'Common
'InputType common
148 let samplePath
' beamline device
=
149 DataSourcePath
'Sample
150 (DataSourcePath
'Double(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"A"))
151 (DataSourcePath
'Double(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"B"))
152 (DataSourcePath
'Double(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"C"))
153 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"alpha"))
154 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"beta"))
155 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"gamma"))
156 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"Ux"))
157 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"Uy"))
158 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"Uz"))
159 let sampleMarsPath beamline device
=
160 DataSourcePath
'Sample
161 (DataSourcePath
'Double(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"a"))
162 (DataSourcePath
'Double(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"b"))
163 (DataSourcePath
'Double(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"c"))
164 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"alpha"))
165 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"beta"))
166 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"gamma"))
167 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"u_x"))
168 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"u_y"))
169 (DataSourcePath
'Degree
(hdf5p
$ grouppat
0 $ groupp beamline
$ groupp device
$ datasetp
"u_z"))
170 let cristalSamplePath
= samplePath
' "NOBEAMLINE" "NOBEAMLINE"
171 let marsSamplePath
= sampleMarsPath
"MARS" "d03-1-cx2__ex__dif-cm_#1"
172 let medHSamplePath
= samplePath
' "SIXS" "i14-c-cx1-ex-cm-med.h"
173 let medVSamplePath
= samplePath
' "SIXS" "i14-c-cx1-ex-cm-med.v"
174 let uhvSamplePath
= samplePath
' "SIXS" "I14-C-CX2__EX__DIFF-UHV__#1"
175 `DataSourcePath
'Sample
'Or`
176 samplePath
' "SIXS" "i14-c-cx2-ex-cm-uhv"
178 let samplePath
= case inputType
of
179 CristalK6C
-> cristalSamplePath
180 MarsFlyscan
-> marsSamplePath
181 MarsSbs
-> marsSamplePath
182 SixsFlyMedH
-> medHSamplePath
183 SixsFlyMedHGisaxs
-> medHSamplePath
184 SixsFlyMedV
-> medVSamplePath
185 SixsFlyMedVGisaxs
-> medVSamplePath
186 SixsFlyUhv
-> uhvSamplePath
187 SixsFlyUhvGisaxs
-> uhvSamplePath
188 SixsSbsMedH
-> medHSamplePath
189 SixsSbsMedHGisaxs
-> medHSamplePath
190 SixsSbsMedV
-> medVSamplePath
191 SixsSbsMedVGisaxs
-> medVSamplePath
192 SixsSbsUhv
-> uhvSamplePath
193 SixsSbsUhvGisaxs
-> uhvSamplePath
195 overload
'DataSourcePath
'Sample sample samplePath
201 data BinocularsConfig
'Sample
202 = BinocularsConfig
'Sample
203 { binocularsConfig
'Sample
'A
:: Maybe Double
204 , binocularsConfig
'Sample
'B
:: Maybe Double
205 , binocularsConfig
'Sample
'C
:: Maybe Double
206 , binocularsConfig
'Sample
'Alpha
:: Maybe Degree
207 , binocularsConfig
'Sample
'Beta
:: Maybe Degree
208 , binocularsConfig
'Sample
'Gamma
:: Maybe Degree
209 , binocularsConfig
'Sample
'Ux
:: Maybe Degree
210 , binocularsConfig
'Sample
'Uy
:: Maybe Degree
211 , binocularsConfig
'Sample
'Uz
:: Maybe Degree
212 } deriving (Eq
, Show, Generic
)
214 default'BinocularsConfig
'Sample
:: BinocularsConfig
'Sample
215 default'BinocularsConfig
'Sample
216 = BinocularsConfig
'Sample
217 { binocularsConfig
'Sample
'A
= Nothing
218 , binocularsConfig
'Sample
'B
= Nothing
219 , binocularsConfig
'Sample
'C
= Nothing
220 , binocularsConfig
'Sample
'Alpha
= Nothing
221 , binocularsConfig
'Sample
'Beta
= Nothing
222 , binocularsConfig
'Sample
'Gamma
= Nothing
223 , binocularsConfig
'Sample
'Ux
= Nothing
224 , binocularsConfig
'Sample
'Uy
= Nothing
225 , binocularsConfig
'Sample
'Uz
= Nothing
228 instance ToIni BinocularsConfig
'Sample
where
229 toIni c
= Ini
{ iniSections
= fromList
[ ("input", elemFMbDef
"a" binocularsConfig
'Sample
'A c
default'BinocularsConfig
'Sample
230 [ "`a` parameter of the sample lattice (same unit than the wavelength)."
232 , "This parameter with the 5 others, `b`, `c`, `alpha`, `beta` and `gamma`"
233 , "can be set in order to overwrite the values from the data file."
235 , " `<not set>` - read `a` from the data file."
236 , " `a` - override `a` with this value."
238 <> elemFMbDef
"b" binocularsConfig
'Sample
'B c
default'BinocularsConfig
'Sample
239 [ "`b` parameter of the sample lattice (same unit than the wavelength)."
241 , "This parameter with the 5 others, `a`, `c`, `alpha`, `beta` and `gamma`"
242 , "can be set in order to overwrite the values from the data file."
244 , " `<not set>` - read `b` from the data file."
245 , " `b` - override `b` with this value."
247 <> elemFMbDef
"c" binocularsConfig
'Sample
'C c
default'BinocularsConfig
'Sample
248 [ "`c` parameter of the sample lattice (same unit than the wavelength)."
250 , "This parameter with the 5 others, `a`, `b`, `alpha`, `beta` and `gamma`"
251 , "can be set in order to overwrite the values from the data file."
253 , " `<not set>` - read `c` from the data file."
254 , " `c` - override `c` with this value."
256 <> elemFMbDef
"alpha" binocularsConfig
'Sample
'Alpha c
default'BinocularsConfig
'Sample
257 [ "`alpha` parameter of the sample lattice (Degree)."
259 , "This parameter with the 5 others, `a`, `b`, `c`, `beta` and `gamma`"
260 , "can be set in order to overwrite the values from the data file."
262 , " `<not set>` - read `alpha` from the data file."
263 , " `alpha` - override `alpha` with this value."
265 <> elemFMbDef
"beta" binocularsConfig
'Sample
'Beta c
default'BinocularsConfig
'Sample
266 [ "`beta` parameter of the sample lattice (Degree)."
268 , "This parameter with the 5 others, `a`, `b`, `c`, `alpha`, and `gamma`"
269 , "can be set in order to overwrite the values from the data file."
271 , " `<not set>` - read `beta` from the data file."
272 , " `beta` - override `beta` with this value."
274 <> elemFMbDef
"gamma" binocularsConfig
'Sample
'Gamma c
default'BinocularsConfig
'Sample
275 [ "`gamma` parameter of the sample lattice (Degree)."
277 , "This parameter with the 5 others, `a`, `b`, `c`, `alpha` and `beta`"
278 , "can be set in order to overwrite the values from the data file."
280 , " `<not set>` - read `gamma` from the data file."
281 , " `gamma` - override `gamma` with this value."
283 <> elemFMbDef
"ux" binocularsConfig
'Sample
'Ux c
default'BinocularsConfig
'Sample
284 [ "`ux` rotation of the sample around the x axis"
286 , "`ux`, `uy`, `uz` are the eulerian angles, which define"
287 , "the orientation of the sample lattice, relatively to"
288 , "the sample holder."
290 , "the rotation is computed like this:"
294 , " `<not set>` - read `ux` from the data file."
295 , " `ux` - override `ux` with this value."
297 <> elemFMbDef
"uy" binocularsConfig
'Sample
'Uy c
default'BinocularsConfig
'Sample
298 [ "`uy` rotation of the sample around the y axis"
300 , "`ux`, `uy`, `uz` are the eulerian angles, which define"
301 , "the orientation of the sample lattice, relatively to"
302 , "the sample holder."
304 , "the rotation is computed like this:"
308 , " `<not set>` - read `uy` from the data file."
309 , " `uy` - override `uy` with this value."
311 <> elemFMbDef
"uz" binocularsConfig
'Sample
'Uz c
default'BinocularsConfig
'Sample
312 [ "`uz` rotation of the sample around the z axis"
314 , "`ux`, `uy`, `uz` are the eulerian angles, which define"
315 , "the orientation of the sample lattice, relatively to"
316 , "the sample holder."
318 , "the rotation is computed like this:"
322 , " `<not set>` - read `uz` from the data file."
323 , " `uz` - override `uz` with this value."
330 parse
'BinocularsConfig
'Sample
:: Text
-> Either String BinocularsConfig
'Sample
331 parse
'BinocularsConfig
'Sample cfg
332 = BinocularsConfig
'Sample
333 <$> parseMb cfg
"input" "a"
334 <*> parseMb cfg
"input" "b"
335 <*> parseMb cfg
"input" "c"
336 <*> parseMb cfg
"input" "alpha"
337 <*> parseMb cfg
"input" "beta"
338 <*> parseMb cfg
"input" "gamma"
339 <*> parseMb cfg
"input" "ux"
340 <*> parseMb cfg
"input" "uy"
341 <*> parseMb cfg
"input" "uz"