WIP: LSP v2

example/daml/Main.daml

@@ -44,3 +44,4 @@ setup = script do
 
   submit bob do
     exerciseCmd bobTV Give with newOwner = alice
+  pure bobTV

hs/daml-cucumber.cabal

@@ -38,6 +38,7 @@ library
     Daml.Cucumber.LSP
     Daml.Cucumber.Parse
     Daml.Cucumber.Types
+    Reflex.LSP
 
   build-depends:
     , abacate                >=0.0     && <0.1
@@ -47,21 +48,32 @@ library
     , lens                   >=5       && <6
     , bytestring             >=0.10.12 && <0.11
     , casing                 >=0.1.4   && <0.2
+    , constraints-extras     >=0.4     && <0.5
     , containers             >=0.6.5   && <0.7
+    , dependent-sum          >=0.7     && <0.8
     , directory              >=1.3.6   && <1.4
     , directory-contents     >=0.2     && <0.3
+    , exceptions             >=0.10    && <0.11
     , filepath               >=1.4.2   && <1.5
     , fsnotify               >=0.4     && <0.5
+    , lens                   >=5       && <6
+    , lens-aeson             >=1.1     && <1.3
     , logging-effect         >=1.3     && <1.5
     , logging-effect-colors  >=0.1     && <0.2
+    , lsp-test               >=0.16    && <0.17
+    , lsp-types              >=2.1     && <2.2
     , mtl                    >=2.2.2   && <2.3
     , neat-interpolation     >=0.4     && <0.5
+    , network-uri            >=2.6     && <2.7
     , parsec                 >=3.1.14  && <3.2
+    , parser-combinators     >=1.3     && <1.4
     , prettyprinter          >=1.7     && <1.8
     , process                >=1.6.13  && <1.7
     , reflex                 >=0.9.2   && <0.10
     , reflex-fsnotify        >=0.3     && <0.4
     , reflex-process         >=0.3.3   && <0.4
+    , some                   >=1       && <1.1
+    , stm                    >=2.5     && <2.6
     , tagsoup                >=0.14.8  && <0.15
     , temporary              >=1.3     && <1.4
     , text                   >=1.2.4   && <1.3
@@ -77,17 +89,28 @@ library
   default-language:   Haskell2010
   default-extensions:
     CPP
+    ConstraintKinds
+    DataKinds
     DeriveGeneric
     FlexibleContexts
+    FlexibleInstances
+    GADTs
     GeneralizedNewtypeDeriving
     ImportQualifiedPost
+    KindSignatures
     LambdaCase
+    MultiParamTypeClasses
     OverloadedStrings
     QuasiQuotes
+    RankNTypes
     RecursiveDo
     ScopedTypeVariables
+    StandaloneDeriving
     TemplateHaskell
     TupleSections
+    TypeApplications
+    TypeOperators
+    UndecidableInstances
 
 executable daml-cucumber
   import:           warnings

hs/default.nix

@@ -27,6 +27,27 @@ let
           librarySystemDepends = (drv.librarySystemDepends or []) ++ [ nix-daml-sdk.sdk ];
         });
       logging-effect-colors = self.callHackage "logging-effect-colors" "0.1.0.0" {};
+      lsp-types = self.callHackageDirect {
+        pkg = "lsp-types";
+        ver = "2.1.0.0";
+        sha256 = "0xnrx4x3y2ldly277qbp3xk2rkaxsnpl26h4ir3d8n4z8n8hxqmf";
+      } {};
+      lsp = self.callHackageDirect {
+        pkg = "lsp";
+        ver = "2.3.0.0";
+        sha256 = "128vknywgf9skk3dccqdqbjpl47anvqzllpr19l6q97nnnk2z6di";
+      } {};
+      lsp-test = haskellLib.dontCheck (self.callHackageDirect {
+        pkg = "lsp-test";
+        ver = "0.16.0.1";
+        sha256 = "0pk5ganrija7ds1y68yg81r0n8hfjgy80zq1rqv3z4q9gq7zsrji";
+      } {});
+      lens-aeson = haskellLib.doJailbreak super.lens-aeson;
+      dependent-sum-template = self.callHackageDirect {
+        pkg = "dependent-sum-template";
+        ver = "0.2.0.1";
+        sha256 = "123chg589dcp2854rfkydb8cwkvy6abjb9wp4mxazb01w4b21v5a";
+      } {};
     };
   };
 in

