From: Luke Lau <luke_lau@icloud.com>
Date: Wed, 2 Oct 2019 13:34:39 +0000 (+0100)
Subject: WIP in wrapping Session in a newtype
X-Git-Tag: 0.8.0.0~3^2~3
X-Git-Url: https://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=a8e8371de3168f0faae2f33eae0d97f466c4786f

WIP in wrapping Session in a newtype
---

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 1b2e7ba..c405f67 100644
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -8,7 +8,7 @@ Module      : Language.Haskell.LSP.Test
 Description : A functional testing framework for LSP servers.
 Maintainer  : luke_lau@icloud.com
 Stability   : experimental
-Portability : POSIX
+Portability : non-portable
 
 Provides the framework to start functionally testing
 <https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>.
diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs
index 52f97ae..f292af5 100644
--- a/src/Language/Haskell/LSP/Test/Parsing.hs
+++ b/src/Language/Haskell/LSP/Test/Parsing.hs
@@ -81,7 +81,7 @@ satisfyMaybe pred = do
       threadDelay (timeout * 1000000)
       writeChan chan (TimeoutMessage timeoutId)
 
-  x <- await
+  x <- Session await
 
   unless skipTimeout $
     modify $ \s -> s { curTimeoutId = timeoutId + 1 }
@@ -98,24 +98,23 @@ satisfyMaybe pred = do
 message :: forall a. (Typeable a, FromJSON a) => Session a
 message =
   let parser = decode . encodeMsg :: FromServerMessage -> Maybe a
-  in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $
-     satisfyMaybe parser
+  in satisfyMaybe parser
 
 -- | Matches if the message is a notification.
 anyNotification :: Session FromServerMessage
-anyNotification = named "Any notification" $ satisfy isServerNotification
+anyNotification = satisfy isServerNotification
 
 -- | Matches if the message is a request.
 anyRequest :: Session FromServerMessage
-anyRequest = named "Any request" $ satisfy isServerRequest
+anyRequest = satisfy isServerRequest
 
 -- | Matches if the message is a response.
 anyResponse :: Session FromServerMessage
-anyResponse = named "Any response" $ satisfy isServerResponse
+anyResponse = satisfy isServerResponse
 
 -- | Matches a response for a specific id.
 responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a)
-responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do
+responseForId lid = do
   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
   satisfyMaybe $ \msg -> do
     z <- parser msg
@@ -133,7 +132,7 @@ encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue
 
 -- | Matches if the message is a log message notification or a show message notification/request.
 loggingNotification :: Session FromServerMessage
-loggingNotification = named "Logging notification" $ satisfy shouldSkip
+loggingNotification = satisfy shouldSkip
   where
     shouldSkip (NotLogMessage _) = True
     shouldSkip (NotShowMessage _) = True
@@ -143,7 +142,7 @@ loggingNotification = named "Logging notification" $ satisfy shouldSkip
 -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
 -- (textDocument/publishDiagnostics) notification.
 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
-publishDiagnosticsNotification = named "Publish diagnostics notification" $
-  satisfyMaybe $ \msg -> case msg of
+publishDiagnosticsNotification = satisfyMaybe $
+  \msg -> case msg of
     NotPublishDiagnostics diags -> Just diags
     _ -> Nothing
diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index b8286a2..1abad54 100644
--- a/src/Language/Haskell/LSP/Test/Session.hs
+++ b/src/Language/Haskell/LSP/Test/Session.hs
@@ -1,12 +1,13 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
 
 module Language.Haskell.LSP.Test.Session
-  ( Session
+  ( Session(..)
   , SessionConfig(..)
   , defaultConfig
   , SessionMessage(..)
@@ -28,6 +29,7 @@ module Language.Haskell.LSP.Test.Session
 
 where
 
+import Control.Applicative
 import Control.Concurrent hiding (yield)
 import Control.Exception
 import Control.Lens hiding (List)
@@ -40,7 +42,7 @@ import Control.Monad.Fail
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 import qualified Control.Monad.Trans.Reader as Reader (ask)
 import Control.Monad.Trans.State (StateT, runStateT)
-import qualified Control.Monad.Trans.State as State (get, put)
+import qualified Control.Monad.Trans.State as State
 import qualified Data.ByteString.Lazy.Char8 as B
 import Data.Aeson
 import Data.Aeson.Encode.Pretty
@@ -76,7 +78,10 @@ import System.Timeout
 -- 'Language.Haskell.LSP.Test.sendRequest' and
 -- 'Language.Haskell.LSP.Test.sendNotification'.
 
-type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
+-- newtype Session a = Session (ParserStateReader FromServerMessage SessionState SessionContext IO a)
+
+newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a)
+  deriving (Functor, Applicative, Monad, MonadIO, Alternative)
 
 #if __GLASGOW_HASKELL__ >= 806
 instance MonadFail Session where
@@ -121,10 +126,10 @@ class Monad m => HasReader r m where
   asks :: (r -> b) -> m b
   asks f = f <$> ask
 
-instance Monad m => HasReader r (ParserStateReader a s r m) where
-  ask = lift $ lift Reader.ask
+instance HasReader SessionContext Session where
+  ask  = Session (lift $ lift Reader.ask)
 
-instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where
+instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where
   ask = lift $ lift Reader.ask
 
 data SessionState = SessionState
@@ -150,19 +155,22 @@ class Monad m => HasState s m where
   modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
   modifyM f = get >>= f >>= put
 
-instance Monad m => HasState s (ParserStateReader a s r m) where
+instance HasState SessionState Session where
+  get = Session (lift State.get)
+  put = Session . lift . State.put
+
+instance Monad m => HasState s (ConduitM a b (StateT s m))
+ where
   get = lift State.get
   put = lift . State.put
 
-instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))
+instance Monad m => HasState s (ConduitParser a (StateT s m))
  where
   get = lift State.get
   put = lift . State.put
 
-type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
-
 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
-runSession context state session = runReaderT (runStateT conduit state) context
+runSession context state (Session session) = runReaderT (runStateT conduit state) context
   where
     conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
 
@@ -235,7 +243,8 @@ updateStateC = awaitForever $ \msg -> do
   updateState msg
   yield msg
 
-updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
+updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
+            => FromServerMessage -> m ()
 updateState (NotPublishDiagnostics n) = do
   let List diags = n ^. params . diagnostics
       doc = n ^. params . uri