aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--hsm-cam/Hsm/Cam.hs4
-rw-r--r--hsm-drive/Hsm/Drive.hs7
-rw-r--r--hsm-drive/Test/Drive.hs6
-rw-r--r--hsm-log/Hsm/Log.hs28
-rw-r--r--hsm-log/Hsm/Log/Options.hs4
-rw-r--r--hsm-web/Hsm/Web.hs6
-rw-r--r--hsm-web/Main.hs6
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
powered by cgit v1.2.1, back to main portfolio site