From 69b9b1d6be98bd78cde88b90aa04059a43a6d52c Mon Sep 17 00:00:00 2001
From: Rob Rix <rob.rix@me.com>
Date: Sun, 23 Jul 2017 14:12:13 -0400
Subject: [PATCH] Pass Messages over the queue with the current time.

---
 semantic-diff.cabal  | 1 +
 src/Semantic/Task.hs | 8 ++++++--
 2 files changed, 7 insertions(+), 2 deletions(-)

diff --git a/semantic-diff.cabal b/semantic-diff.cabal
index b7d7ccc6e..9a291d1ec 100644
--- a/semantic-diff.cabal
+++ b/semantic-diff.cabal
@@ -114,6 +114,7 @@ library
                      , template-haskell
                      , text >= 1.2.1.3
                      , these
+                     , time
                      , haskell-tree-sitter
                      , c
                      , go
diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs
index d6aa6a703..b672c81bf 100644
--- a/src/Semantic/Task.hs
+++ b/src/Semantic/Task.hs
@@ -36,6 +36,8 @@ import Data.String
 import qualified Data.Syntax as Syntax
 import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra)
 import qualified Data.Syntax.Assignment as Assignment
+import qualified Data.Time.Clock as Time
+import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
 import Data.Union
 import Diff
 import qualified Files
@@ -181,7 +183,9 @@ runTaskWithOptions options task = do
     ReadBlobPairs source -> pure <$ writeLog Info "ReadBlobPairs" <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source
     WriteToOutput destination contents -> pure <$ writeLog Info "WriteToOutput" <*> liftIO (either B.hPutStr B.writeFile destination contents)
     WriteLog level message
-      | Just logLevel <- optionsLevel options, level <= logLevel -> pure <$> liftIO (atomically (writeTMQueue logQueue (level, message)))
+      | Just logLevel <- optionsLevel options, level <= logLevel -> pure <$> liftIO (do
+        now <- Time.getCurrentTime
+        atomically (writeTMQueue logQueue (Message now level message)))
       | otherwise -> pure (pure ())
     Parse parser blob -> pure <$ writeLog Info "Parse" <*> runParser options parser blob
     Decorate algebra term -> pure <$ writeLog Info "Decorate" <*> pure (decoratorWithAlgebra algebra term)
@@ -196,7 +200,7 @@ runTaskWithOptions options task = do
   where logSink options queue = do
           message <- atomically (readTMQueue queue)
           case message of
-            Just (level, message) -> do
+            Just (Message _ level message) -> do
               hPutStr stderr (formatMessage (fromMaybe True (optionsColour options)) level message)
               logSink options queue
             _ -> pure ()