{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE OverloadedStrings #-}

-- | Separate module because TH.

module System.Process.Log

(logCreateProcess

,withProcessTimeLog

,showProcessArgDebug)

where

import Control.Monad.IO.Class

import Control.Monad.Logger

import Data.Monoid

import Data.Text (Text)

import qualified Data.Text as T

import Language.Haskell.TH

import qualified System.Clock as Clock

import System.Process (CreateProcess(..), CmdSpec(..))

-- | Log running a process with its arguments, for debugging (-v).

logCreateProcess :: Q Exp

logCreateProcess =

[|let f :: MonadLogger m => CreateProcess -> m ()

f CreateProcess { cmdspec = ShellCommand shellCmd } =

$logDebug ("Creating shell process: " <> T.pack shellCmd)

f CreateProcess { cmdspec = RawCommand name args } =

$logDebug

("Creating process: " <> T.pack name <> " " <>

T.intercalate

" "

(map showProcessArgDebug args))

in f|]

-- | Log running a process with its arguments, for debugging (-v).

--

-- This logs one message before running the process and one message after.

withProcessTimeLog :: Q Exp

withProcessTimeLog =

[|let f :: (MonadIO m, MonadLogger m) => String -> [String] -> m a -> m a

f 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

in f|]

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 = T.pack (show x)

| otherwise = T.pack x

where special '"' = True

special ' ' = True

special _ = False