{-# 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 Biz.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 'Biz.App.Area' instead of
-- 'String', but I don't want to depend on everything in 'Biz.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