binoculars-ng/app/Main.hs

   1 {-# LANGUAGE DerivingStrategies         #-}
   2 {-# LANGUAGE GADTs                      #-}
   3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   4 {-
   5     Copyright  : Copyright (C) 2014-2024 Synchrotron SOLEIL
   6                                          L'Orme des Merisiers Saint-Aubin
   7                                          BP 48 91192 GIF-sur-YVETTE CEDEX
   8     License    : GPL3+
   9
  10     Maintainer : Picca Frédéric-Emmanuel <picca@synchrotron-soleil.fr>
  11     Stability  : Experimental
  12     Portability: GHC only (not tested)
  13 -}
  14 module Main where
  15
  16 import           Control.Monad.Catch       (MonadThrow)
  17 import           Control.Monad.IO.Class    (MonadIO)
  18 import           Control.Monad.Logger      (LogLevel (LevelDebug), LoggingT,
  19                                             MonadLogger, filterLogger,
  20                                             runStdoutLoggingT)
  21 import           Control.Monad.Reader      (MonadReader, ReaderT, ask,
  22                                             runReaderT)
  23 import           Data.Attoparsec.Text      (parseOnly)
  24 import           Data.Text                 (pack)
  25 import           Options.Applicative       (CommandFields, Mod, argument,
  26                                             command, eitherReader, execParser,
  27                                             fullDesc, header, help, helper,
  28                                             hsubparser, info, long, metavar,
  29                                             optional, progDesc, short, str,
  30                                             switch, (<**>))
  31 import           Options.Applicative.Types (Parser)
  32
  33
  34 import           Hkl.Binoculars
  35
  36
  37 data FullOptions = FullOptions Bool Options
  38   deriving Show
  39
  40 data Options = Process (Maybe FilePath) (Maybe ConfigRange)
  41              | CfgNew ProjectionType (Maybe FilePath)
  42              | CfgUpdate FilePath (Maybe ConfigRange)
  43   deriving Show
  44
  45 debug :: Parser Bool
  46 debug = switch ( long "debug" <> short 'd' <> help "Print debug informations" )
  47
  48 config :: Parser FilePath
  49 config = argument str (metavar "CONFIG")
  50
  51 processOptions :: Parser Options
  52 processOptions = Process
  53                  <$> optional config
  54                  <*> optional (argument (eitherReader (parseOnly fieldParser . pack)) (metavar "RANGE"))
  55
  56 processCommand :: Mod CommandFields Options
  57 processCommand = command "process" (info processOptions (progDesc "process data's"))
  58
  59 cfgNewOption :: Parser Options
  60 cfgNewOption = CfgNew
  61                <$> argument (eitherReader (parseOnly fieldParser . pack)) (metavar "PROJECTION")
  62                <*> optional config
  63
  64 cfgNewCommand :: Mod CommandFields Options
  65 cfgNewCommand = command "cfg-new" (info cfgNewOption (progDesc "new config files"))
  66
  67 cfgUpdateOption :: Parser Options
  68 cfgUpdateOption = CfgUpdate
  69                   <$> config
  70                   <*> optional (argument (eitherReader (parseOnly fieldParser. pack)) (metavar "RANGE"))
  71
  72 cfgUpdateCommand :: Mod CommandFields Options
  73 cfgUpdateCommand = command "cfg-update" (info cfgUpdateOption (progDesc "update config files"))
  74
  75 options :: Parser FullOptions
  76 options = FullOptions
  77           <$> debug
  78           <*> hsubparser (processCommand <> cfgNewCommand <> cfgUpdateCommand)
  79
  80 newtype App a =
  81     App { unApp :: ReaderT FullOptions (LoggingT IO) a }
  82     deriving newtype
  83     ( Applicative
  84     , Functor
  85     , Monad
  86     , MonadIO
  87     , MonadReader FullOptions
  88     , MonadLogger
  89     , MonadThrow
  90     )
  91
  92 runApp :: FullOptions -> (LoggingT IO a -> IO a) -> App a -> IO a
  93 runApp env runLogging action =
  94   runLogging $ runReaderT (unApp action) env
  95
  96 app :: App ()
  97 app = do
  98   (FullOptions _ o) <- ask
  99   case o of
 100     (Process mf mr)  -> process mf mr
 101     (CfgNew p mf)    -> new p mf
 102     (CfgUpdate f mr) -> update f mr
 103
 104 main :: IO ()
 105 main = do
 106   let opts = info (options <**> helper)
 107              ( fullDesc
 108              <> progDesc "binoculars subcommand"
 109              <> header "binoculars - bin your data's" )
 110   fopts@(FullOptions d _) <- execParser opts
 111   let debugLogging = if d then id else filterLogger (\_ l -> l /=LevelDebug)
 112   let runLogging = runStdoutLoggingT . debugLogging
 113   runApp fopts runLogging app