Pretty debug messages a-la `npm`'s `debug` for Haskell's stack

stack-pretty-verbose.hs

#!/usr/bin/env stack
-- stack runghc --package ansi-terminal --package time -- -prof
import           Control.Concurrent
import           Control.Monad
import           Data.List
import           Data.Time.Clock
import           System.Console.ANSI
import           System.IO
import           System.IO.Unsafe

{-# NOINLINE lastDebugCall #-}
lastDebugCall :: MVar UTCTime
lastDebugCall = unsafePerformIO newEmptyMVar

debug :: String -> IO ()
debug s = do
    setSGR [SetColor Foreground Vivid Cyan]
    putStr "  debug "
    setSGR [Reset]
    putStr s
    setSGR [SetColor Foreground Vivid Cyan]
    td <- getTimeDiff
    putStrLn $ " +" ++ show (floor (toRational td * 1000) :: Int) ++ "ms"
    setSGR [Reset]
  where
     getTimeDiff = do
         now <- getCurrentTime
         mlastTime <- tryReadMVar lastDebugCall
         case mlastTime of
             Nothing -> do
                 putMVar lastDebugCall now
                 return 0
             Just lastTime -> do
                 _ <- swapMVar lastDebugCall now
                 return $ now `diffUTCTime` lastTime

logPrefixLength :: Int
logPrefixLength = length "2015-12-01 23:43:27.498953: [debug] "

main :: IO ()
main = do
    ln <- getLine
    if "[debug]" `isInfixOf` ln
       then debug $ drop logPrefixLength ln
       else putStrLn ln
    done <- isEOF
    unless done main