From 307cb1b1094c73fd15eab378c27ac0073696b739 Mon Sep 17 00:00:00 2001 From: Paul Oliver Date: Tue, 19 Aug 2025 03:56:40 +0000 Subject: Improves formatting --- hsm-cam/FFI/Cam.cpp | 36 +++++++++----- hsm-cam/FFI/Cam.hpp | 6 ++- hsm-cam/Hsm/Cam.hs | 11 ++--- hsm-cam/Hsm/Cam/FFI.hs | 36 ++++++++++++++ hsm-cam/Hsm/Cam/FFI.hsc | 40 ---------------- hsm-core/hsm-core.cabal | 2 + hsm-gpio/Hsm/GPIO.hs | 9 ++-- hsm-gpio/Hsm/GPIO/FFI.hs | 118 ++++++++++++++++++++++++++++++++++++++++++++++ hsm-gpio/Hsm/GPIO/FFI.hsc | 116 --------------------------------------------- hsm-log/Hsm/Log.hs | 10 +--- hsm-pwm/Hsm/PWM.hs | 10 ++-- hsm-repl/Hsm/Repl.hs | 4 +- stack.yaml | 2 +- stack.yaml.lock | 8 ++-- 14 files changed, 203 insertions(+), 205 deletions(-) create mode 100644 hsm-cam/Hsm/Cam/FFI.hs delete mode 100644 hsm-cam/Hsm/Cam/FFI.hsc create mode 100644 hsm-gpio/Hsm/GPIO/FFI.hs delete mode 100644 hsm-gpio/Hsm/GPIO/FFI.hsc diff --git a/hsm-cam/FFI/Cam.cpp b/hsm-cam/FFI/Cam.cpp index 5f2ca1f..05fd1a8 100644 --- a/hsm-cam/FFI/Cam.cpp +++ b/hsm-cam/FFI/Cam.cpp @@ -1,8 +1,8 @@ -#include +#include "Cam.hpp" #include -#include "Cam.hpp" +#include using namespace libcamera; using namespace std; @@ -15,27 +15,37 @@ unique_ptr g_config; unique_ptr g_allocator; unique_ptr g_request; -template -void logMsg(Severity severity, const format_string fmt, const Args&... args) { +template +void +logMsg(Severity severity, const format_string fmt, const Args &...args) +{ g_logger(severity, vformat(fmt.get(), make_format_args(args...)).c_str()); } -void request_complete(Request *request) { +void +request_complete(Request *request) +{ logMsg(Trace, "Completed request"); g_callback(request->buffers().begin()->second->planes()[0].fd.get()); } -extern "C" void register_logger(HsLogger hs_logger) { +extern "C" void +register_logger(HsLogger hs_logger) +{ g_logger = hs_logger; logMsg(Info, "Registered FFI logger"); } -extern "C" void register_callback(HsCallback hs_callback) { +extern "C" void +register_callback(HsCallback hs_callback) +{ g_callback = hs_callback; logMsg(Info, "Registered FFI callback"); } -extern "C" void initialize_ffi() { +extern "C" void +initialize_ffi() +{ logMsg(Info, "Starting camera manager"); g_manager = make_unique(); g_manager->start(); @@ -45,7 +55,7 @@ extern "C" void initialize_ffi() { g_camera->acquire(); logMsg(Info, "Generating still capture configuration"); - g_config = g_camera->generateConfiguration({StreamRole::StillCapture}); + g_config = g_camera->generateConfiguration({ StreamRole::StillCapture }); g_camera->configure(g_config.get()); logMsg(Info, "Allocating buffer"); @@ -59,7 +69,9 @@ extern "C" void initialize_ffi() { g_camera->start(); } -extern "C" void shutdown_ffi() { +extern "C" void +shutdown_ffi() +{ logMsg(Info, "Stopping camera"); g_camera->stop(); @@ -75,7 +87,9 @@ extern "C" void shutdown_ffi() { g_manager->stop(); } -extern "C" void request_capture() { +extern "C" void +request_capture() +{ logMsg(Trace, "Requesting still capture"); Stream *stream = (*g_config)[0].stream(); diff --git a/hsm-cam/FFI/Cam.hpp b/hsm-cam/FFI/Cam.hpp index e59fa1d..c2cd4ed 100644 --- a/hsm-cam/FFI/Cam.hpp +++ b/hsm-cam/FFI/Cam.hpp @@ -1,7 +1,8 @@ #ifndef CAM_HPP #define CAM_HPP -enum Severity { +enum Severity +{ Attention = 0, Info = 1, Trace = 2, @@ -11,7 +12,8 @@ typedef void (*HsLogger)(enum Severity, const char *); typedef void (*HsCallback)(int fd); #ifdef __cplusplus -extern "C" { +extern "C" +{ #endif void register_logger(HsLogger hs_logger); void register_callback(HsCallback hs_callback); diff --git a/hsm-cam/Hsm/Cam.hs b/hsm-cam/Hsm/Cam.hs index 9857557..78a3e25 100644 --- a/hsm-cam/Hsm/Cam.hs +++ b/hsm-cam/Hsm/Cam.hs @@ -47,9 +47,7 @@ stillCapture = do logMsg Trace $ "Still capture data available in FD " <> show fd runCam - :: (IOE :> es, Log "cam" :> es, Resource :> es) - => Eff (Cam : es) a - -> Eff es a + :: (IOE :> es, Log "cam" :> es, Resource :> es) => Eff (Cam : es) a -> Eff es a runCam action = do fdVar <- liftIO newEmptyMVar void loggerBracket @@ -62,16 +60,13 @@ runCam action = do loggerAlloc = do logMsg Info "Registering FFI logger" loggerIO <- getLoggerIO - loggerFFI <- - liftIO . makeLogger $ \severity message -> - peekCString message >>= loggerIO (toEnum severity) + loggerFFI <- liftIO . makeLogger $ \severity message -> peekCString message >>= loggerIO (toEnum severity) liftIO $ registerLogger loggerFFI return loggerFFI loggerDealloc loggerFFI = do logMsg Info "Unregistering FFI logger" liftIO $ freeHaskellFunPtr loggerFFI - requestCallbackBracket fdVar = - allocateEff requestCallbackAlloc requestCallbackDealloc + requestCallbackBracket fdVar = allocateEff requestCallbackAlloc requestCallbackDealloc where requestCallbackAlloc = do logMsg Info "Registering FFI callback" diff --git a/hsm-cam/Hsm/Cam/FFI.hs b/hsm-cam/Hsm/Cam/FFI.hs new file mode 100644 index 0000000..93d2f57 --- /dev/null +++ b/hsm-cam/Hsm/Cam/FFI.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE CApiFFI #-} + +module Hsm.Cam.FFI + ( makeLogger + , registerLogger + , makeCallback + , registerCallback + , initializeFFI + , shutdownFFI + , requestCapture + ) +where + +import Foreign.C.String (CString) +import Foreign.Ptr (FunPtr) + +type Logger = Int -> CString -> IO () + +type Callback = Int -> IO () + +foreign import ccall safe "wrapper" makeLogger :: Logger -> IO (FunPtr Logger) + +foreign import capi safe "Cam.hpp register_logger" + registerLogger :: FunPtr Logger -> IO () + +foreign import ccall safe "wrapper" + makeCallback :: Callback -> IO (FunPtr Callback) + +foreign import capi safe "Cam.hpp register_callback" + registerCallback :: FunPtr Callback -> IO () + +foreign import capi safe "Cam.hpp initialize_ffi" initializeFFI :: IO () + +foreign import capi safe "Cam.hpp shutdown_ffi" shutdownFFI :: IO () + +foreign import capi safe "Cam.hpp request_capture" requestCapture :: IO () diff --git a/hsm-cam/Hsm/Cam/FFI.hsc b/hsm-cam/Hsm/Cam/FFI.hsc deleted file mode 100644 index 44f3f4b..0000000 --- a/hsm-cam/Hsm/Cam/FFI.hsc +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE CApiFFI #-} - -module Hsm.Cam.FFI - ( makeLogger - , registerLogger - , makeCallback - , registerCallback - , initializeFFI - , shutdownFFI - , requestCapture - ) -where - -import Foreign.C.String (CString) -import Foreign.Ptr (FunPtr) - -type Logger = Int -> CString -> IO () - -type Callback = Int -> IO () - -foreign import ccall safe "wrapper" - makeLogger :: Logger -> IO (FunPtr Logger) - -foreign import capi safe "Cam.hpp register_logger" - registerLogger :: FunPtr Logger -> IO () - -foreign import ccall safe "wrapper" - makeCallback :: Callback -> IO (FunPtr Callback) - -foreign import capi safe "Cam.hpp register_callback" - registerCallback :: FunPtr Callback -> IO () - -foreign import capi safe "Cam.hpp initialize_ffi" - initializeFFI :: IO () - -foreign import capi safe "Cam.hpp shutdown_ffi" - shutdownFFI :: IO () - -foreign import capi safe "Cam.hpp request_capture" - requestCapture :: IO () diff --git a/hsm-core/hsm-core.cabal b/hsm-core/hsm-core.cabal index 10862f7..856a359 100644 --- a/hsm-core/hsm-core.cabal +++ b/hsm-core/hsm-core.cabal @@ -3,10 +3,12 @@ author: Paul Oliver name: hsm-core version: 0.1.0.0 + library build-depends: , base , template-haskell + default-language: GHC2024 exposed-modules: Hsm.Core.Serial ghc-options: -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs index 2bcf3ed..7cc2c36 100644 --- a/hsm-gpio/Hsm/GPIO.hs +++ b/hsm-gpio/Hsm/GPIO.hs @@ -73,8 +73,7 @@ setPins :: (GPIO :> es, Log "gpio" :> es) => [GPIOPin] -> LineValue -> Eff es () setPins pins lineValue = do GPIO lineRequest <- getStaticRep logMsg Trace $ "Setting pin(s) " <> show pins <> " to " <> show lineValue - forM_ pins $ \pin -> - unsafeEff_ $ lineRequestSetValue lineRequest (pinLine pin) lineValue + forM_ pins $ \pin -> unsafeEff_ $ lineRequestSetValue lineRequest (pinLine pin) lineValue setAllPins :: (GPIO :> es, Log "gpio" :> es) => LineValue -> Eff es () setAllPins lineValue = do @@ -122,8 +121,7 @@ runGPIO consumer action = do lineSettingsDealloc lineSettings = do logMsg Info "Freeing line settings" liftIO $ lineSettingsFree lineSettings - lineConfigBracket lineSettings = - allocateEff lineConfigAlloc lineConfigDealloc + lineConfigBracket lineSettings = allocateEff lineConfigAlloc lineConfigDealloc where lineConfigAlloc = do logMsg Info "Allocating line config" @@ -150,8 +148,7 @@ runGPIO consumer action = do requestConfigDealloc requestConfig = do logMsg Info "Freeing request config" liftIO $ requestConfigFree requestConfig - lineRequestBracket chip requestConfig lineConfig = - allocateEff lineRequestAlloc lineRequestDealloc + lineRequestBracket chip requestConfig lineConfig = allocateEff lineRequestAlloc lineRequestDealloc where lineRequestAlloc = do logMsg Info "Allocating line request" diff --git a/hsm-gpio/Hsm/GPIO/FFI.hs b/hsm-gpio/Hsm/GPIO/FFI.hs new file mode 100644 index 0000000..c1bb9e8 --- /dev/null +++ b/hsm-gpio/Hsm/GPIO/FFI.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE CApiFFI #-} + +-- FFI bindings to `libgpiod` for direct GPIO hardware access. +-- +-- Exposes only the minimal required subset of `libgpiod` functionality used by +-- this project. The bindings are suitable for low-level hardware control. +-- +-- Future work could expand this into a comprehensive `gpiod` binding package. +module Hsm.GPIO.FFI + ( chipOpen + , chipClose + , input + , output + , LineValue + , active + , inactive + , lineSettingsNew + , lineSettingsFree + , lineSettingsSetDirection + , lineSettingsSetOutputValue + , lineConfigNew + , lineConfigFree + , lineConfigAddLineSettings + , requestConfigNew + , requestConfigFree + , requestConfigSetConsumer + , LineRequest + , chipRequestLines + , lineRequestRelease + , lineRequestSetValue + , lineRequestSetValues + ) +where + +import Foreign.C.String (CString) +import Foreign.C.Types (CInt (CInt), CSize (CSize), CUInt (CUInt)) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable) + +data Chip + +foreign import capi unsafe "gpiod.h gpiod_chip_open" + chipOpen :: CString -> IO (Ptr Chip) + +foreign import capi unsafe "gpiod.h gpiod_chip_close" + chipClose :: Ptr Chip -> IO () + +data LineSettings + +newtype LineDirection + = LineDirection CInt + deriving Show + +foreign import capi safe "gpiod.h value GPIOD_LINE_DIRECTION_INPUT" + input :: LineDirection + +foreign import capi safe "gpiod.h value GPIOD_LINE_DIRECTION_OUTPUT" + output :: LineDirection + +newtype LineValue + = LineValue CInt + deriving (Show, Storable) + +foreign import capi safe "gpiod.h value GPIOD_LINE_VALUE_ACTIVE" + active :: LineValue + +foreign import capi safe "gpiod.h value GPIOD_LINE_VALUE_INACTIVE" + inactive :: LineValue + +foreign import capi unsafe "gpiod.h gpiod_line_settings_new" + lineSettingsNew :: IO (Ptr LineSettings) + +foreign import capi unsafe "gpiod.h gpiod_line_settings_free" + lineSettingsFree :: Ptr LineSettings -> IO () + +foreign import capi unsafe "gpiod.h gpiod_line_settings_set_direction" + lineSettingsSetDirection :: Ptr LineSettings -> LineDirection -> IO CInt + +foreign import capi unsafe "gpiod.h gpiod_line_settings_set_output_value" + lineSettingsSetOutputValue :: Ptr LineSettings -> LineValue -> IO CInt + +data LineConfig + +foreign import capi unsafe "gpiod.h gpiod_line_config_new" + lineConfigNew :: IO (Ptr LineConfig) + +foreign import capi unsafe "gpiod.h gpiod_line_config_free" + lineConfigFree :: Ptr LineConfig -> IO () + +foreign import capi unsafe "gpiod.h gpiod_line_config_add_line_settings" + lineConfigAddLineSettings + :: Ptr LineConfig -> Ptr CUInt -> CSize -> Ptr LineSettings -> IO CInt + +data RequestConfig + +foreign import capi unsafe "gpiod.h gpiod_request_config_new" + requestConfigNew :: IO (Ptr RequestConfig) + +foreign import capi unsafe "gpiod.h gpiod_request_config_free" + requestConfigFree :: Ptr RequestConfig -> IO () + +foreign import capi unsafe "gpiod.h gpiod_request_config_set_consumer" + requestConfigSetConsumer :: Ptr RequestConfig -> CString -> IO () + +data LineRequest + +foreign import capi unsafe "gpiod.h gpiod_chip_request_lines" + chipRequestLines + :: Ptr Chip -> Ptr RequestConfig -> Ptr LineConfig -> IO (Ptr LineRequest) + +foreign import capi unsafe "gpiod.h gpiod_line_request_release" + lineRequestRelease :: Ptr LineRequest -> IO () + +foreign import capi unsafe "gpiod.h gpiod_line_request_set_value" + lineRequestSetValue :: Ptr LineRequest -> CUInt -> LineValue -> IO CInt + +foreign import capi unsafe "gpiod.h gpiod_line_request_set_values" + lineRequestSetValues :: Ptr LineRequest -> Ptr LineValue -> IO CInt diff --git a/hsm-gpio/Hsm/GPIO/FFI.hsc b/hsm-gpio/Hsm/GPIO/FFI.hsc deleted file mode 100644 index f0f5737..0000000 --- a/hsm-gpio/Hsm/GPIO/FFI.hsc +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE CApiFFI #-} - --- FFI bindings to `libgpiod` for direct GPIO hardware access. --- --- Exposes only the minimal required subset of `libgpiod` functionality used by --- this project. The bindings are suitable for low-level hardware control. --- --- Future work could expand this into a comprehensive `gpiod` binding package. -module Hsm.GPIO.FFI - ( chipOpen - , chipClose - , input - , output - , LineValue - , active - , inactive - , lineSettingsNew - , lineSettingsFree - , lineSettingsSetDirection - , lineSettingsSetOutputValue - , lineConfigNew - , lineConfigFree - , lineConfigAddLineSettings - , requestConfigNew - , requestConfigFree - , requestConfigSetConsumer - , LineRequest - , chipRequestLines - , lineRequestRelease - , lineRequestSetValue - , lineRequestSetValues - ) -where - -import Foreign.C.String (CString) -import Foreign.C.Types (CInt (CInt), CSize (CSize), CUInt (CUInt)) -import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable) - -data Chip - -foreign import capi unsafe "gpiod.h gpiod_chip_open" - chipOpen :: CString -> IO (Ptr Chip) - -foreign import capi unsafe "gpiod.h gpiod_chip_close" - chipClose :: Ptr Chip -> IO () - -data LineSettings - -newtype LineDirection - = LineDirection CInt - deriving Show - -foreign import capi "gpiod.h value GPIOD_LINE_DIRECTION_INPUT" - input :: LineDirection - -foreign import capi "gpiod.h value GPIOD_LINE_DIRECTION_OUTPUT" - output :: LineDirection - -newtype LineValue - = LineValue CInt - deriving (Show, Storable) - -foreign import capi "gpiod.h value GPIOD_LINE_VALUE_ACTIVE" - active :: LineValue - -foreign import capi "gpiod.h value GPIOD_LINE_VALUE_INACTIVE" - inactive :: LineValue - -foreign import capi unsafe "gpiod.h gpiod_line_settings_new" - lineSettingsNew :: IO (Ptr LineSettings) - -foreign import capi unsafe "gpiod.h gpiod_line_settings_free" - lineSettingsFree :: Ptr LineSettings -> IO () - -foreign import capi unsafe "gpiod.h gpiod_line_settings_set_direction" - lineSettingsSetDirection :: Ptr LineSettings -> LineDirection -> IO CInt - -foreign import capi unsafe "gpiod.h gpiod_line_settings_set_output_value" - lineSettingsSetOutputValue :: Ptr LineSettings -> LineValue -> IO CInt - -data LineConfig - -foreign import capi unsafe "gpiod.h gpiod_line_config_new" - lineConfigNew :: IO (Ptr LineConfig) - -foreign import capi unsafe "gpiod.h gpiod_line_config_free" - lineConfigFree :: Ptr LineConfig -> IO () - -foreign import capi unsafe "gpiod.h gpiod_line_config_add_line_settings" - lineConfigAddLineSettings :: Ptr LineConfig -> Ptr CUInt -> CSize -> Ptr LineSettings -> IO CInt - -data RequestConfig - -foreign import capi unsafe "gpiod.h gpiod_request_config_new" - requestConfigNew :: IO (Ptr RequestConfig) - -foreign import capi unsafe "gpiod.h gpiod_request_config_free" - requestConfigFree :: Ptr RequestConfig -> IO () - -foreign import capi unsafe "gpiod.h gpiod_request_config_set_consumer" - requestConfigSetConsumer :: Ptr RequestConfig -> CString -> IO () - -data LineRequest - -foreign import capi unsafe "gpiod.h gpiod_chip_request_lines" - chipRequestLines :: Ptr Chip -> Ptr RequestConfig -> Ptr LineConfig -> IO (Ptr LineRequest) - -foreign import capi unsafe "gpiod.h gpiod_line_request_release" - lineRequestRelease :: Ptr LineRequest -> IO () - -foreign import capi unsafe "gpiod.h gpiod_line_request_set_value" - lineRequestSetValue :: Ptr LineRequest -> CUInt -> LineValue -> IO CInt - -foreign import capi unsafe "gpiod.h gpiod_line_request_set_values" - lineRequestSetValues :: Ptr LineRequest -> Ptr LineValue -> IO CInt diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs index 088be8e..73da4bd 100644 --- a/hsm-log/Hsm/Log.hs +++ b/hsm-log/Hsm/Log.hs @@ -51,12 +51,7 @@ getLoggerIO = do when (severity <= level) $ do time <- formatISO8601Millis <$> getCurrentTime putStrLn . applyWhen (severity == Attention) red $ - printf - "%s %s [%s] %s" - time - (symbolVal $ Proxy @d) - (show severity) - message + printf "%s %s [%s] %s" time (symbolVal $ Proxy @d) (show severity) message logMsg :: forall d es @@ -64,8 +59,7 @@ logMsg => Severity -> String -> Eff es () -logMsg severity message = - getLoggerIO >>= \loggerIO -> unsafeEff_ $ loggerIO severity message +logMsg severity message = getLoggerIO >>= \loggerIO -> unsafeEff_ $ loggerIO severity message runLog :: forall d es a diff --git a/hsm-pwm/Hsm/PWM.hs b/hsm-pwm/Hsm/PWM.hs index aa16d5c..400e704 100644 --- a/hsm-pwm/Hsm/PWM.hs +++ b/hsm-pwm/Hsm/PWM.hs @@ -101,9 +101,7 @@ setCycleDuration channel cycleDuration = do setEnable channel True runPWM - :: (IOE :> es, Log "pwm" :> es, Resource :> es) - => Eff (PWM : es) a - -> Eff es a + :: (IOE :> es, Log "pwm" :> es, Resource :> es) => Eff (PWM : es) a -> Eff es a runPWM action = evalStaticRep (PWM ()) $ do void $ allocateEff_ pwmAlloc pwmDealloc @@ -126,8 +124,7 @@ runPWM action = waitWritable exportPath waitWritable unexportPath forM_ allChannels $ \channel -> do - logMsg Info $ - "Exporting channel " <> show channel <> " on chip " <> chipPath + logMsg Info $ "Exporting channel " <> show channel <> " on chip " <> chipPath liftIO . writeFile exportPath $ show (channelIndex channel) waitWritable $ enablePath channel waitWritable $ periodPath channel @@ -136,6 +133,5 @@ runPWM action = pwmDealloc = forM_ allChannels $ \channel -> do setEnable channel False - logMsg Info $ - "Unexporting channel " <> show channel <> " on chip " <> chipPath + logMsg Info $ "Unexporting channel " <> show channel <> " on chip " <> chipPath liftIO . writeFile unexportPath $ show (channelIndex channel) diff --git a/hsm-repl/Hsm/Repl.hs b/hsm-repl/Hsm/Repl.hs index 5265e59..bcde6ad 100644 --- a/hsm-repl/Hsm/Repl.hs +++ b/hsm-repl/Hsm/Repl.hs @@ -68,8 +68,8 @@ repl = query >>= maybe (return Nothing) parse . queryInput inputState . handleInterrupt (return Nothing) . withInterrupt - . getInputLine - $ symbolVal (Proxy @p) + . getInputLine $ + symbolVal (Proxy @p) parse string = do logMsg Trace $ "Parsing string: " <> string eitherValue <- diff --git a/stack.yaml b/stack.yaml index ffefbb1..8834008 100644 --- a/stack.yaml +++ b/stack.yaml @@ -8,4 +8,4 @@ packages: - hsm-log - hsm-pwm - hsm-repl -resolver: lts-24.3 +resolver: lts-24.6 diff --git a/stack.yaml.lock b/stack.yaml.lock index a48528e..b27e1f1 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -20,7 +20,7 @@ packages: hackage: typelits-printf-0.3.0.0 snapshots: - completed: - sha256: aa97dce5253937e4aa56100a0a9dc1f79a554cf543ad7cfab0afe6ed42de2f31 - size: 724941 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/3.yaml - original: lts-24.3 + sha256: 473840099b95facf73ec72dcafe53a2487bfadeceb03a981a19e16469503a342 + size: 726266 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/6.yaml + original: lts-24.6 -- cgit v1.2.1