hs/src/Daml/Cucumber.hs

@@ -1,12 +1,14 @@
 module Daml.Cucumber
   ( Opts(..)
   , start
+  , runWithLogger
   ) where
 
 import Control.Arrow (first)
 import Control.Exception (SomeException(..), catch)
 import Control.Lens ((^.), _2, _3)
 import Control.Monad
+import Control.Monad.Catch (MonadMask)
 import Control.Monad.IO.Class
 import Control.Monad.Log
 import Control.Monad.Log.Colors (wrapSGRCode)
@@ -28,6 +30,7 @@ import Data.Map qualified as Map
 import Data.Maybe
 import Data.Set qualified as Set
 import Data.Set (Set)
+import Data.String (IsString)
 import Data.Text qualified as T
 import Data.Text (Text)
 import Data.Text.IO qualified as T
@@ -65,13 +68,26 @@ data Opts = Opts
   }
   deriving (Show)
 
-start :: Opts -> IO ()
-start opts = do
+-- | Run an action in a context that allows logging
+runWithLogger
+  :: (MonadIO m, MonadMask m, Monoid a, Pretty a, IsString a)
+  => Bool
+  -- ^ Verbose (enable debug logging)
+  -> LoggingT (WithSeverity a) m b
+  -- ^ Action to run with logging capabilities
+  -> m b
+runWithLogger verbose go = do
   withFDHandler defaultBatchingOptions stdout 0.4 80 $ \stdoutHandler ->
-    runLoggingT runner $ \msg -> case msgSeverity msg of
-      Debug | _opts_verbose opts || _opts_logLsp opts -> stdoutHandler (renderLogMessage msg)
+    runLoggingT go $ \msg -> case msgSeverity msg of
+      Debug | verbose -> stdoutHandler (renderLogMessage msg)
       Debug -> pure ()
       _ -> stdoutHandler (renderLogMessage msg)
+
+-- | Start daml-cucumber
+start :: Opts -> IO ()
+start opts = do
+  let verbose = _opts_verbose opts || _opts_logLsp opts
+  runWithLogger verbose runner
   where
     runner = do
       case _opts_watch opts of
@@ -296,7 +312,7 @@ runTestSuite opts = do
                 outlineFormatStep outline = foldr (.) id $ mconcat $ mconcat $
                   ffor (_outline_examples outline) $ \ex -> do
                     (headerRow, values) <- maybeToList $ List.uncons (_examples_table ex)
-                    ffor (zip [(1::Int)..] values) $ \(index, vals) ->
+                    ffor (zip [(1::Int)..] values) $ \(_index, vals) ->
                       let exampleData = zip headerRow vals
                       in fmap (\(h, v) step -> step { _step_body = T.replace ("<"<>h<>">") v (_step_body step) }) exampleData
 

hs/src/Daml/Cucumber/LSP.hs

