From e36a24df176cdbbd634738115f847e4fa46a0aea Mon Sep 17 00:00:00 2001 From: Paul Oliver Date: Fri, 12 Sep 2025 01:43:15 +0000 Subject: Adds `Logs` constraint combinator --- hsm-cam/Hsm/Cam.hs | 4 ++-- hsm-drive/Hsm/Drive.hs | 7 +++---- hsm-drive/Test/Drive.hs | 6 +++--- hsm-log/Hsm/Log.hs | 28 ++++++++++++++++++++-------- hsm-log/Hsm/Log/Options.hs | 4 ++-- hsm-web/Hsm/Web.hs | 6 +++--- hsm-web/Main.hs | 6 +++--- 7 files changed, 36 insertions(+), 25 deletions(-) diff --git a/hsm-cam/Hsm/Cam.hs b/hsm-cam/Hsm/Cam.hs index d1f9cd2..dfa7425 100644 --- a/hsm-cam/Hsm/Cam.hs +++ b/hsm-cam/Hsm/Cam.hs @@ -46,7 +46,7 @@ import Hsm.Cam.FFI , stopCameraManager ) import Hsm.Core.Bracket (bracketConst, bracketLiftIO_) -import Hsm.Log (Log, Severity (Attention, Info, Trace), getLevel, logMsg, makeLoggerIO) +import Hsm.Log (Log, Logs, Severity (Attention, Info, Trace), getLevel, logMsg, makeLoggerIO) import MMAP (mapShared, mkMmapFlags, mmap, munmap, protRead) import System.Directory (doesFileExist, removeFile) import System.Environment (setEnv) @@ -120,7 +120,7 @@ fromLibCameraSeverity = INFO -> Info _ -> Attention -runCam :: (IOE :> es, Log "cam" :> es, Log "libcamera" :> es) => Eff (Cam : es) a -> Eff es a +runCam :: (IOE :> es, Logs '["cam", "libcamera"] es) => Eff (Cam : es) a -> Eff es a runCam action = do requestCallbackMVar <- liftIO newEmptyMVar bracketConst loggerAlloc loggerDealloc diff --git a/hsm-drive/Hsm/Drive.hs b/hsm-drive/Hsm/Drive.hs index f9bdc43..cf8e4f1 100644 --- a/hsm-drive/Hsm/Drive.hs +++ b/hsm-drive/Hsm/Drive.hs @@ -18,7 +18,7 @@ import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, (:>)) import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep, unsafeEff_) import Effectful.Exception (AsyncException, bracket_, handle) import Hsm.GPIO (GPIO, GPIOPin (..), active, inactive, setPins) -import Hsm.Log (Log, Severity (Attention, Info, Trace), logMsg) +import Hsm.Log (Logs, Severity (Attention, Info, Trace), logMsg) import Hsm.PWM (PWM, PWMChannel (..), setCycleDuration) data Drive (a :: * -> *) (b :: *) @@ -115,8 +115,7 @@ step = PWM3 -- Executes a sequence of drive actions with interruption support -- Wakes motors from SLEEP mode during execution and guarantees return to SLEEP -- mode upon completion or interruption. -drive - :: (GPIO :> es, IOE :> es, Log "drive" :> es, Log "gpio" :> es, Log "pwm" :> es, PWM :> es) => [Action] -> Eff es () +drive :: (GPIO :> es, IOE :> es, Logs '["drive", "gpio", "pwm"] es, PWM :> es) => [Action] -> Eff es () drive actions = bracket_ awaken sleep . handle handler . forM_ actions $ \action -> do logMsg @"drive" Trace $ "Running action: " <> show action @@ -186,7 +185,7 @@ drive actions = -- in its current position. runAction (Stop duration) = delay duration -runDrive :: (GPIO :> es, IOE :> es, Log "drive" :> es, Log "gpio" :> es) => Eff (Drive : es) a -> Eff es a +runDrive :: (GPIO :> es, IOE :> es, Logs '["drive", "gpio"] es) => Eff (Drive : es) a -> Eff es a runDrive = evalStaticRep (Drive ()) . bracket_ enterActive exitActive where alwaysActive = [ms1, ms2, ms3, notReset] diff --git a/hsm-drive/Test/Drive.hs b/hsm-drive/Test/Drive.hs index e6332fd..96bd4f4 100644 --- a/hsm-drive/Test/Drive.hs +++ b/hsm-drive/Test/Drive.hs @@ -23,9 +23,9 @@ type Prompt = AppendSymbol Name " λ " type Imports = '["Hsm.Drive", "Prelude"] -type Loggers = '["drive", "gpio", "pwm", "repl"] +type Logs = '["drive", "gpio", "pwm", "repl"] -$(makeLoggerOptionParser @Loggers "Options" "parser" 'Info) +$(makeLoggerOptionParser @Logs "Options" "parser" 'Info) main :: IO () main = @@ -35,5 +35,5 @@ main = & runGPIO @Name & runPWM & runRepl @Prompt @Imports - & runLogsOpt @Options @Loggers opts + & runLogsOpt @Options @Logs opts & runEff diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs index 99e5b7c..bd8c73f 100644 --- a/hsm-log/Hsm/Log.hs +++ b/hsm-log/Hsm/Log.hs @@ -5,10 +5,11 @@ module Hsm.Log ( Severity (Attention, Info, Trace) , Log + , Logs + , LogOptionPrefix , getLevel , logMsg , makeLoggerIO - , LoggerOptionPrefix , runLog , runLogOpt , runLogs @@ -18,6 +19,7 @@ where import Control.Monad (when) import Data.Function (applyWhen) +import Data.Kind (Constraint) import Data.List (intercalate) import Data.Proxy (Proxy (Proxy)) import Data.Time.Clock (getCurrentTime) @@ -55,6 +57,18 @@ type instance DispatchOf (Log d) = Static WithSideEffects newtype instance StaticRep (Log d) = Log Severity +-- Constraint combinator for multiple logger effects +-- Simplifies effect constraints for functions requiring multiple loggers. +-- +-- Example: +-- >>> :kind! Logs '["log1", "log2"] es +-- (Log "log1" :> es, Log "log2" :> es) +type family Logs ls es :: Constraint where + Logs '[] es = () + Logs (l : ls) es = (Log l :> es, Logs ls es) + +type LogOptionPrefix = "logLevel_" + getLevel :: Log d :> es => Eff es Severity getLevel = getStaticRep >>= \(Log level) -> return level @@ -83,8 +97,6 @@ makeLoggerIO => Eff es (Severity -> String -> IO ()) makeLoggerIO = unsafeEff $ \env -> return $ \severity message -> unEff (logMsg severity message) env -type LoggerOptionPrefix = "logLevel_" - runLog :: forall d es a . IOE :> es @@ -95,25 +107,25 @@ runLog = evalStaticRep . Log runLogOpt :: forall d f o es a - . (AppendSymbol LoggerOptionPrefix d ~ f, HasField f o Severity, IOE :> es) + . (AppendSymbol LogOptionPrefix d ~ f, HasField f o Severity, IOE :> es) => o -> Eff (Log d : es) a -> Eff es a runLogOpt = runLog . getField @f -class Logs (o :: *) (ds :: [Symbol]) (es :: [Effect]) where +class LogsClass (o :: *) (ds :: [Symbol]) (es :: [Effect]) where type Insert ds es :: [Effect] runLogs :: Severity -> Eff (Insert ds es) a -> Eff es a runLogsOpt :: o -> Eff (Insert ds es) a -> Eff es a -instance Logs (o :: *) ('[] :: [Symbol]) (es :: [Effect]) where +instance LogsClass (o :: *) ('[] :: [Symbol]) (es :: [Effect]) where type Insert '[] es = es runLogs = const id runLogsOpt = const id instance - (AppendSymbol LoggerOptionPrefix d ~ f, HasField f o Severity, IOE :> Insert ds es, KnownSymbol d, Logs o ds es) - => Logs (o :: *) (d : ds :: [Symbol]) (es :: [Effect]) + (AppendSymbol LogOptionPrefix d ~ f, HasField f o Severity, IOE :> Insert ds es, KnownSymbol d, LogsClass o ds es) + => LogsClass (o :: *) (d : ds :: [Symbol]) (es :: [Effect]) where type Insert (d : ds) es = Log d : Insert ds es runLogs level = runLogs @o @ds level . runLog @d level diff --git a/hsm-log/Hsm/Log/Options.hs b/hsm-log/Hsm/Log/Options.hs index 0e00b32..877aa4b 100644 --- a/hsm-log/Hsm/Log/Options.hs +++ b/hsm-log/Hsm/Log/Options.hs @@ -9,7 +9,7 @@ where import Data.Proxy (Proxy (Proxy)) import GHC.TypeLits (symbolVal) import Generic.Data.Function.Common.Generic.Meta (KnownSymbols, symbolVals) -import Hsm.Log (LoggerOptionPrefix, Severity) +import Hsm.Log (LogOptionPrefix, Severity) import Language.Haskell.TH ( Bang (Bang) , Body (NormalB) @@ -56,7 +56,7 @@ makeLoggerOptionParser dataNameString parserNameString defaultSeverity = loggers = symbolVals @ls -- Record dataName = mkName dataNameString - fieldPrefix = symbolVal $ Proxy @LoggerOptionPrefix + fieldPrefix = symbolVal $ Proxy @LogOptionPrefix fieldName logger = mkName $ fieldPrefix <> logger fieldBang = Bang NoSourceUnpackedness NoSourceStrictness fieldType = ConT ''Severity diff --git a/hsm-web/Hsm/Web.hs b/hsm-web/Hsm/Web.hs index b8f8881..8c0284c 100644 --- a/hsm-web/Hsm/Web.hs +++ b/hsm-web/Hsm/Web.hs @@ -20,7 +20,7 @@ import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive (Env) import Effectful.Exception (finally) import Hsm.Cam (Cam, capturePng) -import Hsm.Log (Log, Severity (Info, Trace), logMsg, makeLoggerIO) +import Hsm.Log (Log, Logs, Severity (Info, Trace), logMsg, makeLoggerIO) import Network.Wai.Handler.Warp (defaultSettings, setLogger) import Paths_hsm_web (getDataFileName) import Web.Scotty (Options (settings, verbose), defaultOptions, file, get, liftIO, raw, scottyOpts, setHeader) @@ -41,7 +41,7 @@ server options env = do setHeader "Content-Type" "image/png" liftIO (unEff capturePng env) >>= raw -runServer :: (Cam :> es, Log "cam" :> es, Log "web" :> es, Web :> es) => Eff es () +runServer :: (Cam :> es, Logs '["cam", "web"] es, Web :> es) => Eff es () runServer = finally startServer stopServer where startServer = do @@ -50,7 +50,7 @@ runServer = finally startServer stopServer unsafeEff $ server options stopServer = logMsg @"web" Info "Stopping scotty web server" -runWeb :: (IOE :> es, Log "scotty" :> es, Log "web" :> es) => Eff (Web : es) a -> Eff es a +runWeb :: (IOE :> es, Logs '["scotty", "web"] es) => Eff (Web : es) a -> Eff es a runWeb action = do logMsg @"web" Info "Registering logger for scotty web server" scottyLogger <- makeLoggerIO @"scotty" >>= return . logRequest diff --git a/hsm-web/Main.hs b/hsm-web/Main.hs index 6cbfa31..82e07c9 100644 --- a/hsm-web/Main.hs +++ b/hsm-web/Main.hs @@ -11,9 +11,9 @@ import Hsm.Web (runServer, runWeb) -- Avoids package/module qualifiers in generated code import Options.Applicative -type Loggers = '["cam", "libcamera", "scotty", "web"] +type Logs = '["cam", "libcamera", "scotty", "web"] -$(makeLoggerOptionParser @Loggers "Options" "parser" 'Info) +$(makeLoggerOptionParser @Logs "Options" "parser" 'Info) main :: IO () -main = bootstrapAppNoEcho parser "Launch HsMouse Web Server" $ \opts -> runServer & runWeb & runCam & runLogsOpt @Options @Loggers opts & runEff +main = bootstrapAppNoEcho parser "Launch HsMouse Web Server" $ \opts -> runServer & runWeb & runCam & runLogsOpt @Options @Logs opts & runEff -- cgit v1.2.1