Initial commit

src/Effects/Log.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module Effects.Log (
+  Severity (..),
+  runLogEff,
+  stderrLogger,
+  fmtMessage,
+  addTime,
+  Log,
+  log,
+  pattern I,
+  pattern D,
+  pattern W,
+  pattern E,
+  LogData (..),
+) where
+
+import Colog.Core
+import Data.Text (Text, justifyLeft)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+import Data.Text.Lazy qualified as LT
+import Data.Text.Lazy.Builder qualified as T
+import Effectful
+import Effectful.Concurrent.QSem
+import Effectful.Dispatch.Dynamic
+import Effectful.Reader.Static
+import Effectful.TH
+import Effects.Time
+import UnliftIO.Exception (bracket_)
+import UnliftIO.IO (stderr)
+import Prelude hiding (log)
+
+import Terminal
+
+class Monoid a => LogData a where
+  toLog :: a -> T.Builder
+
+instance LogData T.Builder where
+  toLog = id
+
+instance LogData Text where
+  toLog = T.fromText
+
+instance LogData String where
+  toLog = T.fromString
+
+data Log :: Effect where
+  Log :: Severity -> T.Builder -> Log m ()
+
+makeEffect ''Log
+
+runLogEff ::
+  (Time :> es, Concurrent :> es, IOE :> es) =>
+  LogAction IO T.Builder ->
+  Eff (Log : es) a ->
+  Eff es a
+runLogEff logger e = do
+  lock <- newQSem 1
+
+  reinterpret
+    (runReader lock)
+    ( \_ -> \case
+        Log sev msg -> do
+          l <- ask
+          bracket_ (waitQSem l) (signalQSem l) $ do
+            t <- currentTimeB
+            liftIO $ cmap (addTime t . fmtMessage) logger <& msg `WithSeverity` sev
+    )
+    e
+
+stderrLogger ::
+  (MonadIO m) =>
+  LogAction m T.Builder
+stderrLogger = LogAction (liftIO . T.hPutStrLn stderr . LT.toStrict . T.toLazyText)
+
+fmtMessage :: WithSeverity T.Builder -> T.Builder
+fmtMessage (WithSeverity txt sev) = "[" <> T.fromText (justifyLeft 7 ' ' (colorSev sev)) <> "] - " <> txt
+ where
+  colorSev :: Severity -> Text
+  colorSev W = colorNormal Red . tshow $ W
+  colorSev a = tshow a
+
+addTime ::
+  T.Builder ->
+  T.Builder ->
+  T.Builder
+addTime t msg = (" [" :: T.Builder) <> t <> ("] " :: T.Builder) <> toLog msg
+
+--- Helpers
+tshow :: Show a => a -> Text
+tshow = T.pack . show

src/Effects/Time.hs

@@ -0,0 +1,36 @@
+module Effects.Time (
+  currentTime,
+  currentTimeB,
+  currentTimeT,
+  runTimeEff,
+  Time,
+)
+where
+
+import Chronos hiding (Time)
+import Chronos qualified as C
+import Data.Text (Text)
+import Data.Text.Lazy.Builder qualified as T
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.TH
+
+data Time :: Effect where
+  CurrentTime :: Time m C.Time
+  CurrentTimeB :: Time m T.Builder
+  CurrentTimeT :: Time m Text
+
+makeEffect ''Time
+
+runTimeEff ::
+  (IOE :> es) =>
+  Eff (Time : es) a ->
+  Eff es a
+runTimeEff = interpret $ \_ -> \case
+  CurrentTime -> liftIO now
+  CurrentTimeB ->
+    builder_YmdHMS (SubsecondPrecisionFixed 4) w3c . timeToDatetime
+      <$> liftIO now
+  CurrentTimeT ->
+    encode_YmdHMS (SubsecondPrecisionFixed 4) w3c . timeToDatetime
+      <$> liftIO now

src/Terminal.hs

@@ -0,0 +1,58 @@
+module Terminal (
+  Color (..),
+  TextFeatures (..),
+  Section (..),
+  Term (..),
+)
+where
+
+import Data.String (IsString)
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Lazy.Builder qualified as T
+
+data Color
+  = Black
+  | Red
+  | Green
+  | Yellow
+  | Blue
+  | Magenta
+  | Cyan
+  | White
+  deriving (Show, Eq, Enum)
+
+data TextFeatures
+  = AllOff
+  | Bold
+  | Underline
+  | BlinkOn
+  | BoldOff
+  | UnderlineOff
+  | BlinkOff
+  deriving (Eq)
+
+data Section
+  = Foreground
+  | Background
+
+class (IsString a, Monoid a) => Term a where
+  color :: Color -> Bool -> a -> a
+
+  colorBright :: Color -> a -> a
+  colorBright c = color c True
+
+  colorNormal :: Color -> a -> a
+  colorNormal c = color c False
+
+instance Term T.Builder where
+  color c bright txt =
+    let f = if bright then "9" else "3"
+        col = T.fromString . show . fromEnum $ c
+     in "\x1b[" <> f <> col <> "m" <> txt <> "\x1b[0m"
+
+instance Term Text where
+  color c bright txt =
+    let f = if bright then "9" else "3"
+        col = T.pack . show . fromEnum $ c
+     in "\x1b[" <> f <> col <> "m" <> txt <> "\x1b[0m"