@@ -1,30 +1,49 @@
-{-# Language RankNTypes #-}
+{-# Language PolyKinds #-}
 module Daml.Cucumber.LSP
   ( runTestLspSession
   , damlPath
   ) where
 
+import Prelude hiding (log)
+
 import Control.Applicative
+import Control.Applicative.Combinators (skipManyTill)
+import Control.Lens ((^.))
+import Control.Lens qualified as Lens
 import Control.Monad
 import Control.Monad.Fix
 import Control.Monad.IO.Class
 import Control.Monad.Log
 import Daml.Cucumber.Log
 import Daml.Cucumber.Utils
 import Data.Aeson
+import Data.Aeson.Lens
 import Data.Aeson.Types
 import qualified Data.ByteString.Char8 as BS
+import Data.Constraint.Extras
+import Data.Constraint.Extras.TH
+import Data.Dependent.Sum
+import Data.Functor.Identity
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe
+import Data.Proxy
 import qualified Data.Set as Set
 import Data.Set (Set)
+import Data.Some
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
+import Language.LSP.Protocol.Lens qualified as L
+import Language.LSP.Protocol.Lens qualified as LSP
+import Language.LSP.Protocol.Message qualified as LSP
+import Language.LSP.Protocol.Types
+import Language.LSP.Test
 import NeatInterpolation (text)
+import Network.URI (escapeURIString, isUnescapedInURIComponent)
 import Reflex hiding (Request, Response)
 import Reflex.Host.Headless
+import Reflex.LSP
 import Reflex.Process
 import System.Directory
 import System.Posix.Process
@@ -127,7 +146,7 @@ setCwd :: FilePath -> Proc.CreateProcess -> Proc.CreateProcess
 setCwd fp cp = cp { Proc.cwd = Just fp }
 
 mkTestUri :: FilePath -> Text -> Text
-mkTestUri fp funcName = "daml://compiler?file=" <> (T.replace "/" "%2F" $ T.pack fp) <> "&top-level-decl=" <> funcName
+mkTestUri fp funcName = "daml://compiler?file=" <> (uriPath fp) <> "&top-level-decl=" <> funcName
 
 runTestLspSession
   :: FilePath
@@ -182,6 +201,9 @@ runTestLspSession cwd filepath verbose testNames = do
                     ]
   pure $ fmap (mconcat . fmap (\(TestResponse name result) -> Map.singleton name $ getTracesAndErrors result)) testResults
 
+uriPath :: String -> Text
+uriPath = T.replace "/" "%2F" . T.pack
+
 tShow :: Show a => a -> Text
 tShow = T.pack . show
 
@@ -270,11 +292,12 @@ damlIde logHandler cwd verbose rpcEvent = do
     damlProc = setCwd cwd $ Proc.proc damlPath ["ide", "--debug", "--scenarios", "yes"]
     sendPipe = fmap (SendPipe_Message . T.encodeUtf8 . makeReq . wrapRequest) rpcEvent
     logDebug' = flip runLoggingT logHandler . logDebug . T.decodeUtf8
+    logWarning' = flip runLoggingT logHandler . logWarning . T.decodeUtf8
 
   process <- createProcess damlProc (ProcessConfig sendPipe never)
   when verbose $ do
     performEvent_ $ ffor (_process_stdout process) $ liftIO . logDebug'
-    performEvent_ $ ffor (_process_stderr process) $ liftIO . logDebug'
+    performEvent_ $ ffor (_process_stderr process) $ liftIO . logWarning'
 
   let
     errorOutput = T.decodeUtf8 <$> _process_stderr process
@@ -389,3 +412,114 @@ mkInitPayload pid =
         }
       |]
     pidStr = tShow pid
