From 8ade8536a0cd9202093a6b3c387af77e64978fd0 Mon Sep 17 00:00:00 2001 From: fwcd Date: Sat, 4 Sep 2021 17:57:38 +0200 Subject: [PATCH 1/3] Add empty semantic tokens handler --- src/Curry/LanguageServer/Handlers.hs | 2 ++ .../LanguageServer/Handlers/SemanticTokens.hs | 19 +++++++++++++++++++ 2 files changed, 21 insertions(+) create mode 100644 src/Curry/LanguageServer/Handlers/SemanticTokens.hs diff --git a/src/Curry/LanguageServer/Handlers.hs b/src/Curry/LanguageServer/Handlers.hs index 0047824..7cdfffd 100644 --- a/src/Curry/LanguageServer/Handlers.hs +++ b/src/Curry/LanguageServer/Handlers.hs @@ -8,6 +8,7 @@ import Curry.LanguageServer.Handlers.Definition (definitionHandler) import Curry.LanguageServer.Handlers.DocumentSymbols (documentSymbolHandler) import Curry.LanguageServer.Handlers.Hover (hoverHandler) import Curry.LanguageServer.Handlers.Initialized (initializedHandler) +import Curry.LanguageServer.Handlers.SemanticTokens (semanticTokensHandler) import Curry.LanguageServer.Handlers.SignatureHelp (signatureHelpHandler) import Curry.LanguageServer.Handlers.TextDocument (didOpenHandler, didChangeHandler, didSaveHandler, didCloseHandler) import Curry.LanguageServer.Handlers.WorkspaceSymbols (workspaceSymbolHandler) @@ -26,6 +27,7 @@ handlers = mconcat , codeActionHandler , codeLensHandler , signatureHelpHandler + , semanticTokensHandler -- Notification handlers , initializedHandler , didOpenHandler diff --git a/src/Curry/LanguageServer/Handlers/SemanticTokens.hs b/src/Curry/LanguageServer/Handlers/SemanticTokens.hs new file mode 100644 index 0000000..a9c7f36 --- /dev/null +++ b/src/Curry/LanguageServer/Handlers/SemanticTokens.hs @@ -0,0 +1,19 @@ +module Curry.LanguageServer.Handlers.SemanticTokens (semanticTokensHandler) where + +import Control.Lens ((^.)) +import Control.Monad.IO.Class (liftIO) +import Curry.LanguageServer.Monad +import Curry.LanguageServer.Utils.Uri (normalizeUriWithPath) +import qualified Language.LSP.Server as S +import qualified Language.LSP.Types as J +import qualified Language.LSP.Types.Lens as J +import System.Log.Logger + +semanticTokensHandler :: S.Handlers LSM +semanticTokensHandler = S.requestHandler J.STextDocumentSemanticTokensFull $ \req responder -> do + liftIO $ debugM "cls.semanticTokens" "Processing semantic tokens request" + let doc = req ^. J.params . J.textDocument + uri = doc ^. J.uri + normUri <- liftIO $ normalizeUriWithPath uri + store <- getStore + responder $ Right $ Just $ J.SemanticTokens Nothing $ J.List [] From 30376d612f3ac7d395f05485b18d1b57d50b187f Mon Sep 17 00:00:00 2001 From: fwcd Date: Sat, 4 Sep 2021 19:01:03 +0200 Subject: [PATCH 2/3] Add HasSemanticTokens and instances for identifiers --- .../LanguageServer/Handlers/SemanticTokens.hs | 7 + src/Curry/LanguageServer/Utils/Convert.hs | 187 +++++++++++++++++- 2 files changed, 190 insertions(+), 4 deletions(-) diff --git a/src/Curry/LanguageServer/Handlers/SemanticTokens.hs b/src/Curry/LanguageServer/Handlers/SemanticTokens.hs index a9c7f36..7006bf6 100644 --- a/src/Curry/LanguageServer/Handlers/SemanticTokens.hs +++ b/src/Curry/LanguageServer/Handlers/SemanticTokens.hs @@ -3,7 +3,9 @@ module Curry.LanguageServer.Handlers.SemanticTokens (semanticTokensHandler) wher import Control.Lens ((^.)) import Control.Monad.IO.Class (liftIO) import Curry.LanguageServer.Monad +import qualified Curry.LanguageServer.Index.Store as I import Curry.LanguageServer.Utils.Uri (normalizeUriWithPath) +import Data.Maybe (fromMaybe) import qualified Language.LSP.Server as S import qualified Language.LSP.Types as J import qualified Language.LSP.Types.Lens as J @@ -17,3 +19,8 @@ semanticTokensHandler = S.requestHandler J.STextDocumentSemanticTokensFull $ \re normUri <- liftIO $ normalizeUriWithPath uri store <- getStore responder $ Right $ Just $ J.SemanticTokens Nothing $ J.List [] + +fetchSemanticTokens :: I.ModuleStoreEntry -> [J.SemanticTokenAbsolute] +fetchSemanticTokens entry = fromMaybe [] $ do + ast <- I.mseModuleAST entry + return [] diff --git a/src/Curry/LanguageServer/Utils/Convert.hs b/src/Curry/LanguageServer/Utils/Convert.hs index 6bf91bd..11f1fbb 100644 --- a/src/Curry/LanguageServer/Utils/Convert.hs +++ b/src/Curry/LanguageServer/Utils/Convert.hs @@ -27,6 +27,7 @@ module Curry.LanguageServer.Utils.Convert , ppPredTypeToText , HasDocumentSymbols (..) , HasWorkspaceSymbols (..) + , HasSemanticTokens (..) ) where -- Curry Compiler Libraries + Dependencies @@ -41,11 +42,12 @@ import qualified Base.CurryTypes as CCT import qualified Base.Types as CT import qualified Text.PrettyPrint as PP +import Control.Monad (guard) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Maybe (MaybeT(runMaybeT)) import Curry.LanguageServer.Utils.General import Curry.LanguageServer.Utils.Uri (filePathToUri, uriToFilePath) -import Data.Maybe (fromMaybe, listToMaybe) +import Data.Maybe (fromMaybe, listToMaybe, maybeToList) import qualified Data.Text as T import qualified Language.LSP.Types as J @@ -206,8 +208,8 @@ instance HasDocumentSymbols (CS.Decl a) where symKind = J.SkOperator CS.DataDecl _ ident _ cs _ -> [makeDocumentSymbol name symKind range $ Just childs] where name = ppToText ident - symKind = if length cs > 1 then J.SkEnum - else J.SkStruct + symKind = if length cs /= 1 then J.SkEnum + else J.SkStruct childs = documentSymbols =<< cs CS.NewtypeDecl _ ident _ c _ -> [makeDocumentSymbol name symKind range $ Just childs] where name = ppToText ident @@ -215,7 +217,7 @@ instance HasDocumentSymbols (CS.Decl a) where childs = documentSymbols c CS.ExternalDataDecl _ ident _ -> [makeDocumentSymbol name symKind range Nothing] where name = ppToText ident - symKind = J.SkStruct + symKind = J.SkEnum CS.FunctionDecl _ _ ident eqs -> [makeDocumentSymbol name symKind range $ Just childs] where name = ppToText ident symKind = if eqsArity eqs > 0 then J.SkFunction @@ -327,6 +329,183 @@ instance (HasDocumentSymbols s, CSPI.HasSpanInfo s) => HasWorkspaceSymbols s whe cis = documentSymbolToInformations =<< cs' return $ documentSymbolToInformations =<< documentSymbols s +makeSemanticToken :: J.SemanticTokenTypes -> [J.SemanticTokenModifiers] -> Maybe J.Range -> [J.SemanticTokenAbsolute] +makeSemanticToken tt tm r = maybeToList $ do + J.Range (J.Position l c) (J.Position l' c') <- r + guard $ l == l' + return $ J.SemanticTokenAbsolute l c (c' - c) tt tm + +curryIdent2Token :: J.SemanticTokenTypes -> [J.SemanticTokenModifiers] -> CI.Ident -> [J.SemanticTokenAbsolute] +curryIdent2Token tt tm = makeSemanticToken tt tm . currySpanInfo2Range + +class HasSemanticTokens e where + semanticTokens :: e -> [J.SemanticTokenAbsolute] + +instance HasSemanticTokens (CS.Module a) where + semanticTokens (CS.Module _ _ _ _ _ imps decls) = semanticTokens imps ++ semanticTokens decls + +instance HasSemanticTokens CS.ImportDecl where + semanticTokens (CS.ImportDecl _ _ _ _ spec) = semanticTokens spec + +instance HasSemanticTokens CS.ImportSpec where + semanticTokens spec = case spec of + CS.Importing _ is -> semanticTokens is + CS.Hiding _ is -> semanticTokens is + +instance HasSemanticTokens CS.Import where + semanticTokens imp = case imp of + CS.Import _ _ -> [] + CS.ImportTypeWith _ i is -> curryIdent2Token J.SttType [] i + ++ (curryIdent2Token J.SttFunction [] =<< is) + CS.ImportTypeAll _ i -> curryIdent2Token J.SttType [] i + +instance HasSemanticTokens (CS.Decl a) where + semanticTokens decl = case decl of + CS.InfixDecl _ _ _ is -> curryIdent2Token J.SttOperator [J.StmDeclaration] =<< is + CS.DataDecl _ i is cdecls _ -> curryIdent2Token tt [J.StmDeclaration] i + ++ (curryIdent2Token J.SttTypeParameter [J.StmDeclaration] =<< is) + ++ semanticTokens cdecls + where tt | length cdecls == 1 = J.SttStruct + | otherwise = J.SttEnum + CS.ExternalDataDecl _ i is -> curryIdent2Token J.SttEnum [J.StmDeclaration] i + ++ (curryIdent2Token J.SttTypeParameter [J.StmDeclaration] =<< is) + CS.NewtypeDecl _ i is cdecl _ -> curryIdent2Token J.SttStruct [J.StmDeclaration] i + ++ (curryIdent2Token J.SttTypeParameter [J.StmDeclaration] =<< is) + ++ semanticTokens cdecl + CS.TypeDecl _ i is t -> curryIdent2Token J.SttInterface [J.StmDeclaration] i + ++ (curryIdent2Token J.SttTypeParameter [J.StmDeclaration] =<< is) + ++ semanticTokens t + CS.TypeSig _ is t -> (curryIdent2Token J.SttFunction [J.StmDeclaration] =<< is) + ++ semanticTokens t + CS.FunctionDecl _ _ i es -> curryIdent2Token J.SttFunction [J.StmDeclaration] i + ++ semanticTokens es + CS.ExternalDecl _ vs -> semanticTokens vs + CS.PatternDecl _ p rhs -> semanticTokens p ++ semanticTokens rhs + CS.FreeDecl _ vs -> semanticTokens vs + CS.DefaultDecl _ ts -> semanticTokens ts + CS.ClassDecl _ _ c i1 i2 ds -> semanticTokens c + ++ curryIdent2Token J.SttInterface [J.StmDeclaration] i1 + ++ curryIdent2Token J.SttTypeParameter [J.StmDeclaration] i2 + ++ semanticTokens ds + CS.InstanceDecl _ _ c _ _ ds -> semanticTokens c ++ semanticTokens ds + +instance HasSemanticTokens CS.Constraint where + semanticTokens (CS.Constraint _ _ t) = semanticTokens t + +instance HasSemanticTokens (CS.Equation a) where + semanticTokens (CS.Equation _ lhs rhs) = semanticTokens lhs ++ semanticTokens rhs + +instance HasSemanticTokens (CS.Pattern a) where + semanticTokens pat = case pat of + CS.VariablePattern _ _ i -> curryIdent2Token J.SttVariable [J.StmDeclaration] i + CS.ConstructorPattern _ _ _ ps -> semanticTokens ps + CS.InfixPattern _ _ p1 _ p2 -> semanticTokens p1 ++ semanticTokens p2 + CS.ParenPattern _ p -> semanticTokens p + CS.RecordPattern _ _ _ fs -> semanticTokens fs + CS.TuplePattern _ ps -> semanticTokens ps + CS.ListPattern _ _ ps -> semanticTokens ps + CS.AsPattern _ i p -> curryIdent2Token J.SttVariable [J.StmDeclaration] i + ++ semanticTokens p + CS.LazyPattern _ p -> semanticTokens p + CS.FunctionPattern _ _ _ ps -> semanticTokens ps + CS.InfixFuncPattern _ _ p1 _ p2 -> semanticTokens p1 ++ semanticTokens p2 + _ -> [] + +instance HasSemanticTokens (CS.Statement a) where + semanticTokens stmt = case stmt of + CS.StmtExpr _ e -> semanticTokens e + CS.StmtDecl _ _ ds -> semanticTokens ds + CS.StmtBind _ p e -> semanticTokens p ++ semanticTokens e + +instance HasSemanticTokens (CS.Lhs a) where + semanticTokens lhs = case lhs of + CS.FunLhs _ _ ps -> semanticTokens ps + CS.OpLhs _ p1 _ p2 -> semanticTokens p1 ++ semanticTokens p2 + CS.ApLhs _ l ps -> semanticTokens l ++ semanticTokens ps + +instance HasSemanticTokens (CS.Rhs a) where + semanticTokens rhs = case rhs of + CS.SimpleRhs _ _ e ds -> semanticTokens e ++ semanticTokens ds + CS.GuardedRhs _ _ es ds -> semanticTokens es ++ semanticTokens ds + +instance HasSemanticTokens (CS.CondExpr a) where + semanticTokens (CS.CondExpr _ e1 e2) = semanticTokens e1 ++ semanticTokens e2 + +instance HasSemanticTokens (CS.Expression a) where + semanticTokens e = case e of + CS.Paren _ e' -> semanticTokens e' + CS.Typed _ e' _ -> semanticTokens e' + CS.Record _ _ _ fields -> semanticTokens fields + CS.RecordUpdate _ e' fields -> semanticTokens e' ++ semanticTokens fields + CS.Tuple _ entries -> semanticTokens entries + CS.List _ _ entries -> semanticTokens entries + CS.ListCompr _ e' stmts -> semanticTokens e' ++ semanticTokens stmts + CS.EnumFrom _ e' -> semanticTokens e' + CS.EnumFromThen _ e1 e2 -> semanticTokens e1 ++ semanticTokens e2 + CS.EnumFromThenTo _ e1 e2 e3 -> semanticTokens e1 ++ semanticTokens e2 ++ semanticTokens e3 + CS.UnaryMinus _ e' -> semanticTokens e' + CS.Apply _ e1 e2 -> semanticTokens e1 ++ semanticTokens e2 + CS.InfixApply _ e1 _ e2 -> semanticTokens e1 ++ semanticTokens e2 + CS.LeftSection _ e' _ -> semanticTokens e' + CS.RightSection _ _ e' -> semanticTokens e' + CS.Lambda _ _ e' -> semanticTokens e' + CS.Let _ _ decls e' -> semanticTokens decls ++ semanticTokens e' + CS.Do _ _ stmts e' -> semanticTokens stmts ++ semanticTokens e' + CS.IfThenElse _ e1 e2 e3 -> semanticTokens e1 ++ semanticTokens e2 ++ semanticTokens e3 + CS.Case _ _ _ e' alts -> semanticTokens e' ++ semanticTokens alts + _ -> [] + +instance HasSemanticTokens (CS.Alt a) where + semanticTokens (CS.Alt _ p rhs) = semanticTokens p ++ semanticTokens rhs + +instance HasSemanticTokens a => HasSemanticTokens (CS.Field a) where + semanticTokens (CS.Field _ _ e) = semanticTokens e + +instance HasSemanticTokens (CS.Var a) where + semanticTokens (CS.Var _ i) = curryIdent2Token J.SttVariable [] i + +instance HasSemanticTokens CS.ConstrDecl where + semanticTokens cdecl = case cdecl of + CS.ConstrDecl _ i ts -> curryIdent2Token J.SttFunction [J.StmDeclaration] i + ++ semanticTokens ts + CS.ConOpDecl _ t1 i t2 -> curryIdent2Token J.SttOperator [J.StmDeclaration] i + ++ semanticTokens t1 + ++ semanticTokens t2 + CS.RecordDecl _ i fs -> curryIdent2Token J.SttFunction [J.StmDeclaration] i + ++ semanticTokens fs + +instance HasSemanticTokens CS.FieldDecl where + semanticTokens (CS.FieldDecl _ _ t) = semanticTokens t + +instance HasSemanticTokens CS.NewConstrDecl where + semanticTokens cdecl = case cdecl of + CS.NewConstrDecl _ i t -> curryIdent2Token J.SttFunction [J.StmDeclaration] i + ++ semanticTokens t + CS.NewRecordDecl _ i (i', t) -> curryIdent2Token J.SttFunction [J.StmDeclaration] i + ++ curryIdent2Token J.SttFunction [J.StmDeclaration] i' + ++ semanticTokens t + +instance HasSemanticTokens CS.TypeExpr where + semanticTokens texpr = case texpr of + CS.ApplyType _ t1 t2 -> semanticTokens t1 ++ semanticTokens t2 + CS.VariableType _ i -> curryIdent2Token J.SttTypeParameter [] i + CS.TupleType _ ts -> semanticTokens ts + CS.ListType _ t -> semanticTokens t + CS.ArrowType _ t1 t2 -> semanticTokens t1 ++ semanticTokens t2 + CS.ParenType _ t -> semanticTokens t + CS.ForallType _ is t -> (curryIdent2Token J.SttTypeParameter [J.StmDeclaration] =<< is) + ++ semanticTokens t + _ -> [] + +instance HasSemanticTokens CS.QualTypeExpr where + semanticTokens (CS.QualTypeExpr _ c t) = semanticTokens c ++ semanticTokens t + +instance HasSemanticTokens a => HasSemanticTokens [a] where + semanticTokens = (semanticTokens =<<) + +instance HasSemanticTokens a => HasSemanticTokens (Maybe a) where + semanticTokens = semanticTokens . maybeToList + -- Language Server Protocol -> Curry Compiler -- TODO From daf138f2dc28b2ec51f43286e11d2e422391d8f7 Mon Sep 17 00:00:00 2001 From: fwcd Date: Sat, 4 Sep 2021 19:07:25 +0200 Subject: [PATCH 3/3] Implement semantic tokens handler --- src/Curry/LanguageServer/Handlers/SemanticTokens.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Curry/LanguageServer/Handlers/SemanticTokens.hs b/src/Curry/LanguageServer/Handlers/SemanticTokens.hs index 7006bf6..86bc3ed 100644 --- a/src/Curry/LanguageServer/Handlers/SemanticTokens.hs +++ b/src/Curry/LanguageServer/Handlers/SemanticTokens.hs @@ -4,7 +4,9 @@ import Control.Lens ((^.)) import Control.Monad.IO.Class (liftIO) import Curry.LanguageServer.Monad import qualified Curry.LanguageServer.Index.Store as I +import Curry.LanguageServer.Utils.Convert (HasSemanticTokens (..)) import Curry.LanguageServer.Utils.Uri (normalizeUriWithPath) +import Data.Default (def) import Data.Maybe (fromMaybe) import qualified Language.LSP.Server as S import qualified Language.LSP.Types as J @@ -18,9 +20,12 @@ semanticTokensHandler = S.requestHandler J.STextDocumentSemanticTokensFull $ \re uri = doc ^. J.uri normUri <- liftIO $ normalizeUriWithPath uri store <- getStore - responder $ Right $ Just $ J.SemanticTokens Nothing $ J.List [] + let tokens = fromMaybe [] $ fetchSemanticTokens =<< I.storedModule normUri store + case J.makeSemanticTokens def tokens of + Left e -> responder $ Left $ J.ResponseError J.InternalError e Nothing + Right ts -> responder $ Right $ Just ts -fetchSemanticTokens :: I.ModuleStoreEntry -> [J.SemanticTokenAbsolute] -fetchSemanticTokens entry = fromMaybe [] $ do +fetchSemanticTokens :: I.ModuleStoreEntry -> Maybe [J.SemanticTokenAbsolute] +fetchSemanticTokens entry = do ast <- I.mseModuleAST entry - return [] + return $ semanticTokens ast