diff --git a/src/Curry/LanguageServer/Compiler.hs b/src/Curry/LanguageServer/Compiler.hs index e26ebfb..59dd974 100644 --- a/src/Curry/LanguageServer/Compiler.hs +++ b/src/Curry/LanguageServer/Compiler.hs @@ -4,7 +4,8 @@ module Curry.LanguageServer.Compiler ( FileLoader, compileCurryFileWithDeps, compilationToMaybe, - failedCompilation + failedCompilation, + parseCurryModule ) where -- Curry Compiler Libraries + Dependencies @@ -125,7 +126,7 @@ loadAndCheckCurryModule opts fl m fp = do return ce -- | Loads a single module. -loadCurryModule :: CO.Options -> CI.ModuleIdent -> String -> FilePath -> CYIO (CE.CompEnv (CS.Module())) +loadCurryModule :: CO.Options -> CI.ModuleIdent -> String -> FilePath -> CYIO (CE.CompEnv (CS.Module ())) loadCurryModule opts m src fp = do -- Parse the module (lex, ast) <- parseCurryModule opts m src fp diff --git a/src/Curry/LanguageServer/Features/Completion.hs b/src/Curry/LanguageServer/Features/Completion.hs index 99fb334..324392d 100644 --- a/src/Curry/LanguageServer/Features/Completion.hs +++ b/src/Curry/LanguageServer/Features/Completion.hs @@ -3,34 +3,92 @@ module Curry.LanguageServer.Features.Completion (fetchCompletions) where -- Curry Compiler Libraries + Dependencies import qualified Curry.Base.Ident as CI +import qualified Curry.Base.SpanInfo as CSPI +import Curry.Base.Monad (runCYIOIgnWarn) +import qualified Curry.Files.Filenames as CFN +import qualified Curry.Syntax as CS import qualified Base.TopEnv as CT import qualified Base.Types as CTY import qualified CompilerEnv as CE +import qualified CompilerOpts as CO import qualified Env.TypeConstructor as CETC import qualified Env.Value as CEV +import Control.Applicative (Alternative (..)) import Control.Lens ((^.)) -import Curry.LanguageServer.IndexStore (ModuleStoreEntry (..)) +import Curry.LanguageServer.Compiler (parseCurryModule) +import Curry.LanguageServer.IndexStore (storedModules, IndexStore, ModuleStoreEntry (..)) import Curry.LanguageServer.Logging import Curry.LanguageServer.Utils.Conversions (ppToText) -import Curry.LanguageServer.Utils.General (rmDupsOn) +import Curry.LanguageServer.Utils.General (rmDupsOn, wordAtPos, guarded) import Curry.LanguageServer.Utils.Env (valueInfoType, typeInfoKind) +import Curry.LanguageServer.Utils.Syntax (elementAt, elementsAt, elementContains, HasExpressions (..), HasDeclarations (..)) import qualified Data.Map as M -import Data.Maybe (maybeToList) +import Data.Maybe (maybeToList, isJust) import qualified Data.Text as T import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J -fetchCompletions :: ModuleStoreEntry -> T.Text -> J.Position -> IO [J.CompletionItem] -fetchCompletions entry query pos = do - -- TODO: Context-awareness (through nested envs?) - let env = maybeToList $ compilerEnv entry - valueCompletions = valueBindingToCompletion <$> ((CT.allBindings . CE.valueEnv) =<< env) - typeCompletions = typeBindingToCompletion <$> ((CT.allBindings . CE.tyConsEnv) =<< env) - keywordCompletions = keywordToCompletion <$> keywords - completions = rmDupsOn (^. J.label) $ filter (matchesQuery query) $ valueCompletions ++ typeCompletions ++ keywordCompletions - logs INFO $ "fetchCompletions: Found " ++ show (length completions) ++ " completions with query '" ++ show query ++ "'" +fetchCompletions :: IndexStore -> ModuleStoreEntry -> T.Text -> J.Position -> IO [J.CompletionItem] +fetchCompletions store entry content pos = do + let query = maybe "" id $ wordAtPos pos content + env = compilerEnv entry + ast = moduleAST entry + + -- Workaround: Re-parse AST since stored AST is not updated after errors + ast' <- case (\(CS.Module _ _ _ mid _ _ _) -> parseCurryModule CO.defaultOptions mid (T.unpack content) $ CFN.moduleNameToFile mid) <$> ast of + Just p -> do + out <- runCYIOIgnWarn p + return $ case out of + Right (_, m) -> Just m + _ -> Nothing + _ -> return Nothing + + let completions = maybe [] id + $ (takeIfNonEmpty $ expressionCompletions ast' pos) + <|> (takeIfNonEmpty $ importCompletions store ast' pos) + <|> (takeIfNonEmpty $ generalCompletions env ast' pos query) + + logs INFO $ "fetchCompletions: Found " ++ show (length completions) ++ " completions with query '" ++ show query return completions + where takeIfNonEmpty = guarded (not . null) + +expressionCompletions :: Maybe (CS.Module a) -> J.Position -> [J.CompletionItem] +expressionCompletions ast pos = do + expr <- maybeToList $ elementAt pos =<< (expressions <$> ast) + case expr of + -- TODO: Implement expression-specific completions + _ -> [] + +importCompletions :: IndexStore -> Maybe (CS.Module a) -> J.Position -> [J.CompletionItem] +importCompletions store ast pos = do + CS.Module _ _ _ _ _ is _ <- maybeToList ast + CS.ImportDecl _ mid _ _ _ <- maybeToList $ elementAt pos is + let mName = T.pack $ CI.moduleName mid + filter (\c -> mName `T.isPrefixOf` (c ^. J.label)) $ moduleCompletions store + +moduleCompletions :: IndexStore -> [J.CompletionItem] +moduleCompletions store = moduleToCompletion <$> ((maybeToList . moduleAST) =<< snd <$> storedModules store) + +generalCompletions :: Maybe CE.CompilerEnv -> Maybe (CS.Module a) -> J.Position -> T.Text -> [J.CompletionItem] +generalCompletions env ast pos query = rmDupsOn (^. J.label) $ filter (matchesQuery query) + $ valueCompletions env ++ localCompletions ast pos + ++ typeCompletions env + ++ keywordCompletions + +-- TODO: Re-implement localCompletions using NestEnvs and bindings + +localCompletions :: Maybe (CS.Module a) -> J.Position -> [J.CompletionItem] +localCompletions ast pos = declarationToCompletions =<< (elementsAt pos $ declarations =<< maybeToList ast) + +valueCompletions :: Maybe CE.CompilerEnv -> [J.CompletionItem] +valueCompletions env = valueBindingToCompletion <$> ((CT.allBindings . CE.valueEnv) =<< maybeToList env) + +typeCompletions :: Maybe CE.CompilerEnv -> [J.CompletionItem] +typeCompletions env = typeBindingToCompletion <$> ((CT.allBindings . CE.tyConsEnv) =<< maybeToList env) + +keywordCompletions :: [J.CompletionItem] +keywordCompletions = keywordToCompletion <$> keywords where keywords = ["case", "class", "data", "default", "deriving", "do", "else", "external", "fcase", "free", "if", "import", "in", "infix", "infixl", "infixr", "instance", "let", "module", "newtype", "of", "then", "type", "where", "as", "ccall", "forall", "hiding", "interface", "primitive", "qualified"] -- | Tests whether a completion item matches the user's query. @@ -41,6 +99,24 @@ matchesQuery query item = query `T.isPrefixOf` (item ^. J.label) completionFrom :: T.Text -> J.CompletionItemKind -> Maybe T.Text -> Maybe T.Text -> J.CompletionItem completionFrom label ciKind detail doc = J.CompletionItem label (Just ciKind) detail (J.CompletionDocString <$> doc) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing +-- | Converts a module to a completion item. +moduleToCompletion :: CS.Module a -> J.CompletionItem +moduleToCompletion (CS.Module _ _ _ mid _ _ _) = item + where name = T.pack $ CI.moduleName mid + ciKind = J.CiModule + detail = Nothing + doc = Nothing + item = completionFrom name ciKind detail doc + +-- | Converts a declaration to a completion item. +declarationToCompletions :: CS.Decl a -> [J.CompletionItem] +declarationToCompletions decl = (\n -> completionFrom n J.CiVariable Nothing Nothing) <$> names + where names = T.pack <$> CI.idName <$> case decl of + CS.FunctionDecl _ _ ident _ -> [ident] + CS.ExternalDecl _ vars -> (\(CS.Var _ ident) -> ident) <$> vars + CS.FreeDecl _ vars -> (\(CS.Var _ ident) -> ident) <$> vars + _ -> [] + -- TODO: Reimplement the following functions in terms of bindingToQualSymbols and a conversion from SymbolInformation to CompletionItem -- | Converts a Curry value binding to a completion item. diff --git a/src/Curry/LanguageServer/Features/Definition.hs b/src/Curry/LanguageServer/Features/Definition.hs index 80e9fe0..d004509 100644 --- a/src/Curry/LanguageServer/Features/Definition.hs +++ b/src/Curry/LanguageServer/Features/Definition.hs @@ -27,7 +27,7 @@ fetchDefinitions store entry pos = do definition :: IndexStore -> J.Position -> LM J.Location definition store pos = do - (qident, spi) <- findAtPos pos + (qident, spi) <- qualIdentAtPos pos qident' <- lift $ runMaybeT $ CT.origName <$> lookupValueInfo qident let ident = CI.qidIdent $ qident ident' = CI.qidIdent <$> qident' diff --git a/src/Curry/LanguageServer/Features/Hover.hs b/src/Curry/LanguageServer/Features/Hover.hs index a8a259c..1d013a0 100644 --- a/src/Curry/LanguageServer/Features/Hover.hs +++ b/src/Curry/LanguageServer/Features/Hover.hs @@ -29,7 +29,7 @@ fetchHover entry pos = runMaybeT $ do hoverAt :: J.Position -> LM J.Hover hoverAt pos = do - (ident, spi) <- findAtPos pos + (ident, spi) <- qualIdentAtPos pos valueInfo <- lookupValueInfo ident let msg = J.HoverContents $ J.markedUpContent "curry" $ ppToText (CT.origName valueInfo) <> " :: " <> ppToText (valueInfoType valueInfo) range = currySpanInfo2Range spi diff --git a/src/Curry/LanguageServer/Reactor.hs b/src/Curry/LanguageServer/Reactor.hs index 02c7607..2564e81 100644 --- a/src/Curry/LanguageServer/Reactor.hs +++ b/src/Curry/LanguageServer/Reactor.hs @@ -16,7 +16,7 @@ import Curry.LanguageServer.Features.DocumentSymbols import Curry.LanguageServer.Features.Hover import Curry.LanguageServer.Features.WorkspaceSymbols import Curry.LanguageServer.Logging -import Curry.LanguageServer.Utils.General (liftMaybe, slipr3, wordAtPos) +import Curry.LanguageServer.Utils.General (liftMaybe, slipr3) import Curry.LanguageServer.Utils.Uri (filePathToNormalizedUri, normalizeUriWithPath) import Data.Default import qualified Data.Map as M @@ -106,11 +106,11 @@ reactor lf rin = do pos = req ^. J.params . J.position normUri <- liftIO $ normalizeUriWithPath uri vfile <- liftIO $ Core.getVirtualFileFunc lf normUri + store <- get completions <- fmap (join . maybeToList) $ runMaybeT $ do entry <- I.getModule normUri vfile <- liftMaybe =<< (liftIO $ Core.getVirtualFileFunc lf normUri) - query <- liftMaybe $ wordAtPos pos $ VFS.virtualFileText vfile - liftIO $ fetchCompletions entry query pos + liftIO $ fetchCompletions store entry (VFS.virtualFileText vfile) pos let maxCompletions = 25 items = take maxCompletions completions incomplete = length completions > maxCompletions diff --git a/src/Curry/LanguageServer/Utils/Env.hs b/src/Curry/LanguageServer/Utils/Env.hs index 5a2aaa0..8923cfc 100644 --- a/src/Curry/LanguageServer/Utils/Env.hs +++ b/src/Curry/LanguageServer/Utils/Env.hs @@ -4,7 +4,7 @@ module Curry.LanguageServer.Utils.Env ( LookupEnv, LM, runLM, - findAtPos, + qualIdentAtPos, valueInfoType, typeInfoKind ) where @@ -12,6 +12,7 @@ module Curry.LanguageServer.Utils.Env ( -- Curry Compiler Libraries + Dependencies import qualified Curry.Base.Ident as CI import qualified Curry.Base.SpanInfo as CSPI +import qualified Curry.Syntax as CS import qualified Base.Kinds as CK import qualified Base.Types as CT import qualified CompilerEnv as CE @@ -35,8 +36,8 @@ runLM :: LM a -> CE.CompilerEnv -> ModuleAST -> IO (Maybe a) runLM lm = curry $ runReaderT $ runMaybeT lm -- | Finds identifier and (occurrence) span info at a given position. -findAtPos :: J.Position -> LM (CI.QualIdent, CSPI.SpanInfo) -findAtPos pos = do +qualIdentAtPos :: J.Position -> LM (CI.QualIdent, CSPI.SpanInfo) +qualIdentAtPos pos = do (env, ast) <- lift ask let mident = moduleIdentifier ast exprIdent = joinFst $ qualIdentifier <.$> (withSpanInfo <$> (elementAt pos $ expressions ast)) diff --git a/src/Curry/LanguageServer/Utils/General.hs b/src/Curry/LanguageServer/Utils/General.hs index f2ce023..fbf78f1 100644 --- a/src/Curry/LanguageServer/Utils/General.hs +++ b/src/Curry/LanguageServer/Utils/General.hs @@ -6,6 +6,7 @@ module Curry.LanguageServer.Utils.General ( nth, pair, dup, + guarded, wordAtIndex, wordAtPos, wordsWithSpaceCount, pointRange, emptyRange, @@ -28,6 +29,7 @@ module Curry.LanguageServer.Utils.General ( tripleToPair ) where +import Control.Applicative import Control.Monad (join) import Control.Monad.Trans.Maybe import qualified Data.ByteString as B @@ -70,6 +72,10 @@ pair x y = (x, y) dup :: a -> (a, a) dup x = (x, x) +-- | Creates a wrapped alternative value if it satisfies the predicate, otherwise empty +guarded :: Alternative f => (a -> Bool) -> a -> f a +guarded p x = if p x then pure x else empty + -- | Finds the word at the given offset. wordAtIndex :: Int -> T.Text -> Maybe T.Text wordAtIndex n = wordAtIndex' n . wordsWithSpaceCount diff --git a/src/Curry/LanguageServer/Utils/Syntax.hs b/src/Curry/LanguageServer/Utils/Syntax.hs index 36eddad..f4d5e17 100644 --- a/src/Curry/LanguageServer/Utils/Syntax.hs +++ b/src/Curry/LanguageServer/Utils/Syntax.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + -- | AST utilities and typeclasses. module Curry.LanguageServer.Utils.Syntax ( HasExpressions (..), @@ -6,6 +8,8 @@ module Curry.LanguageServer.Utils.Syntax ( HasIdentifier (..), ModuleAST, elementAt, + elementsAt, + elementContains, moduleIdentifier ) where @@ -21,9 +25,13 @@ import qualified Language.Haskell.LSP.Types as J type ModuleAST = CS.Module CT.PredType --- | Fetches the element at the given position. +-- | Fetches the innermost element at the given position. elementAt :: CSPI.HasSpanInfo e => J.Position -> [e] -> Maybe e -elementAt pos = lastSafe . filter (elementContains pos) +elementAt pos = lastSafe . elementsAt pos + +-- | Fetches the elements at the given position. +elementsAt :: CSPI.HasSpanInfo e => J.Position -> [e] -> [e] +elementsAt pos = filter (elementContains pos) -- | Tests whether the given element in the AST contains the given position. elementContains :: CSPI.HasSpanInfo e => J.Position -> e -> Bool @@ -100,9 +108,27 @@ instance HasDeclarations CS.Module where instance HasDeclarations CS.Decl where declarations decl = decl : case decl of -- TODO: Fetch declarations inside equations/expressions/... - CS.ClassDecl _ _ _ _ _ ds -> ds - CS.InstanceDecl _ _ _ _ _ ds -> ds - _ -> [] + CS.ClassDecl _ _ _ _ _ ds -> declarations =<< ds + CS.InstanceDecl _ _ _ _ _ ds -> declarations =<< ds + CS.FunctionDecl _ _ _ eqs -> declarations =<< eqs + _ -> [] + +instance HasDeclarations CS.Equation where + declarations (CS.Equation _ _ rhs) = declarations rhs + +instance HasDeclarations CS.Rhs where + declarations rhs = case rhs of + CS.SimpleRhs _ _ e decls -> (declarations e) ++ (declarations =<< decls) + CS.GuardedRhs _ _ conds decls -> (declarations =<< conds) ++ (declarations =<< decls) + +instance HasDeclarations CS.CondExpr where + declarations ce = declarations =<< expressions ce + +instance HasDeclarations CS.Expression where + declarations e = expressions e >>= \case + -- TODO: Declarations in do-statements etc. + CS.Let _ _ ds e -> declarations =<< ds + _ -> [] class HasQualIdentifier e where qualIdentifier :: e -> Maybe CI.QualIdent diff --git a/test/resources/Test.curry b/test/resources/Test.curry index fc2e801..6463dac 100644 --- a/test/resources/Test.curry +++ b/test/resources/Test.curry @@ -1,7 +1,5 @@ module Test where -import Demo - f x = case x of - _ -> 3 - _ -> 5 + _ -> let y = 4 in f y + _ -> 4