+
+_test :: FilePath -> Log IO ()
+_test p = do
+  handler <- askLogHandler
+  let
+    log :: MonadIO m' =>  Text -> m' ()
+    log = liftIO . flip runLoggingT handler . logDebug
+  cwd <- liftIO $ canonicalizePath p
+  liftIO $ runHeadlessApp $ do
+    rec
+      LspClient init rsp shutdown <- lsp $ LspClientConfig
+        { _lspClientConfig_log = log
+        , _lspClientConfig_workingDirectory = cwd
+        , _lspClientConfig_serverCommand =
+            Proc.RawCommand damlPath ["ide", "--debug", "--scenarios", "yes"]
+        , _lspClientConfig_handler = handleDamlLsp
+        , _lspClientConfig_requests = leftmost
+          [ ffor init $ \_ -> Right
+            [ Some $ DamlLsp_Lsp $ Lsp_Doc $ OpenDoc "daml/Main.daml" "daml"
+            , Some $ DamlLsp_Lsp $ Lsp_Diagnostics $ WaitForDiagnostics
+            , Some $ DamlLsp_OpenScenario "daml/Main.daml" "setup"
+            , Some $ DamlLsp_WaitForScenarioDidChange
+            ]
+          , fforMaybe rsp $ \case
+              (DamlLsp_WaitForScenarioDidChange :=> _) -> Just (Left ())
+              _ -> Nothing
+          ]
+        }
+    performEvent_ $ ffor rsp $ \(k :=> v) -> log . T.pack $ has @Show k $ show v
+    pure shutdown
+
+data DamlLsp a where
+  DamlLsp_Lsp
+    :: Lsp a -> DamlLsp a
+  DamlLsp_OpenScenario
+    :: FilePath -> String -> DamlLsp TextDocumentIdentifier
+  DamlLsp_WaitForScenarioDidChange
+    :: DamlLsp (Either VirtualResourceNoteSetParams VirtualResourceChangedParams)
+
+handleDamlLsp :: Some DamlLsp -> Session (DSum DamlLsp Identity)
+handleDamlLsp (Some req) = case req of
+  DamlLsp_Lsp a -> do
+    (k :=> v) <- handleLsp (Some a)
+    pure $ DamlLsp_Lsp k :=> v
+  DamlLsp_OpenScenario fp str -> (req :=>) . Identity <$> openScenario fp str
+  DamlLsp_WaitForScenarioDidChange -> (req :=>) . Identity <$> waitForScenarioChangeOrNote
+
+scenarioUri :: FilePath -> String -> Session Uri
+scenarioUri fp name = do
+    Just fp' <- uriToFilePath <$> getDocUri fp
+    pure $ Uri $ T.pack $
+        "daml://compiler?file=" <> escapeURIString isUnescapedInURIComponent fp' <>
+        "&top-level-decl=" <> name
+
+openScenario :: FilePath -> String -> Session TextDocumentIdentifier
+openScenario fp name = do
+    uri <- scenarioUri fp name
+    sendNotification LSP.SMethod_TextDocumentDidOpen (DidOpenTextDocumentParams $ TextDocumentItem uri (T.pack "daml") 0 "")
+    pure $ TextDocumentIdentifier uri
+
+-- | Parameters for the virtual resource changed notification
+data VirtualResourceChangedParams = VirtualResourceChangedParams
+    { _vrcpUri      :: !T.Text
+      -- ^ The uri of the virtual resource.
+    , _vrcpContents :: !T.Text
+      -- ^ The new contents of the virtual resource.
+    } deriving Show
+
+instance ToJSON VirtualResourceChangedParams where
+    toJSON (VirtualResourceChangedParams uri contents) =
+        object ["uri" .= uri, "contents" .= contents]
+
+instance FromJSON VirtualResourceChangedParams where
+  parseJSON = withObject "VirtualResourceChangedParams" $ \o ->
+      VirtualResourceChangedParams <$> o .: "uri" <*> o .: "contents"
+
+waitForScenarioChangeOrNote :: Session (Either VirtualResourceNoteSetParams VirtualResourceChangedParams)
+waitForScenarioChangeOrNote = do
+  skipManyTill anyMessage $ waitForScenarioDidChange <|> waitForVirtualResourceNote
+  where
+    waitForScenarioDidChange = do
+      LSP.NotMess scenario <- customNotification $ Proxy @"daml/virtualResource/didChange"
+      guard $ Lens.has (L.params . key "contents") scenario
+      case fromJSON $ scenario ^. LSP.params of
+          Success p -> pure $ Right p
+          Data.Aeson.Types.Error s -> fail $ "Failed to parse daml/virtualResource/didChange params: " <> s
+    waitForVirtualResourceNote = do
+      LSP.NotMess note' <- skipManyTill anyMessage $
+        customNotification $ Proxy @"daml/virtualResource/note"
+      guard $ Lens.has (L.params . key "note") note'
+      case fromJSON $ note' ^. LSP.params of
+          Success p -> pure $ Left p
+          Data.Aeson.Types.Error s -> fail $ "Failed to parse daml/virtualResource/note params: " <> s
+
+-- | Parameters for the virtual resource changed notification
+data VirtualResourceNoteSetParams = VirtualResourceNoteSetParams
+    { _vrcpNoteUri      :: !T.Text
+      -- ^ The uri of the virtual resource.
+    , _vrcpNoteContent :: !T.Text
+      -- ^ The new contents of the virtual resource.
+    } deriving Show
+
+instance ToJSON VirtualResourceNoteSetParams where
+    toJSON (VirtualResourceNoteSetParams uri note) =
+        object ["uri" .= uri, "note" .= note]
+
+instance FromJSON VirtualResourceNoteSetParams where
+    parseJSON = withObject "VirtualResourceNoteSetParams" $ \o ->
+        VirtualResourceNoteSetParams <$> o .: "uri" <*> o .: "note"
+
+deriveArgDict ''DamlLsp