Log.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Separate module because TH.

module System.Process.Log
    (logCreateProcess
    ,withProcessTimeLog
    ,showProcessArgDebug)
    where

import qualified Data.Text as T
import           Stack.Prelude
import qualified System.Clock as Clock
import           System.Process (CreateProcess(..), CmdSpec(..))

-- | Log running a process with its arguments, for debugging (-v).
logCreateProcess :: MonadLogger m => CreateProcess -> m ()
logCreateProcess CreateProcess { cmdspec = ShellCommand shellCmd } =
  logDebug ("Creating shell process: " <> T.pack shellCmd)
logCreateProcess CreateProcess { cmdspec = RawCommand name args } =
  logDebug
      ("Creating process: " <> T.pack name <> " " <>
       T.intercalate
           " "
           (map showProcessArgDebug args))

-- | Log running a process with its arguments, for debugging (-v).
--
-- This logs one message before running the process and one message after.
withProcessTimeLog :: (MonadIO m, MonadLogger m) => String -> [String] -> m a -> m a
withProcessTimeLog name args proc = do
  let cmdText =
          T.intercalate
              " "
              (T.pack name : map showProcessArgDebug args)
  logDebug ("Run process: " <> cmdText)
  start <- liftIO $ Clock.getTime Clock.Monotonic
  x <- proc
  end <- liftIO $ Clock.getTime Clock.Monotonic
  let diff = Clock.diffTimeSpec start end
  -- useAnsi <- asks getAnsiTerminal
  let useAnsi = True
  logDebug
      ("Process finished in " <>
      (if useAnsi then "\ESC[92m" else "") <> -- green
      timeSpecMilliSecondText diff <>
      (if useAnsi then "\ESC[0m" else "") <> -- reset
       ": " <> cmdText)
  return x

timeSpecMilliSecondText :: Clock.TimeSpec -> Text
timeSpecMilliSecondText t =
    (T.pack . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> "ms"

-- | Show a process arg including speechmarks when necessary. Just for
-- debugging purposes, not functionally important.
showProcessArgDebug :: String -> Text
showProcessArgDebug x
    | any special x || null x = T.pack (show x)
    | otherwise = T.pack x
  where special '"' = True
        special ' ' = True
        special _ = False