Merge pull request #165 from rzk-lang/refactor/handlers

Move inline handlers to the dedicated module
rzk-lang · Dec 20, 2023 · e4700d2 · e4700d2
2 parents 8c6bdfd + dfe219d
commit e4700d2
Show file tree

Hide file tree

Showing 2 changed files with 88 additions and 92 deletions.
diff --git a/rzk/src/Language/Rzk/VSCode/Handlers.hs b/rzk/src/Language/Rzk/VSCode/Handlers.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
@@ -8,14 +9,19 @@ module Language.Rzk.VSCode.Handlers (
   typecheckFromConfigFile,
   provideCompletions,
   formatDocument,
+  provideSemanticTokens,
+  handleFilesChanged,
 ) where
 
 import           Control.Exception             (SomeException, evaluate, try)
 import           Control.Lens
 import           Control.Monad                 (forM_, when)
+import           Control.Monad.Except          (ExceptT (ExceptT),
+                                                MonadError (throwError),
+                                                modifyError, runExceptT)
 import           Control.Monad.IO.Class        (MonadIO (..))
 import           Data.Default.Class
-import           Data.List                     (sort, (\\))
+import           Data.List                     (isSuffixOf, sort, (\\))
 import           Data.Maybe                    (fromMaybe, isNothing)
 import qualified Data.Text                     as T
 import qualified Data.Yaml                     as Yaml
@@ -25,7 +31,7 @@ import           Language.LSP.Protocol.Lens    (HasDetail (detail),
                                                 HasLabel (label),
                                                 HasParams (params),
                                                 HasTextDocument (textDocument),
-                                                HasUri (uri))
+                                                HasUri (uri), changes, uri)
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
 import           Language.LSP.Server
@@ -36,10 +42,12 @@ import           System.FilePath.Glob          (compile, globDir)
 import           Language.Rzk.Free.Syntax      (RzkPosition (RzkPosition),
                                                 VarIdent (getVarIdent))
 import           Language.Rzk.Syntax           (Module, VarIdent' (VarIdent),
-                                                parseModuleFile, printTree)
+                                                parseModuleFile,
+                                                parseModuleSafe, printTree)
 import           Language.Rzk.VSCode.Config    (ServerConfig (ServerConfig, formatEnabled))
 import           Language.Rzk.VSCode.Env
 import           Language.Rzk.VSCode.Logging
+import           Language.Rzk.VSCode.Tokenize  (tokenizeModule)
 import           Rzk.Format                    (FormattingEdit (..),
                                                 formatTextEdits)
 import           Rzk.Project.Config            (ProjectConfig (include))
@@ -249,3 +257,78 @@ formatDocument req res = do
   else do
     logDebug "Formatting is disabled in config"
     res $ Right $ InR Null
