Provide fully context-aware completions

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

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.

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'

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

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

src/Curry/LanguageServer/Utils/Env.hs

@@ -4,14 +4,15 @@ module Curry.LanguageServer.Utils.Env (
     LookupEnv,
     LM,
     runLM,
-    findAtPos,
+    qualIdentAtPos,
     valueInfoType,
     typeInfoKind
 ) where
 
 -- 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))

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

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

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