Re-namespace some stuff to Omni

I was getting confused about what is a product and what is internal
infrastructure; I think it is good to keep those things separate. So I moved a
bunch of stuff to an Omni namespace, actually most stuff went there. Only things
that are explicitly external products are still in the Biz namespace.

1 files changed, 133 insertions, 0 deletions

diff --git a/Omni/Log.hs b/Omni/Log.hs
new file mode 100644
index 0000000..91fcb55
--- /dev/null
+++ b/Omni/Log.hs
@@ -0,0 +1,133 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Log reporting interface
+--
+-- Some guidelines:
+--
+--    * don't allow `mark` in final code
+--
+--    * don't use `br` after `info`, unless verbose mode is requested (--loud flag in bild)
+--
+--    * always use `br` after `good`, `fail`, and `pass`
+--
+--    * often use `br` after `warn`, unless its really unimportant
+--
+--    * labels should be roughly hierarchical from general->specific
+module Omni.Log
+  ( Lvl (..),
+    good,
+    pass,
+    info,
+    warn,
+    fail,
+    wipe,
+
+    -- * Debugging
+    mark,
+
+    -- * Operators
+    (~&),
+    (~?),
+
+    -- * Wai Middleware
+    wai,
+
+    -- * Low-level
+    msg,
+    fmt,
+    br,
+  )
+where
+
+import Alpha hiding (pass)
+import qualified Data.Text as Text
+import qualified Network.Wai as Wai
+import Rainbow (chunk, fore, green, magenta, red, white, yellow)
+import qualified Rainbow
+import qualified System.Environment as Env
+import qualified System.IO as IO
+import System.IO.Unsafe (unsafePerformIO)
+
+data Lvl = Good | Pass | Info | Warn | Fail | Mark
+
+-- | Get the environment. This should probably return 'Omni.App.Area' instead of
+-- 'String', but I don't want to depend on everything in 'Omni.App', so some kind
+-- of refactor is needed.
+area :: IO String
+area =
+  Env.lookupEnv "AREA"
+    /> maybe "Test" identity
+
+msg :: Lvl -> [Text] -> IO ()
+msg lvl labels =
+  area +> \case
+    "Live" -> putDumb
+    _ ->
+      Env.getEnv "TERM" +> \case
+        "dumb" -> putDumb
+        _ -> Rainbow.hPutChunks IO.stderr [fore color <| clear <> chunk txt <> "\r"]
+  where
+    -- For systemd-journal, emacs *compilation* buffers, etc.
+    putDumb = putStr <| txt <> "\n"
+    txt = fmt (label : labels)
+    (color, label) = case lvl of
+      Good -> (green, "good")
+      Pass -> (green, "pass")
+      Info -> (white, "info")
+      Warn -> (yellow, "warn")
+      Fail -> (red, "fail")
+      Mark -> (magenta, "mark")
+    clear = "\ESC[2K"
+
+-- | Helper function for formatting outputs of labels.
+fmt :: [Text] -> Text
+fmt = Text.intercalate gap
+
+gap :: Text
+gap = ":  "
+
+br :: IO ()
+br = Rainbow.hPutChunks stderr ["\n"] >> IO.hFlush stderr
+
+wipe :: IO ()
+wipe = hPutStr stderr ("\r" :: Text) >> IO.hFlush stderr
+
+good, pass, info, warn, fail :: [Text] -> IO ()
+good = msg Good
+pass = msg Pass
+info = msg Info
+warn = msg Warn
+fail = msg Fail
+
+-- | Like 'Debug.trace' but follows the patterns in this module
+mark :: (Show a) => Text -> a -> a
+mark label val =
+  unsafePerformIO <| do
+    msg Mark [label, tshow val]
+    br
+    pure val
+
+-- | Pipelined version of 'mark'.
+--
+-- @
+-- mark label val = val ~& label
+-- @
+(~&) :: (Show a) => a -> Text -> a
+val ~& label = mark label val
+
+-- | Conditional mark.
+(~?) :: (Show a) => a -> (a -> Bool) -> Text -> a
+(~?) val test label = if test val then mark label val else val
+
+wai :: Wai.Middleware
+wai app req sendResponse =
+  app req <| \res ->
+    info
+      [ str <| Wai.requestMethod req,
+        show <| Wai.remoteHost req,
+        str <| Wai.rawPathInfo req
+      ]
+      >> br
+      >> sendResponse res