+
+provideSemanticTokens :: Handler LSP 'Method_TextDocumentSemanticTokensFull
+provideSemanticTokens req responder = do
+  let doc = req ^. params . textDocument . uri . to toNormalizedUri
+  mdoc <- getVirtualFile doc
+  possibleTokens <- case virtualFileText <$> mdoc of
+    Nothing         -> return (Left "Failed to get file content")
+    Just sourceCode -> fmap (fmap tokenizeModule) $ liftIO $
+      parseModuleSafe (filter (/= '\r') $ T.unpack sourceCode)
+  case possibleTokens of
+    Left err -> do
+      -- Exception occurred when parsing the module
+      logWarning ("Failed to tokenize file: " ++ err)
+    Right tokens -> do
+      let encoded = encodeTokens defaultSemanticTokensLegend $ relativizeTokens tokens
+      case encoded of
+        Left _err -> do
+          -- Failed to encode the tokens
+          return ()
+        Right list ->
+          responder (Right (InL (SemanticTokens Nothing list)))
+
+
+data IsChanged
+  = HasChanged
+  | NotChanged
+
+-- | Detects if the given path has changes in its declaration compared to what's in the cache
+isChanged :: RzkTypecheckCache -> FilePath -> LSP IsChanged
+isChanged cache path = toIsChanged $ do
+  cachedDecls <- maybeToEitherLSP $ lookup path cache
+  module' <- toExceptTLifted $ parseModuleFile path
+  e <- toExceptTLifted $ try @SomeException $ evaluate $
+    defaultTypeCheck (typecheckModulesWithLocationIncremental (takeWhile ((/= path) . fst) cache) [(path, module')])
+  (checkedModules, _errors) <- toExceptT $ return e
+  decls' <- maybeToEitherLSP $ lookup path checkedModules
+  return $ if decls' == cachedDecls
+    then NotChanged
+    else HasChanged
+  where
+    toExceptT = modifyError (const ()) . ExceptT
+    toExceptTLifted = toExceptT . liftIO
+    maybeToEitherLSP = \case
+      Nothing -> throwError ()
+      Just x -> return x
+    toIsChanged m = runExceptT m >>= \case
+      Left _ -> return HasChanged -- in case of error consider the file has changed
+      Right x -> return x
+
+hasNotChanged :: RzkTypecheckCache -> FilePath -> LSP Bool
+hasNotChanged cache path = isChanged cache path >>= \case
+  HasChanged -> return False
+  NotChanged -> return True
+
+-- | Monadic 'dropWhile'
+dropWhileM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
+dropWhileM _ []     = return []
+dropWhileM p (x:xs) = do
+  q <- p x
+  if q
+    then dropWhileM p xs
+    else return (x:xs)
+
+handleFilesChanged :: Handler LSP 'Method_WorkspaceDidChangeWatchedFiles
+handleFilesChanged msg = do
+  let modifiedPaths = msg ^.. params . changes . traverse . uri . to uriToFilePath . _Just
+  if any ("rzk.yaml" `isSuffixOf`) modifiedPaths
+    then do
+      logDebug "rzk.yaml modified. Clearing module cache"
+      resetCacheForAllFiles
+    else do
+      cache <- getCachedTypecheckedModules
+      actualModified <- dropWhileM (hasNotChanged cache) modifiedPaths
+      resetCacheForFiles actualModified
+  typecheckFromConfigFile
diff --git a/rzk/src/Language/Rzk/VSCode/Lsp.hs b/rzk/src/Language/Rzk/VSCode/Lsp.hs
@@ -1,105 +1,36 @@
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE TypeApplications      #-}
 
 module Language.Rzk.VSCode.Lsp where
 
-import           Control.Lens                  (_Just, to, (^.), (^..))
 import           Control.Monad.IO.Class
 import           Control.Monad.Reader
 import           Data.Default.Class            (Default (def))
-import           Data.List                     (isSuffixOf)
 import qualified Data.Text                     as T
-import           Language.LSP.Protocol.Lens    (HasParams (params),
-                                                HasTextDocument (textDocument),
-                                                HasUri (uri), changes, uri)
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
 import           Language.LSP.Server
-import           Language.LSP.VFS              (virtualFileText)
 
-import           Control.Exception             (SomeException, evaluate, try)
-import           Control.Monad.Except          (ExceptT (ExceptT),
-                                                MonadError (throwError),
-                                                modifyError, runExceptT)
 import           Data.Aeson                    (Result (Error, Success),
                                                 fromJSON)
-import           Language.Rzk.Syntax           (parseModuleFile,
-                                                parseModuleSafe)
 import           Language.Rzk.VSCode.Config    (ServerConfig (..))
 import           Language.Rzk.VSCode.Env
 import           Language.Rzk.VSCode.Handlers
-import           Language.Rzk.VSCode.Logging
-import           Language.Rzk.VSCode.Tokenize  (tokenizeModule)
-import           Rzk.TypeCheck                 (defaultTypeCheck,
-                                                typecheckModulesWithLocationIncremental)
 
 -- | The maximum number of diagnostic messages to send to the client
 maxDiagnosticCount :: Int
 maxDiagnosticCount = 100
 
-data IsChanged
-  = HasChanged
-  | NotChanged
-
--- | Detects if the given path has changes in its declaration compared to what's in the cache
-isChanged :: RzkTypecheckCache -> FilePath -> LSP IsChanged
-isChanged cache path = toIsChanged $ do
-  cachedDecls <- maybeToEitherLSP $ lookup path cache
-  module' <- toExceptTLifted $ parseModuleFile path
-  e <- toExceptTLifted $ try @SomeException $ evaluate $
-    defaultTypeCheck (typecheckModulesWithLocationIncremental (takeWhile ((/= path) . fst) cache) [(path, module')])
-  (checkedModules, _errors) <- toExceptT $ return e
-  decls' <- maybeToEitherLSP $ lookup path checkedModules
-  return $ if decls' == cachedDecls
-    then NotChanged
-    else HasChanged
-  where
-    toExceptT = modifyError (const ()) . ExceptT
-    toExceptTLifted = toExceptT . liftIO
-    maybeToEitherLSP = \case
-      Nothing -> throwError ()
-      Just x -> return x
-    toIsChanged m = runExceptT m >>= \case
-      Left _ -> return HasChanged -- in case of error consider the file has changed
-      Right x -> return x
-
-hasNotChanged :: RzkTypecheckCache -> FilePath -> LSP Bool
-hasNotChanged cache path = isChanged cache path >>= \case
-  HasChanged -> return False
-  NotChanged -> return True
-
--- | Monadic 'dropWhile'
-dropWhileM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
-dropWhileM _ []     = return []
-dropWhileM p (x:xs) = do
-  q <- p x
-  if q
-    then dropWhileM p xs
-    else return (x:xs)
-
 handlers :: Handlers LSP
 handlers =
   mconcat
     [ notificationHandler SMethod_Initialized $ const typecheckFromConfigFile
     -- TODO: add logging
     -- Empty handlers to silence the errors
     , notificationHandler SMethod_TextDocumentDidOpen $ \_msg -> pure ()
-    -- , requestHandler SMethod_TextDocumentFormatting $ \_req _res -> pure ()
     , notificationHandler SMethod_TextDocumentDidChange $ \_msg -> pure ()
     , notificationHandler SMethod_TextDocumentDidClose $ \_msg -> pure ()
-    , notificationHandler SMethod_WorkspaceDidChangeWatchedFiles $ \msg -> do
-        let modifiedPaths = msg ^.. params . changes . traverse . uri . to uriToFilePath . _Just
-        if any ("rzk.yaml" `isSuffixOf`) modifiedPaths
-          then do
-            logDebug "rzk.yaml modified. Clearing module cache"
-            resetCacheForAllFiles
-          else do
-            cache <- getCachedTypecheckedModules
-            actualModified <- dropWhileM (hasNotChanged cache) modifiedPaths
-            resetCacheForFiles actualModified
-        typecheckFromConfigFile
+    , notificationHandler SMethod_WorkspaceDidChangeWatchedFiles handleFilesChanged
     , notificationHandler SMethod_TextDocumentDidSave $ \_msg -> do
         -- TODO: check if the file is included in the config's `include` list.
         --       If not (and not in `exclude`) either, issue a warning.
@@ -115,25 +46,7 @@ handlers =
     --         range' = Range pos pos
     --     responder (Right $ InL rsp)
     , requestHandler SMethod_TextDocumentCompletion provideCompletions
-    , requestHandler SMethod_TextDocumentSemanticTokensFull $ \req responder -> do
-        let doc = req ^. params . textDocument . uri . to toNormalizedUri
-        mdoc <- getVirtualFile doc
-        possibleTokens <- case virtualFileText <$> mdoc of
-              Nothing         -> return (Left "Failed to get file content")
-              Just sourceCode -> fmap (fmap tokenizeModule) $ liftIO $
-                parseModuleSafe (filter (/= '\r') $ T.unpack sourceCode)
-        case possibleTokens of
-          Left err -> do
-            -- Exception occurred when parsing the module
-            logWarning ("Failed to tokenize file: " ++ err)
-          Right tokens -> do
-            let encoded = encodeTokens defaultSemanticTokensLegend $ relativizeTokens tokens
-            case encoded of
-              Left _err -> do
-                -- Failed to encode the tokens
-                return ()
-              Right list ->
-                responder (Right (InL SemanticTokens { _resultId = Nothing, _data_ = list }))
+    , requestHandler SMethod_TextDocumentSemanticTokensFull provideSemanticTokens
     , requestHandler SMethod_TextDocumentFormatting formatDocument
     ]