{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.LSP.Capture
  ( Event(..)
  , CaptureContext
  , noCapture
  , captureToFile
  , captureFromClient
  , captureFromServer
  ) where

import Data.Aeson
import Data.ByteString.Lazy.Char8 as BSL
import Data.Time.Clock
import GHC.Generics
import Language.Haskell.LSP.Messages
import System.IO
import Language.Haskell.LSP.Utility
import Control.Concurrent
import Control.Monad
import Control.Concurrent.STM

data Event = FromClient !UTCTime !FromClientMessage
           | FromServer !UTCTime !FromServerMessage
  deriving (Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show, Event -> Event -> Bool
(Event -> Event -> Bool) -> (Event -> Event -> Bool) -> Eq Event
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c== :: Event -> Event -> Bool
Eq, (forall x. Event -> Rep Event x)
-> (forall x. Rep Event x -> Event) -> Generic Event
forall x. Rep Event x -> Event
forall x. Event -> Rep Event x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Event x -> Event
$cfrom :: forall x. Event -> Rep Event x
Generic, [Event] -> Encoding
[Event] -> Value
Event -> Encoding
Event -> Value
(Event -> Value)
-> (Event -> Encoding)
-> ([Event] -> Value)
-> ([Event] -> Encoding)
-> ToJSON Event
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Event] -> Encoding
$ctoEncodingList :: [Event] -> Encoding
toJSONList :: [Event] -> Value
$ctoJSONList :: [Event] -> Value
toEncoding :: Event -> Encoding
$ctoEncoding :: Event -> Encoding
toJSON :: Event -> Value
$ctoJSON :: Event -> Value
ToJSON, Value -> Parser [Event]
Value -> Parser Event
(Value -> Parser Event)
-> (Value -> Parser [Event]) -> FromJSON Event
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Event]
$cparseJSONList :: Value -> Parser [Event]
parseJSON :: Value -> Parser Event
$cparseJSON :: Value -> Parser Event
FromJSON)

data CaptureContext = NoCapture | Capture (TChan Event)

noCapture :: CaptureContext
noCapture :: CaptureContext
noCapture = CaptureContext
NoCapture

captureToFile :: FilePath -> IO CaptureContext
captureToFile :: String -> IO CaptureContext
captureToFile String
fname = do
    String -> IO ()
logs (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"haskell-lsp:Logging to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname
    TChan Event
chan <- IO (TChan Event)
forall a. IO (TChan a)
newTChanIO
    ThreadId
_tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fname IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan Event -> Handle -> IO ()
writeToHandle TChan Event
chan
    CaptureContext -> IO CaptureContext
forall (m :: * -> *) a. Monad m => a -> m a
return (CaptureContext -> IO CaptureContext)
-> CaptureContext -> IO CaptureContext
forall a b. (a -> b) -> a -> b
$ TChan Event -> CaptureContext
Capture TChan Event
chan

captureFromServer :: FromServerMessage -> CaptureContext -> IO ()
captureFromServer :: FromServerMessage -> CaptureContext -> IO ()
captureFromServer FromServerMessage
_ CaptureContext
NoCapture = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
captureFromServer FromServerMessage
msg (Capture TChan Event
chan) = do
  UTCTime
time <- IO UTCTime
getCurrentTime
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Event
chan (Event -> STM ()) -> Event -> STM ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> FromServerMessage -> Event
FromServer UTCTime
time FromServerMessage
msg

captureFromClient :: FromClientMessage -> CaptureContext -> IO ()
captureFromClient :: FromClientMessage -> CaptureContext -> IO ()
captureFromClient FromClientMessage
_ CaptureContext
NoCapture = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
captureFromClient FromClientMessage
msg (Capture TChan Event
chan) = do
  UTCTime
time <- IO UTCTime
getCurrentTime
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Event
chan (Event -> STM ()) -> Event -> STM ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> FromClientMessage -> Event
FromClient UTCTime
time FromClientMessage
msg

writeToHandle :: TChan Event -> Handle -> IO ()
writeToHandle :: TChan Event -> Handle -> IO ()
writeToHandle TChan Event
chan Handle
hdl = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Event
ev <- STM Event -> IO Event
forall a. STM a -> IO a
atomically (STM Event -> IO Event) -> STM Event -> IO Event
forall a b. (a -> b) -> a -> b
$ TChan Event -> STM Event
forall a. TChan a -> STM a
readTChan TChan Event
chan
    Handle -> ByteString -> IO ()
BSL.hPutStrLn Handle
hdl (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Event -> ByteString
forall a. ToJSON a => a -> ByteString
encode Event
ev