contrib/haskell/src/Hkl/Binoculars/Config.hs

   1 {-# LANGUAGE CPP                        #-}
   2 {-# LANGUAGE DataKinds                  #-}
   3 {-# LANGUAGE DeriveGeneric              #-}
   4 {-# LANGUAGE FlexibleInstances          #-}
   5 {-# LANGUAGE GADTs                      #-}
   6 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   7 {-# LANGUAGE LambdaCase                 #-}
   8 {-# LANGUAGE OverloadedStrings          #-}
   9 {-# LANGUAGE StandaloneDeriving         #-}
  10 {-# LANGUAGE TemplateHaskell            #-}
  11 {-# LANGUAGE TypeApplications           #-}
  12 {-# LANGUAGE TypeFamilies               #-}
  13 {-# LANGUAGE UndecidableInstances       #-}
  14
  15 {-
  16     Copyright  : Copyright (C) 2014-2023 Synchrotron SOLEIL
  17                                          L'Orme des Merisiers Saint-Aubin
  18                                          BP 48 91192 GIF-sur-YVETTE CEDEX
  19     License    : GPL3+
  20
  21     Maintainer : Picca Frédéric-Emmanuel <picca@synchrotron-soleil.fr>
  22     Stability  : Experimental
  23     Portability: GHC only (not tested)
  24 -}
  25
  26 module Hkl.Binoculars.Config
  27     ( Angstrom(..)
  28     , Args
  29     , Attenuation(..)
  30     , BinocularsPreConfig(..)
  31     , Capabilities(..)
  32     , Config
  33     , ConfigContent(..)
  34     , ConfigRange(..)
  35     , DataPath
  36     , Degree(..)
  37     , DestinationTmpl(..)
  38     , FieldEmitter(..)
  39     , FieldParsable(..)
  40     , HasFieldComment(..)
  41     , HasFieldValue(..)
  42     , HasIniConfig(..)
  43     , InputRange(..)
  44     , InputTmpl(..)
  45     , InputType(..)
  46     , InputTypeDeprecated(..)
  47     , Limits(..)
  48     , MaskLocation(..)
  49     , Meter(..)
  50     , NCores(..)
  51     , ProjectionType(..)
  52     , Resolutions(..)
  53     , RLimits(..)
  54     , SampleAxis(..)
  55     , ToIni(..)
  56     , auto
  57     , auto'
  58     , destination'
  59     , files
  60     , getCapabilities
  61     , getMask
  62     , getPreConfig
  63     , mergeIni
  64     , readConfig
  65     , serializeConfig
  66     ) where
  67
  68
  69 import           Control.Applicative               (many, (<|>))
  70 import           Control.Lens                      (makeLenses)
  71 import           Control.Monad.Catch               (MonadThrow, throwM)
  72 import           Control.Monad.Catch.Pure          (runCatch)
  73 import           Control.Monad.IO.Class            (MonadIO)
  74 import           Data.Aeson                        (FromJSON (..), ToJSON (..))
  75 import           Data.Array.Repa.Index             (DIM2, DIM3)
  76 import           Data.Attoparsec.Text              (Parser, char, decimal,
  77                                                     double, parseOnly, satisfy,
  78                                                     sepBy, signed, takeText)
  79 import           Data.Either.Combinators           (maybeToRight)
  80 import           Data.Either.Extra                 (mapLeft, mapRight)
  81 import           Data.Foldable                     (foldl')
  82 import           Data.HashMap.Strict               (HashMap, unionWith)
  83 import           Data.Hashable                     (Hashable)
  84 import           Data.Ini                          (Ini (..), printIni)
  85 import           Data.Ini.Config.Bidir             (FieldValue (..), IniSpec,
  86                                                     bool, field, getIniValue,
  87                                                     ini, listWithSeparator,
  88                                                     number, parseIni, section,
  89                                                     text, (.=))
  90 import           Data.List                         (find, isInfixOf, length)
  91 import           Data.List.NonEmpty                (NonEmpty (..), map)
  92 import           Data.String                       (IsString)
  93 import           Data.Text                         (Text, breakOn, cons, drop,
  94                                                     empty, findIndex,
  95                                                     intercalate, length, lines,
  96                                                     pack, replace, singleton,
  97                                                     strip, take, takeWhile,
  98                                                     toLower, unlines, unpack,
  99                                                     unwords)
 100 import           Data.Text.IO                      (readFile)
 101 import           Data.Typeable                     (Proxy (..), Typeable,
 102                                                     typeRep)
 103 import           GHC.Conc                          (getNumCapabilities,
 104                                                     getNumProcessors)
 105 import           GHC.Exts                          (IsList (..))
 106 import           Numeric.Interval                  (Interval, empty, hull, inf,
 107                                                     singleton, singular, sup,
 108                                                     (...))
 109 import           Numeric.Units.Dimensional.NonSI   (angstrom)
 110 import           Numeric.Units.Dimensional.Prelude (Length, degree, meter, (*~),
 111                                                     (/~))
 112 import           Path                              (Abs, Dir, File, Path, Rel,
 113                                                     fileExtension, filename,
 114                                                     fromAbsDir, parseAbsDir,
 115                                                     toFilePath)
 116 import           Path.IO                           (getCurrentDir, walkDirAccum)
 117 import           System.Directory                  (doesPathExist)
 118 import           System.FilePath                   (splitExtensions)
 119 import           Test.QuickCheck                   (Arbitrary (..), elements,
 120                                                     oneof)
 121 import           Text.Printf                       (printf)
 122
 123 import           Prelude                           hiding (drop, length, lines,
 124                                                     putStr, readFile, take,
 125                                                     takeWhile, unlines, unwords)
 126
 127 import           Hkl.C.Binoculars
 128 import           Hkl.Detector
 129 import           Hkl.Exception
 130 import           Hkl.Lattice
 131 import           Hkl.Types
 132 import           Paths_hkl
 133
 134 -- TODO
 135 -- rendre le parametre surface_orientation obligatoire pour les q
 136 -- revoir le message d'erreur lorsque un des moteur est manquant, c'est incomprehensible... exemple:
 137 --   "CanNotOpenDataSource'Double'Or (CanNotOpenDataSource'Double'Ini \"geometry.values\" \"beta\") (CanNotOpenDataSource'Double'Or (CanNotOpenDataSource'Double'Ini \"geometry.values\" \"mu\") (CanNotOpenDataSource'Double'Or (CanNotOpenDataSource'Double'Ini \"geometry.values\" \"eix\") (HklDataSourceException'HklH5Exception (CanNotOpenH5Or (CanNotOpenDataset \"scan_data/eix\") (CanNotOpenDataset \"SIXS/i14-c-cx1-dt-det_tx.1/position_pre\")))))"
 138 --   ici le probleme c'est eix...
 139 --      $(PROCESS) /nfs/ruche-sixs/sixs-soleil/com-sixs/2023/Run2/Mozhzhukhina_20220548/binoculars/config_sbs_eiger.txt 640
 140 -- gerer les mask en int64 uint64 etc...
 141 --   /nfs/ruche-sixs/sixs-soleil/com-sixs/2020/Run3/Lacaze/mask_eiger.npy
 142 -- comment documenter la section geometry.values
 143 --   migrer le code de config-ini vers ini afin de resoudre ce probleme.
 144 -- gerer les data sources qui n'ont pas la meme dimensionnalite genre un scalar et un array.
 145 -- implementer les q/tth_scantime et q/tth_scanindex
 146 -- implementer les corrections de polarisation
 147 -- gui merge de cube.
 148 -- ajouter un XpadFlat -> ajouter 3.2 dans le nom
 149 -- adapter angles -> cglm 0 -> subprojection
 150 --  - delta_lab, gamma_lab, <sample-axis>
 151 --  - gamma_lab, delta_lab, <sample_axis>
 152
 153 -- Class FieldEmitter
 154
 155 class FieldEmitter a where
 156   fieldEmitter :: a -> Text
 157
 158 -- Class FieldParsable
 159
 160 class FieldEmitter a => FieldParsable a where
 161   fieldParser :: Parser a
 162
 163 -- class HasFieldComment
 164
 165 class HasFieldValue a => HasFieldComment a where
 166   fieldComment :: a -> [Text]
 167
 168 -- Class HasFieldValue
 169
 170 class HasFieldValue a where
 171   fieldvalue :: FieldValue a
 172
 173 auto :: HasFieldValue a => FieldValue a
 174 auto = fieldvalue
 175
 176 auto' :: HasFieldValue a => Text -> Either String a
 177 auto' = fvParse fieldvalue
 178
 179 instance HasFieldValue Bool where
 180   fieldvalue = bool
 181
 182 instance HasFieldValue Degree where
 183   fieldvalue = FieldValue
 184     { fvParse =  mapRight (Degree . (*~ degree)) . fvParse auto
 185     , fvEmit = \(Degree m) -> pack . show . (/~ degree) $ m
 186     }
 187
 188 number' :: (Show a, Read a, Num a, Typeable a) => FieldValue a
 189 number' = Data.Ini.Config.Bidir.number
 190   { fvParse = \t -> case fvParse Data.Ini.Config.Bidir.number . uncomment $ t of
 191                      Left _ -> fvParse Data.Ini.Config.Bidir.number . uncomment $ nt
 192                        where
 193                          nt :: Text
 194                          nt = cons '0' t
 195                      Right v -> Right v
 196   }
 197
 198 instance HasFieldValue Double where
 199   fieldvalue = number'
 200
 201 instance  HasFieldValue (Detector Hkl DIM2) where
 202   fieldvalue = FieldValue
 203                { fvParse = parseDetector2D . strip . uncomment
 204                , fvEmit = \(Detector2D _ name _) -> pack name
 205                }
 206
 207 instance HasFieldValue Float where
 208   fieldvalue = number'
 209
 210 instance HasFieldValue Int where
 211   fieldvalue = number'
 212
 213 instance HasFieldValue (Path Abs Dir) where
 214   fieldvalue = FieldValue { fvParse = \t -> mapLeft show (runCatch . parseAbsDir . unpack $ t)
 215                           , fvEmit = pack . fromAbsDir
 216                           }
 217
 218 instance HasFieldValue Text where
 219   fieldvalue = text
 220
 221 instance HasFieldValue [Double] where
 222   fieldvalue = listWithSeparator "," auto
 223
 224 pairWithSeparator' :: FieldValue l -> Text -> FieldValue r -> FieldValue (l, r)
 225 pairWithSeparator' left sep right = FieldValue
 226   { fvParse = \ t ->
 227       let (leftChunk, rightChunk) = breakOn sep t
 228       in do
 229         x <- fvParse left leftChunk
 230         y <- fvParse right (drop (Data.Text.length sep) rightChunk)
 231         return (x, y)
 232   , fvEmit = \ (x, y) -> fvEmit left x <> sep <> fvEmit right y
 233   }
 234
 235 instance HasFieldValue (Int, Int) where
 236   fieldvalue = pairWithSeparator' number' "," number'
 237
 238 -- Class HasIniConfig
 239
 240 data family Config (a :: ProjectionType)
 241 data family DataPath (a :: ProjectionType)
 242 data family Args (a :: ProjectionType)
 243
 244 readConfig :: Maybe FilePath -> IO ConfigContent
 245 readConfig mf = do
 246   cfg <- readFile =<< case mf of
 247                        Nothing  -> getDataFileName "data/test/config_manip1.cfg"
 248                        (Just f) -> pure f
 249   -- return $ ConfigContent cfg
 250   return $ ConfigContent $ unlines $ [fixHeader l | l <- lines cfg]
 251     where
 252       fixHeader :: Text -> Text
 253       fixHeader l = case findIndex (== '#' ) l of
 254         Nothing  -> l
 255         (Just n) -> take n l
 256
 257 class HasIniConfig (a :: ProjectionType) where
 258
 259   getConfig :: ConfigContent
 260             -> Args a
 261             -> Capabilities
 262             -> Either String (Config a)
 263
 264 -- Class ToIni
 265
 266 class ToIni a where
 267   toIni :: a -> Ini
 268
 269 serializeConfig :: ToIni a => a -> Text
 270 serializeConfig = printIni . toIni
 271
 272 mergeHash :: (Eq k, Hashable k, Semigroup v) => HashMap k v -> HashMap k v -> HashMap k v
 273 mergeHash = unionWith f
 274   where
 275     f :: Semigroup v => v -> v -> v
 276     f v1 v2 = v1 <> v2
 277
 278 mergeIni :: Ini -> Ini -> Ini
 279 mergeIni x y = Ini {iniGlobals = mempty, iniSections = iniSections x `mergeHash` iniSections y}
 280
 281 -- Angstrom
 282
 283 newtype Angstrom = Angstrom { unAngstrom :: Length Double }
 284     deriving (Eq, Show)
 285
 286 instance FromJSON Angstrom where
 287   parseJSON = fmap (Angstrom . (*~ angstrom)) . parseJSON
 288
 289 instance ToJSON Angstrom where
 290   toJSON = toJSON . (/~ angstrom) . unAngstrom
 291
 292 instance Arbitrary Angstrom where
 293   arbitrary = Angstrom . (*~ angstrom) <$> arbitrary
 294
 295 instance HasFieldValue Angstrom where
 296   fieldvalue = FieldValue
 297     { fvParse =  mapRight (Angstrom . (*~ angstrom)) . fvParse auto
 298     , fvEmit = \(Angstrom m) -> pack . show . (/~ angstrom) $ m
 299     }
 300
 301 -- Attenuation
 302
 303 newtype Attenuation = Attenuation { unAttenuation :: Double }
 304   deriving (Eq, Show)
 305
 306 -- Capabilities
 307
 308 data Capabilities = Capabilities Int Int
 309   deriving (Eq, Show)
 310
 311 getCapabilities :: IO Capabilities
 312 getCapabilities = Capabilities
 313                   <$> getNumCapabilities
 314                   <*> getNumProcessors
 315
 316 -- ConfigRange
 317
 318 newtype ConfigRange = ConfigRange (NonEmpty InputRange)
 319   deriving (Eq, Show, IsList)
 320
 321 instance Arbitrary ConfigRange where
 322   arbitrary = ConfigRange <$> ((:|) <$> arbitrary <*> arbitrary)
 323
 324 instance FieldEmitter ConfigRange where
 325   fieldEmitter (ConfigRange is) = unwords . toList $ Data.List.NonEmpty.map fieldEmitter is
 326
 327 instance FieldParsable ConfigRange where
 328   fieldParser = ConfigRange <$> ((:|)
 329                                  <$> fieldParser <* many (satisfy isSep)
 330                                  <*> fieldParser `sepBy` many (satisfy isSep))
 331     where
 332       isSep :: Char -> Bool
 333       isSep c = c == ' ' || c == ','
 334
 335 instance HasFieldValue ConfigRange where
 336   fieldvalue = parsable
 337
 338 -- DestinationTmpl
 339
 340 newtype DestinationTmpl =
 341   DestinationTmpl { unDestinationTmpl :: Text }
 342   deriving (Eq, Show)
 343
 344 instance Arbitrary DestinationTmpl where
 345   arbitrary = pure $ DestinationTmpl "{first}_{last}.h5"
 346
 347 instance HasFieldValue DestinationTmpl where
 348   fieldvalue = FieldValue
 349     { fvParse = Right . DestinationTmpl . uncomment
 350     , fvEmit = \(DestinationTmpl t) -> t
 351     }
 352
 353 -- HklBinocularsQCustomSubProjectionEnum
 354
 355 instance FieldEmitter HklBinocularsQCustomSubProjectionEnum where
 356   fieldEmitter HklBinocularsQCustomSubProjectionEnum'QxQyQz            = "qx_qy_qz"
 357   fieldEmitter HklBinocularsQCustomSubProjectionEnum'QTthTimestamp     = "q_tth_timestamp"
 358   fieldEmitter HklBinocularsQCustomSubProjectionEnum'QTimestamp        = "q_timestamp"
 359   fieldEmitter HklBinocularsQCustomSubProjectionEnum'QparQperTimestamp = "qpar_qper_timestamp"
 360   fieldEmitter HklBinocularsQCustomSubProjectionEnum'QparQper          = "qpar_qper"
 361   fieldEmitter HklBinocularsQCustomSubProjectionEnum'QPhiQx            = "q_phi_qx"
 362   fieldEmitter HklBinocularsQCustomSubProjectionEnum'QPhiQy            = "q_phi_qy"
 363   fieldEmitter HklBinocularsQCustomSubProjectionEnum'QPhiQz            = "q_phi_qz"
 364   fieldEmitter HklBinocularsQCustomSubProjectionEnum'QStereo           = "q_stereo"
 365   fieldEmitter HklBinocularsQCustomSubProjectionEnum'DeltalabGammalabSampleaxis = "deltalab_gammalab_sampleaxis"
 366   fieldEmitter HklBinocularsQCustomSubProjectionEnum'XYZ                  = "x_y_z"
 367   fieldEmitter HklBinocularsQCustomSubProjectionEnum'YZTimestamp          = "y_z_timestamp"
 368   fieldEmitter HklBinocularsQCustomSubProjectionEnum'QQparQper            = "q_qpar_qper"
 369   fieldEmitter HklBinocularsQCustomSubProjectionEnum'QparsQperTimestamp   = "qpars_qper_timestamp"
 370   fieldEmitter HklBinocularsQCustomSubProjectionEnum'QparQperSampleaxis   = "qpar_qper_sampleaxis"
 371   fieldEmitter HklBinocularsQCustomSubProjectionEnum'QSampleaxisTth       = "q_sampleaxis_tth"
 372   fieldEmitter HklBinocularsQCustomSubProjectionEnum'QSampleaxisTimestamp = "q_sampleaxis_timestamp"
 373
 374 instance FieldParsable HklBinocularsQCustomSubProjectionEnum where
 375   fieldParser = go . strip . uncomment . toLower =<< takeText
 376     where
 377       err t =  "Unsupported "
 378                ++ show (typeRep (Proxy :: Proxy HklBinocularsQCustomSubProjectionEnum))
 379                ++ " :" ++ unpack t
 380                ++ " Supported ones are: "
 381                ++ unpack (unwords $ Prelude.map fieldEmitter [minBound..maxBound :: HklBinocularsQCustomSubProjectionEnum])
 382
 383       go :: Text -> Parser HklBinocularsQCustomSubProjectionEnum
 384       go "q_index" = pure HklBinocularsQCustomSubProjectionEnum'QTimestamp
 385       go "angle_zaxis_omega" = pure HklBinocularsQCustomSubProjectionEnum'DeltalabGammalabSampleaxis
 386       go "angle_zaxis_mu" = pure HklBinocularsQCustomSubProjectionEnum'DeltalabGammalabSampleaxis
 387       go t = case parseEnum (err t) t of
 388         Right p   -> pure p
 389         Left err' -> fail err'
 390
 391 instance HasFieldValue HklBinocularsQCustomSubProjectionEnum where
 392   fieldvalue = parsable
 393
 394
 395 instance HasFieldComment HklBinocularsQCustomSubProjectionEnum where
 396   fieldComment _ = [ "The sub-projection that can be computed with binoculars-ng"
 397                    , ""
 398                    , "the list of the available sub-projections are:"
 399                    , ""
 400                    ]
 401                    <> [" - " <> fvEmit fieldvalue v | v <- [minBound..maxBound :: HklBinocularsQCustomSubProjectionEnum]]
 402
 403 -- HklBinocularsSurfaceOrientationEnum
 404
 405 instance HasFieldValue HklBinocularsSurfaceOrientationEnum where
 406   fieldvalue = FieldValue { fvParse = parse . strip . uncomment, fvEmit = emit }
 407     where
 408       err t = "Unsupported "
 409               ++ show (typeRep (Proxy :: Proxy HklBinocularsSurfaceOrientationEnum))
 410               ++ " :" ++ unpack t
 411               ++ " Supported ones are: "
 412               ++ unpack (unwords $ Prelude.map emit [minBound..maxBound])
 413
 414       parse :: Text -> Either String HklBinocularsSurfaceOrientationEnum
 415       parse t = parseEnum (err t) t
 416
 417       emit :: HklBinocularsSurfaceOrientationEnum -> Text
 418       emit HklBinocularsSurfaceOrientationEnum'Vertical   = "vertical"
 419       emit HklBinocularsSurfaceOrientationEnum'Horizontal = "horizontal"
 420
 421 instance HasFieldComment HklBinocularsSurfaceOrientationEnum where
 422   fieldComment _ = [ "The orientation of the surface."
 423                    , ""
 424                    , "the list of the available orientation are:"
 425                    , ""
 426                    ]
 427                    <> [" - " <> fvEmit fieldvalue v | v <- [minBound..maxBound :: HklBinocularsSurfaceOrientationEnum]]
 428                    <> [ ""
 429                       , "this orientation if for all the Geometry axes set to zero and correspond to"
 430                       , "the orientation of a vector collinear to the surface."
 431                       ]
 432
 433 -- InputRange
 434
 435 newtype InputRange = InputRange {unInputRange :: Interval Int }
 436                    deriving (Eq, Show)
 437
 438 instance Arbitrary InputRange where
 439   arbitrary = InputRange <$> oneof [ Numeric.Interval.singleton <$> arbitrary
 440                                    , do
 441                                        f <- arbitrary
 442                                        t <- arbitrary
 443                                        pure $ if f < t then f...t else t...f
 444                                    ]
 445
 446 instance FieldEmitter InputRange where
 447   fieldEmitter (InputRange i) = pack $ if singular i
 448                                        then printf "%d" (sup i)
 449                                        else printf "%d-%d" (inf i) (sup i)
 450
 451 instance FieldParsable InputRange where
 452   fieldParser = inputRangeFromToP <|> inputRangeP'
 453     where
 454       inputRangeFromToP :: Parser InputRange
 455       inputRangeFromToP =  InputRange
 456                            <$> ((...)
 457                                 <$> signed decimal <* char '-'
 458                                 <*> signed decimal)
 459
 460       inputRangeP' :: Parser InputRange
 461       inputRangeP' = InputRange
 462                      <$> (Numeric.Interval.singleton <$> signed decimal)
 463
 464 -- InputTmpl
 465
 466 newtype InputTmpl = InputTmpl { unInputTmpl :: Text }
 467   deriving (Eq, Show)
 468
 469 instance Arbitrary InputTmpl where
 470   arbitrary = pure $ InputTmpl "inputfiles%04.nxs"
 471
 472 instance HasFieldValue InputTmpl where
 473   fieldvalue = FieldValue
 474     { fvParse = Right . InputTmpl . uncomment
 475     , fvEmit = \(InputTmpl t) -> t
 476     }
 477
 478 -- InputType
 479
 480 data InputTypeDeprecated
 481   = SixsFlyMedVEiger
 482   | SixsFlyMedVS70
 483   | SixsFlyScanUhvGisaxsEiger
 484   | SixsFlyScanUhvUfxc
 485   deriving (Eq, Show, Enum, Bounded)
 486
 487 instance FieldEmitter InputTypeDeprecated where
 488   fieldEmitter SixsFlyMedVEiger          = "sixs:flymedveiger"
 489   fieldEmitter SixsFlyMedVS70            = "sixs:flymedvs70"
 490   fieldEmitter SixsFlyScanUhvGisaxsEiger = "sixs:gisaxuhveiger"
 491   fieldEmitter SixsFlyScanUhvUfxc        = "sixs:flyscanuhvufxc"
 492
 493 instance FieldParsable InputTypeDeprecated where
 494   fieldParser = go . strip . uncomment . toLower =<< takeText
 495     where
 496       err t =  "Unsupported "
 497                ++ show (typeRep (Proxy :: Proxy InputTypeDeprecated))
 498                ++ " :" ++ unpack t
 499                ++ " Supported ones are: "
 500                ++ unpack (unwords $ Prelude.map fieldEmitter [minBound..maxBound :: InputTypeDeprecated])
 501
 502       go :: Text -> Parser InputTypeDeprecated
 503       go t = case parseEnum (err t) t of
 504         Right p   -> pure p
 505         Left err' -> fail err'
 506
 507 instance HasFieldValue InputTypeDeprecated where
 508   fieldvalue = parsable
 509
 510 data InputType = CristalK6C
 511                | MarsFlyscan
 512                | MarsSbs
 513                | SixsFlyMedH
 514                | SixsFlyMedHGisaxs
 515                | SixsFlyMedV
 516                | SixsFlyMedVGisaxs
 517                | SixsFlyUhv
 518                | SixsFlyUhvGisaxs
 519                | SixsSbsMedH
 520                | SixsSbsMedHGisaxs
 521                | SixsSbsMedV
 522                | SixsSbsMedVGisaxs
 523                | SixsSbsUhv
 524                | SixsSbsUhvGisaxs
 525   deriving (Eq, Show, Enum, Bounded)
 526
 527 instance Arbitrary InputType where
 528   arbitrary = elements ([minBound .. maxBound] :: [InputType])
 529
 530 instance FieldEmitter InputType where
 531   fieldEmitter CristalK6C        = "cristal:k6c"
 532   fieldEmitter MarsFlyscan       = "mars:flyscan"
 533   fieldEmitter MarsSbs           = "mars:sbs"
 534   fieldEmitter SixsFlyMedH       = "sixs:flymedh"
 535   fieldEmitter SixsFlyMedHGisaxs = "sixs:flymedhgisaxs"
 536   fieldEmitter SixsFlyMedV       = "sixs:flymedv"
 537   fieldEmitter SixsFlyMedVGisaxs = "sixs:flymedvgisaxs"
 538   fieldEmitter SixsFlyUhv        = "sixs:flyuhv"
 539   fieldEmitter SixsFlyUhvGisaxs  = "sixs:flyuhvgisaxs"
 540   fieldEmitter SixsSbsMedH       = "sixs:sbsmedh"
 541   fieldEmitter SixsSbsMedHGisaxs = "sixs:sbsmedhgisaxs"
 542   fieldEmitter SixsSbsMedV       = "sixs:sbsmedv"
 543   fieldEmitter SixsSbsMedVGisaxs = "sixs:sbsmedvgisaxs"
 544   fieldEmitter SixsSbsUhv        = "sixs:sbsuhv"
 545   fieldEmitter SixsSbsUhvGisaxs  = "sixs:sbsuhvgisaxs"
 546
 547 instance FieldParsable InputType where
 548   fieldParser = go . strip . uncomment . toLower =<< takeText
 549     where
 550       err t =  "Unsupported "
 551                ++ show (typeRep (Proxy :: Proxy InputType))
 552                ++ " :" ++ unpack t
 553                ++ " Supported ones are: "
 554                ++ unpack (unwords $ Prelude.map fieldEmitter [minBound..maxBound :: InputType])
 555
 556       go :: Text -> Parser InputType
 557       go "sixs:flyscanuhv" = pure SixsFlyUhv
 558       go "sixs:flyscanuhv2" = pure SixsFlyUhv
 559       go "sixs:flyscanuhvtest" = pure SixsFlyUhv
 560       go "sixs:sbsmedhfixdetector" = pure SixsSbsMedHGisaxs
 561       go "sixs:sbsmedvfixdetector" = pure SixsSbsMedVGisaxs
 562       go t = case parseEnum (err t) t of
 563         Right p   -> pure p
 564         Left err' -> fail err'
 565
 566 instance HasFieldValue InputType where
 567   fieldvalue = parsable
 568
 569 -- Limits
 570
 571 data Limits = Limits (Maybe Double) (Maybe Double)
 572   deriving (Eq, Show)
 573
 574 instance Arbitrary Limits where
 575   arbitrary = Limits <$> arbitrary <*> arbitrary
 576
 577 -- MaskLocation
 578
 579 newtype MaskLocation = MaskLocation { unMaskLocation :: Text }
 580     deriving (Eq, Show, IsString)
 581
 582 instance Arbitrary MaskLocation where
 583   arbitrary = pure $ MaskLocation "mask location"
 584
 585 instance HasFieldValue MaskLocation where
 586   fieldvalue = FieldValue
 587     { fvParse = mapRight MaskLocation . fvParse text
 588     , fvEmit = \(MaskLocation m) -> fvEmit text m
 589     }
 590
 591 -- Meter
 592
 593 newtype Meter = Meter { unMeter :: Length Double }
 594     deriving (Eq, Show)
 595
 596 instance Arbitrary Meter where
 597   arbitrary = Meter . (*~ meter) <$> arbitrary
 598
 599 instance HasFieldValue Meter where
 600   fieldvalue = FieldValue
 601     { fvParse =  mapRight (Meter . (*~ meter)) . fvParse auto
 602     , fvEmit = \(Meter m) -> pack . show . (/~ meter) $ m
 603     }
 604
 605 -- NCores
 606
 607 newtype NCores = NCores { unNCores :: Int }
 608     deriving (Eq, Show)
 609
 610 instance Arbitrary NCores where
 611   arbitrary = NCores <$> arbitrary
 612
 613 instance HasFieldValue NCores where
 614   fieldvalue = FieldValue
 615     { fvParse =  mapRight NCores . fvParse auto
 616     , fvEmit = \(NCores m) -> pack . show $ m
 617     }
 618
 619 -- ProjectionType
 620
 621 data ProjectionType = AnglesProjection
 622                     | Angles2Projection
 623                     | HklProjection
 624                     | QCustomProjection
 625                     | QIndexProjection
 626                     | QparQperProjection
 627                     | QxQyQzProjection
 628                     | RealSpaceProjection
 629                     | PixelsProjection
 630                     | TestProjection
 631
 632   deriving (Eq, Show, Enum, Bounded)
 633
 634 instance Arbitrary ProjectionType where
 635   arbitrary = elements ([minBound .. maxBound] :: [ProjectionType])
 636
 637 instance FieldEmitter ProjectionType where
 638   fieldEmitter AnglesProjection    = "angles"
 639   fieldEmitter Angles2Projection   = "angles2"
 640   fieldEmitter HklProjection       = "hkl"
 641   fieldEmitter QCustomProjection   = "qcustom"
 642   fieldEmitter QIndexProjection    = "qindex"
 643   fieldEmitter QparQperProjection  = "qparqper"
 644   fieldEmitter QxQyQzProjection    = "qxqyqz"
 645   fieldEmitter RealSpaceProjection = "realspace"
 646   fieldEmitter PixelsProjection    = "pixels"
 647   fieldEmitter TestProjection      = "test"
 648
 649 instance FieldParsable ProjectionType where
 650   fieldParser = go . strip . uncomment . toLower =<< takeText
 651     where
 652       err t =  "Unsupported "
 653                ++ show (typeRep (Proxy :: Proxy ProjectionType))
 654                ++ " :" ++ unpack t
 655                ++ " Supported ones are: "
 656                ++ unpack (unwords $ Prelude.map fieldEmitter [minBound..maxBound :: ProjectionType])
 657
 658       go :: Text -> Parser ProjectionType
 659       go "sixs:anglesprojection" = pure AnglesProjection
 660       go "sixs:angles2projection" = pure Angles2Projection
 661       go "sixs:qindex" = pure QIndexProjection
 662       go "sixs:qxqyqzprojection" = pure QxQyQzProjection
 663       go "sixs:qparqperprojection" = pure QparQperProjection
 664       go "sixs:hklprojection" = pure HklProjection
 665       go "sixs:realspace" = pure RealSpaceProjection
 666       go "sixs:pixels" = pure PixelsProjection
 667       go "qcustom2" = pure QCustomProjection
 668       go t = case parseEnum (err t) t of
 669         Right p   -> pure p
 670         Left err' -> fail err'
 671
 672 instance HasFieldValue ProjectionType where
 673   fieldvalue = parsable
 674
 675 instance HasFieldComment ProjectionType where
 676   fieldComment _ = [ "The type of projection that can be computed with binoculars-ng"
 677                    , ""
 678                    , "the list of the available projections are:"
 679                    , ""
 680                    ]
 681                    <> [" - " <> fvEmit fieldvalue v | v <- [minBound..maxBound :: ProjectionType]]
 682                    <> [ ""
 683                       , "Some projections can be customize using the `subprojection` parameter."
 684                       ]
 685
 686 ms :: String
 687 ms = "#;"
 688
 689 uncomment :: Text -> Text
 690 uncomment = takeWhile (`notElem` ms)
 691
 692 parsable :: FieldParsable a => FieldValue a
 693 parsable = FieldValue { fvParse = parse . strip . uncomment, fvEmit = emit }
 694   where
 695     parse ::  FieldParsable a => Text -> Either String a
 696     parse = parseOnly fieldParser
 697
 698     emit ::  FieldParsable a => a -> Text
 699     emit = fieldEmitter
 700
 701 parseEnum :: (Bounded a, Enum a, HasFieldValue a, Typeable a)
 702           => String -> Text -> Either String a
 703 parseEnum err t = maybeToRight err (find match [minBound..maxBound])
 704   where
 705     match :: HasFieldValue a => a -> Bool
 706     match i = toLower t == fvEmit fieldvalue i
 707
 708 -- Resolutions
 709
 710 data Resolutions sh where
 711   Resolutions2 :: Double -> Double -> Resolutions DIM2
 712   Resolutions3 :: Double -> Double -> Double -> Resolutions DIM3
 713
 714 deriving instance Eq (Resolutions sh)
 715 deriving instance Show (Resolutions sh)
 716
 717 instance Arbitrary (Resolutions DIM2) where
 718   arbitrary = Resolutions2 <$> arbitrary <*> arbitrary
 719
 720 instance Arbitrary (Resolutions DIM3) where
 721   arbitrary = Resolutions3 <$> arbitrary <*> arbitrary <*> arbitrary
 722
 723 instance IsList (Resolutions sh) where
 724   type Item (Resolutions sh) = Double
 725
 726   toList (Resolutions2 r1 r2)    = [r1, r2]
 727   toList (Resolutions3 r1 r2 r3) = [r1, r2, r3]
 728
 729   fromList = undefined
 730
 731 instance HasFieldValue (Resolutions DIM2) where
 732   fieldvalue = FieldValue { fvParse = parse, fvEmit = emit }
 733     where
 734       parse :: Text -> Either String (Resolutions DIM2)
 735       parse t = do
 736         rs <- (fvParse $ listWithSeparator "," auto) t
 737         case Data.List.length rs of
 738           1 -> Right (Resolutions2 (head rs) (head rs))
 739           2 -> Right (Resolutions2 (head rs) (rs !! 1))
 740           _ -> Left "Need one or two resolutions values for this projection"
 741
 742       emit :: Resolutions DIM2 -> Text
 743       emit (Resolutions2 r1 r2) = intercalate "," (Prelude.map (pack . show) [r1, r2])
 744
 745 instance HasFieldComment (Resolutions DIM2) where
 746   fieldComment _ = [ "The resolution of the bins expected for the projection's axes"
 747                    , ""
 748                    , "The expected value are:"
 749                    , "  - one double - same resolution for all axes."
 750                    , "  - one double per axis - each axis has it's own resolution."
 751                    , ""
 752                    , "the latter form use a comma to separate the values and no space is allowed."
 753                    ]
 754
 755 instance HasFieldValue (Resolutions DIM3) where
 756   fieldvalue = FieldValue { fvParse = parse, fvEmit = emit }
 757     where
 758       parse :: Text -> Either String (Resolutions DIM3)
 759       parse t = do
 760         rs <- (fvParse $ listWithSeparator "," auto) t
 761         case Data.List.length rs of
 762           1 -> Right (Resolutions3 (head rs) (head rs) (head rs))
 763           3 -> Right (Resolutions3 (head rs) (rs !! 1) (rs !! 2))
 764           _ -> Left "Need one or three resolutions values for this projection"
 765
 766       emit :: Resolutions DIM3 -> Text
 767       emit (Resolutions3 r1 r2 r3) = intercalate "," (Prelude.map (pack . show) [r1, r2, r3])
 768
 769 instance HasFieldComment (Resolutions DIM3) where
 770   fieldComment _ = [ "The resolution of the bins expected for the projection's axes"
 771                    , ""
 772                    , "The expected value are:"
 773                    , "  - one double - same resolution for all axes."
 774                    , "  - one double per axis - each axis has it's own resolution."
 775                    , ""
 776                    , "the latter form use a comma to separate the values and no space is allowed."
 777                    ]
 778
 779 -- RLimits
 780
 781 data RLimits sh where
 782   Limits2 :: Limits -> Limits -> RLimits DIM2
 783   Limits3 :: Limits -> Limits -> Limits -> RLimits DIM3
 784
 785 deriving instance Eq (RLimits sh)
 786 deriving instance Show (RLimits sh)
 787
 788 instance Arbitrary (RLimits DIM2) where
 789   arbitrary = Limits2 <$> arbitrary <*> arbitrary
 790
 791
 792 instance Arbitrary (RLimits DIM3) where
 793   arbitrary = Limits3 <$> arbitrary <*> arbitrary <*> arbitrary
 794
 795
 796 limitsP' :: Parser Limits
 797 limitsP' = Limits
 798            <$> lim <* char ':'
 799            <*> lim
 800   where
 801     lim :: Parser (Maybe Double)
 802     lim = (Just <$> double) <|> return Nothing
 803
 804 showLimit :: Maybe Double -> Text
 805 showLimit (Just l) = pack $ printf "%f" l
 806 showLimit Nothing  = Data.Text.empty
 807
 808 showLimits :: Limits -> Text
 809 showLimits (Limits f t) = showLimit f <> Data.Text.singleton ':' <> showLimit t
 810
 811 instance (FieldEmitter (RLimits sh)) where
 812   fieldEmitter ls = Data.Text.singleton '['
 813                     <> intercalate "," (Prelude.map showLimits (toList ls))
 814                     <> Data.Text.singleton ']'
 815
 816 instance (FieldParsable (RLimits DIM2)) where
 817   fieldParser = Limits2
 818                 <$> (char '[' *> limitsP')
 819                 <*> (char ',' *> limitsP' <* char ']')
 820
 821 instance (FieldParsable (RLimits DIM3)) where
 822   fieldParser = Limits3
 823                 <$> (char '[' *> limitsP')
 824                 <*> (char ',' *> limitsP')
 825                 <*> (char ',' *> limitsP' <* char ']')
 826
 827 instance HasFieldValue (RLimits DIM2) where
 828   fieldvalue = parsable
 829
 830 instance HasFieldComment (RLimits DIM2) where
 831   fieldComment _ = [ "The limits of the bins expected for the projection's axes"
 832                    , ""
 833                    , "Sometime it is interesting to focus on a specific region of a map."
 834                    , "this allows to increase the resolution and keep a memory footprint acceptable."
 835                    , ""
 836                    , "The expected value is a list of <limits>. One per axis."
 837                    , ""
 838                    , "  `[<limits>,<limits>]`"
 839                    , ""
 840                    , "<limits> has this form `<double or nothing>:<double or nothing>`"
 841                    , "nothing means realy nothing and in this case their is no limits."
 842                    , ""
 843                    , "example:"
 844                    , "  - [:1,2:3]"
 845                    , "  - [:,2:3]"
 846                    ]
 847
 848 instance HasFieldValue (RLimits DIM3) where
 849   fieldvalue = parsable
 850
 851 instance HasFieldComment (RLimits DIM3) where
 852   fieldComment _ = [ "The limits of the bins expected for the projection's axes"
 853                    , ""
 854                    , "Sometime it is interesting to focus on a specific region of a map."
 855                    , "this allows to increase the resolution and keep a memory footprint acceptable."
 856                    , ""
 857                    , "The expected value is a list of <limits>. One per axis."
 858                    , ""
 859                    , "  `[<limits>,<limits>,<limits>]`"
 860                    , ""
 861                    , "<limits> has this form `<double or nothing>:<double or nothing>`."
 862                    , "nothing means realy nothing and in this case their is no limits."
 863                    , ""
 864                    , "example:"
 865                    , "  - [:1,2:3,4:5]"
 866                    , "  - [:,2:3,4:]"
 867                    ]
 868
 869 instance IsList (RLimits sh) where
 870   type Item (RLimits sh) = Limits
 871
 872   toList (Limits2 l1 l2)    = [l1, l2]
 873   toList (Limits3 l1 l2 l3) = [l1, l2, l3]
 874
 875   fromList = undefined
 876
 877 -- SampleAxis
 878
 879 newtype SampleAxis = SampleAxis { unSampleAxis :: Text }
 880   deriving (Eq, Show)
 881
 882 instance HasFieldValue SampleAxis where
 883   fieldvalue = FieldValue { fvParse = Right . SampleAxis . uncomment
 884                           , fvEmit = \(SampleAxis t) -> t
 885                           }
 886
 887 instance Arbitrary SampleAxis where
 888   arbitrary = pure $ SampleAxis "omega"
 889
 890 -- BinocularsPreConfig
 891
 892 newtype BinocularsPreConfig =
 893   BinocularsPreConfig { _binocularsPreConfigProjectionType :: ProjectionType }
 894                          deriving (Eq, Show)
 895
 896 makeLenses ''BinocularsPreConfig
 897
 898 binocularsPreConfigDefault :: BinocularsPreConfig
 899 binocularsPreConfigDefault = BinocularsPreConfig
 900   { _binocularsPreConfigProjectionType = QxQyQzProjection }
 901
 902 binocularsPreConfigSpec :: IniSpec BinocularsPreConfig ()
 903 binocularsPreConfigSpec = do
 904   section "projection" $ do
 905     binocularsPreConfigProjectionType .= field "type" parsable
 906
 907
 908 ---------------
 909 -- functions --
 910 ---------------
 911
 912 destination' :: ProjectionType -> Maybe HklBinocularsQCustomSubProjectionEnum -> ConfigRange -> Maybe (RLimits a) -> DestinationTmpl -> Bool -> IO FilePath
 913 destination' proj msub (ConfigRange rs) ml dtmpl overwrite =
 914   if overwrite
 915   then pure $ replace' proj msub interval limits dtmpl Nothing
 916   else do
 917     let guess = replace' proj msub interval limits dtmpl Nothing : Prelude.map (replace' proj msub interval limits dtmpl . Just) [2..]
 918     findFirst guess
 919       where
 920         findFirst :: [FilePath] -> IO FilePath
 921         findFirst [] = undefined -- can not append non empty list
 922         findFirst (x : xs) = do
 923           exists <- doesPathExist x
 924           if exists
 925             then findFirst xs
 926             else return x
 927
 928         interval = foldl' hull Numeric.Interval.empty intervals
 929
 930         limits = case ml of
 931                    Nothing   -> "nolimits"
 932                    (Just ls) -> fieldEmitter ls
 933
 934         intervals = Data.List.NonEmpty.map unInputRange rs
 935
 936 isHdf5 :: Path Abs File -> Bool
 937 isHdf5 p = case (fileExtension p :: Maybe [Char]) of
 938              Nothing    -> False
 939              (Just ext) -> ext `elem` [".h5", ".nxs"]
 940
 941 isInConfigRange :: Maybe InputTmpl -> Maybe ConfigRange ->  Path Abs File -> Bool
 942 isInConfigRange mtmpl mr f
 943   = case mr of
 944       (Just (ConfigRange rs)) -> do
 945         let tmpl = maybe "%05d" (unpack . unInputTmpl) mtmpl
 946         any (isInInputRange (filename f) tmpl) rs
 947       Nothing -> True
 948   where
 949     matchIndex :: Path Rel File -> String -> Int -> Bool
 950     matchIndex p tmpl n = printf tmpl n `isInfixOf` toFilePath p
 951
 952     isInInputRange :: Path Rel File -> String -> InputRange -> Bool
 953     isInInputRange p tmpl (InputRange i) = any (matchIndex p tmpl) [inf i .. sup i]
 954
 955 files :: (MonadThrow m, MonadIO m)
 956        => Maybe (Path Abs Dir)
 957        -> Maybe ConfigRange
 958        -> Maybe InputTmpl
 959        -> m [Path Abs File]
 960 files md mr mt
 961   = do
 962   let filters = [ isHdf5
 963                 , isInConfigRange mt mr
 964                 ]
 965
 966   dir <- case md of
 967         Nothing  -> getCurrentDir
 968         (Just d) -> pure d
 969
 970   fs <- walkDirAccum Nothing
 971        (\_root _dirs fs -> return $ filter (\f -> all ($ f) filters) fs)
 972        dir
 973
 974   if null fs
 975     then throwM (NoDataFilesUnderTheGivenDirectory dir)
 976     else return fs
 977
 978 getMask :: (MonadThrow m, MonadIO m) => Maybe MaskLocation -> Detector Hkl DIM2 -> m (Maybe Mask)
 979 getMask ml d = case ml of
 980                 Nothing          -> return Nothing
 981                 (Just "default") -> Just <$> getDetectorDefaultMask d
 982                 (Just fname)     -> Just <$> getDetectorMask d (unMaskLocation fname)
 983
 984 getPreConfig' :: ConfigContent -> Either String BinocularsPreConfig
 985 getPreConfig' (ConfigContent cfg) = do
 986   let r = parseIni cfg (ini binocularsPreConfigDefault binocularsPreConfigSpec)
 987   mapRight getIniValue r
 988
 989 getPreConfig :: Maybe FilePath -> IO (Either String BinocularsPreConfig)
 990 getPreConfig mf = getPreConfig' <$> readConfig mf
 991
 992 addOverwrite :: Maybe Int -> DestinationTmpl -> DestinationTmpl
 993 addOverwrite midx tmpl = case midx of
 994   Nothing -> tmpl
 995   Just idx -> let (f, ext) = splitExtensions . unpack . unDestinationTmpl $ tmpl
 996              in DestinationTmpl (pack $ f <> printf "_%02d" idx <> ext)
 997
 998 replace' :: ProjectionType -> Maybe HklBinocularsQCustomSubProjectionEnum -> Interval Int -> Text -> DestinationTmpl -> Maybe Int -> FilePath
 999 replace' proj msub i l dtmpl midx = unpack
1000                           . replace "{last}" (pack . show . sup $ i)
1001                           . replace "{first}" (pack . show . inf $ i)
1002                           . replace "{limits}" l
1003                           . replace "{projection}" (case msub of
1004                                                       Just sub -> fieldEmitter sub
1005                                                       Nothing -> fieldEmitter proj)
1006                           . unDestinationTmpl . addOverwrite midx $ dtmpl