[WIP] Completion support (#227)

* Initial implementation of completion support

* Add fuzzy to set of additional dependencies in 8.8

* Fix test

* Work a bit more on completion

* Attempt at getting completions from last good tckd module

* Revert "Attempt at getting completions from last good tckd module"

This reverts commit 04ca13b9d8.

* "useWithStale" everywhere

* Some suggestions by @cocreature

* Adjust positions in the document

* Start working on tests

* Fix compilation problem

* Fix tests

* Better type tests

ghcide.cabal

@@ -39,6 +39,7 @@ library
         deepseq,
         directory,
         extra,
+        fuzzy,
         filepath,
         hashable,
         haskell-lsp-types == 0.19.*,
@@ -96,6 +97,8 @@ library
     include-dirs:
         include
     exposed-modules:
+        Development.IDE.Core.Completions
+        Development.IDE.Core.CompletionsTypes
         Development.IDE.Core.FileStore
         Development.IDE.Core.OfInterest
         Development.IDE.Core.PositionMapping
@@ -123,6 +126,7 @@ library
         Development.IDE.GHC.Warnings
         Development.IDE.Import.FindImports
         Development.IDE.LSP.CodeAction
+        Development.IDE.LSP.Completions
         Development.IDE.LSP.HoverDefinition
         Development.IDE.LSP.Notifications
         Development.IDE.Spans.AtPoint
@@ -180,6 +184,7 @@ test-suite ghcide-tests
         ghcide:ghcide,
         ghcide:ghcide-test-preprocessor
     build-depends:
+        aeson,
         base,
         bytestring,
         containers,

src/Development/IDE/Core/Completions.hs

@@ -0,0 +1,565 @@
+-- Mostly taken from "haskell-ide-engine"
+module Development.IDE.Core.Completions (
+  CachedCompletions
+, cacheDataProducer
+, WithSnippets(..)
+,getCompletions
+) where
+
+import Control.Applicative
+import Data.Aeson
+import Data.Aeson.Types
+import Data.Char (isSpace)
+import Data.Generics
+import Data.List as List hiding (stripPrefix)
+import qualified Data.Map  as Map
+import Data.Maybe (fromMaybe, mapMaybe)
+import qualified Data.Text as T
+import qualified Text.Fuzzy as Fuzzy
+
+import GHC
+import Module
+import HscTypes
+import Name
+import RdrName
+import TcRnTypes
+import Type
+import Var
+import Packages
+import DynFlags
+import ConLike
+import DataCon
+import SrcLoc as GHC
+
+import Language.Haskell.LSP.Types
+import Language.Haskell.LSP.Types.Capabilities
+import qualified Language.Haskell.LSP.VFS as VFS
+import Development.IDE.Core.CompletionsTypes
+import Development.IDE.Spans.Documentation
+
+-- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs
+
+data NameDetails
+  = NameDetails Module OccName
+  deriving (Eq)
+
+nsJSON :: NameSpace -> Value
+nsJSON ns
+  | isVarNameSpace ns = String "v"
+  | isDataConNameSpace ns = String "c"
+  | isTcClsNameSpace ns  = String "t"
+  | isTvNameSpace ns = String "z"
+  | otherwise = error "namespace not recognized"
+
+parseNs :: Value -> Parser NameSpace
+parseNs (String "v") = pure Name.varName
+parseNs (String "c") = pure dataName
+parseNs (String "t") = pure tcClsName
+parseNs (String "z") = pure tvName
+parseNs _ = mempty
+
+instance FromJSON NameDetails where
+  parseJSON v@(Array _)
+    = do
+      [modname,modid,namesp,occname] <- parseJSON v
+      mn  <- parseJSON modname
+      mid <- parseJSON modid
+      ns <- parseNs namesp
+      occn <- parseJSON occname
+      pure $ NameDetails (mkModule (stringToUnitId mid) (mkModuleName mn)) (mkOccName ns occn)
+  parseJSON _ = mempty
+instance ToJSON NameDetails where
+  toJSON (NameDetails mdl occ) = toJSON [toJSON mname,toJSON mid,nsJSON ns,toJSON occs]
+    where
+      mname = moduleNameString $ moduleName mdl
+      mid = unitIdString $ moduleUnitId mdl
+      ns = occNameSpace occ
+      occs = occNameString occ
+
+safeTyThingId :: TyThing -> Maybe Id
+safeTyThingId (AnId i)                    = Just i
+safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc
+safeTyThingId _                           = Nothing
+
+-- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs
+
+-- | A context of a declaration in the program
+-- e.g. is the declaration a type declaration or a value declaration
+-- Used for determining which code completions to show
+-- TODO: expand this with more contexts like classes or instances for
+-- smarter code completion
+data Context = TypeContext
+             | ValueContext
+             | ModuleContext String -- ^ module context with module name
+             | ImportContext String -- ^ import context with module name
+             | ImportListContext String -- ^ import list context with module name
+             | ImportHidingContext String -- ^ import hiding context with module name
+             | ExportContext -- ^ List of exported identifiers from the current module
+  deriving (Show, Eq)
+
+-- | Generates a map of where the context is a type and where the context is a value
+-- i.e. where are the value decls and the type decls
+getCContext :: Position -> ParsedModule -> Maybe Context
+getCContext pos pm
+  | Just (L (RealSrcSpan r) modName) <- moduleHeader
+  , pos `isInsideRange` r
+  = Just (ModuleContext (moduleNameString modName))
+
+  | Just (L (RealSrcSpan r) _) <- exportList
+  , pos `isInsideRange` r
+  = Just ExportContext
+
+  | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl
+  = Just ctx
+
+  | Just ctx <- something (Nothing `mkQ` importGo) imports
+  = Just ctx
+
+  | otherwise
+  = Nothing
+
+  where decl = hsmodDecls $ unLoc $ pm_parsed_source pm
+        moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm
+        exportList = hsmodExports $ unLoc $ pm_parsed_source pm
+        imports = hsmodImports $ unLoc $ pm_parsed_source pm
+
+        go :: LHsDecl GhcPs -> Maybe Context
+        go (L (RealSrcSpan r) SigD {})
+          | pos `isInsideRange` r = Just TypeContext
+          | otherwise = Nothing
+        go (L (GHC.RealSrcSpan r) GHC.ValD {})
+          | pos `isInsideRange` r = Just ValueContext
+          | otherwise = Nothing
+        go _ = Nothing
+
+        goInline :: GHC.LHsType GhcPs -> Maybe Context
+        goInline (GHC.L (GHC.RealSrcSpan r) _)
+          | pos `isInsideRange` r = Just TypeContext
+          | otherwise = Nothing
+        goInline _ = Nothing
+
+        p `isInsideRange` r = sp <= p && p <= ep
+          where (sp, ep) = unpackRealSrcSpan r
+
+        -- | Converts from one based tuple
+        toPos :: (Int,Int) -> Position
+        toPos (l,c) = Position (l-1) (c-1)
+          
+        unpackRealSrcSpan :: GHC.RealSrcSpan -> (Position, Position)
+        unpackRealSrcSpan rspan =
+          (toPos (l1,c1),toPos (l2,c2))
+          where s  = GHC.realSrcSpanStart rspan
+                l1 = GHC.srcLocLine s
+                c1 = GHC.srcLocCol s
+                e  = GHC.realSrcSpanEnd rspan
+                l2 = GHC.srcLocLine e
+                c2 = GHC.srcLocCol e
+
+        importGo :: GHC.LImportDecl GhcPs -> Maybe Context
+        importGo (L (RealSrcSpan r) impDecl)
+          | pos `isInsideRange` r
+          = importInline importModuleName (ideclHiding impDecl)
+          <|> Just (ImportContext importModuleName)
+
+          | otherwise = Nothing
+          where importModuleName = moduleNameString $ unLoc $ ideclName impDecl
+
+        importGo _ = Nothing
+
+        importInline :: String -> Maybe (Bool,  GHC.Located [LIE GhcPs]) -> Maybe Context
+        importInline modName (Just (True, L (RealSrcSpan r) _))
+          | pos `isInsideRange` r = Just $ ImportHidingContext modName
+          | otherwise = Nothing
+        importInline modName (Just (False, L (RealSrcSpan r) _))
+          | pos `isInsideRange` r = Just $ ImportListContext modName
+          | otherwise = Nothing
+        importInline _ _ = Nothing
+
+type CompItemResolveData
+  = Maybe NameDetails
+
+occNameToComKind :: OccName -> CompletionItemKind
+occNameToComKind oc
+  | isVarOcc  oc = CiFunction
+  | isTcOcc   oc = CiClass
+  | isDataOcc oc = CiConstructor
+  | otherwise    = CiVariable
+
+mkCompl :: CompItem -> CompletionItem
+mkCompl CI{origName,importedFrom,thingType,label,isInfix,docs} =
+  CompletionItem label kind (Just $ maybe "" (<>"\n") typeText <> importedFrom)
+    (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs)
+    Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
+    Nothing Nothing Nothing Nothing resolveData
+  where kind = Just $ occNameToComKind $ occName origName
+        resolveData = Just (toJSON nameDets)
+        insertText = case isInfix of
+            Nothing -> case getArgText <$> thingType of
+                            Nothing -> label
+                            Just argText -> label <> " " <> argText
+            Just LeftSide -> label <> "`"
+
+            Just Surrounded -> label
+        typeText
+          | Just t <- thingType = Just . stripForall $ T.pack (showGhc t)
+          | otherwise = Nothing
+        nameDets =
+          case (thingType, nameModule_maybe origName) of
+            (Just _,_) -> Nothing
+            (Nothing, Nothing) -> Nothing
+            (Nothing, Just mdl) -> Just (NameDetails mdl (nameOccName origName))
+
+stripForall :: T.Text -> T.Text
+stripForall t
+  | T.isPrefixOf "forall" t =
+    -- We drop 2 to remove the '.' and the space after it
+    T.drop 2 (T.dropWhile (/= '.') t)
+  | otherwise               = t
+
+getArgText :: Type -> T.Text
+getArgText typ = argText
+  where
+    argTypes = getArgs typ
+    argText :: T.Text
+    argText =  mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes
+    snippet :: Int -> Type -> T.Text
+    snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"
+    getArgs :: Type -> [Type]
+    getArgs t
+      | isPredTy t = []
+      | isDictTy t = []
+      | isForAllTy t = getArgs $ snd (splitForAllTys t)
+      | isFunTy t =
+        let (args, ret) = splitFunTys t
+          in if isForAllTy ret
+              then getArgs ret
+              else Prelude.filter (not . isDictTy) args
+      | isPiTy t = getArgs $ snd (splitPiTys t)
+      | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)
+      | otherwise = []
+
+mkModCompl :: T.Text -> CompletionItem
+mkModCompl label =
+  CompletionItem label (Just CiModule) Nothing
+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+    Nothing Nothing Nothing Nothing (Just $ toJSON resolveData)
+  where resolveData :: CompItemResolveData
+        resolveData = Nothing
+
+mkImportCompl :: T.Text -> T.Text -> CompletionItem
+mkImportCompl enteredQual label =
+  CompletionItem m (Just CiModule) (Just label)
+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+    Nothing Nothing Nothing Nothing Nothing
+  where 
+    m = fromMaybe "" (T.stripPrefix enteredQual label)
+
+mkExtCompl :: T.Text -> CompletionItem
+mkExtCompl label =
+  CompletionItem label (Just CiKeyword) Nothing
+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+    Nothing Nothing Nothing Nothing Nothing
+
+mkPragmaCompl :: T.Text -> T.Text -> CompletionItem
+mkPragmaCompl label insertText =
+  CompletionItem label (Just CiKeyword) Nothing
+    Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
+    Nothing Nothing Nothing Nothing Nothing
+
+cacheDataProducer :: DynFlags -> TypecheckedModule -> [TypecheckedModule] -> IO CachedCompletions
+cacheDataProducer dflags tm tcs = do
+  let parsedMod = tm_parsed_module tm
+      curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod
+      Just (_,limports,_,_) = tm_renamed_source tm
+
+      iDeclToModName :: ImportDecl name -> ModuleName
+      iDeclToModName = unLoc . ideclName
+
+      showModName :: ModuleName -> T.Text
+      showModName = T.pack . moduleNameString
+
+      asNamespace :: ImportDecl name -> ModuleName
+      asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp)
+      -- Full canonical names of imported modules
+      importDeclerations = map unLoc limports
+
+      -- The list of all importable Modules from all packages
+      moduleNames = map showModName (listVisibleModuleNames dflags)
+
+      -- The given namespaces for the imported modules (ie. full name, or alias if used)
+      allModNamesAsNS = map (showModName . asNamespace) importDeclerations
+
+      typeEnv = tcg_type_env $ fst $ tm_internals_ tm
+      rdrEnv = tcg_rdr_env $ fst $ tm_internals_ tm
+      rdrElts = globalRdrEnvElts rdrEnv
+
+      getCompls :: [GlobalRdrElt] -> ([CompItem],QualCompls)
+      getCompls = foldMap getComplsForOne
+
+      getComplsForOne :: GlobalRdrElt -> ([CompItem],QualCompls)
+      getComplsForOne (GRE n _ True _) =
+        case lookupTypeEnv typeEnv n of
+          Just tt -> case safeTyThingId tt of
+            Just var -> ([varToCompl var],mempty)
+            Nothing -> ([toCompItem curMod n],mempty)
+          Nothing -> ([toCompItem curMod n],mempty)
+      getComplsForOne (GRE n _ False prov) =
+        flip foldMap (map is_decl prov) $ \spec ->
+          let unqual
+                | is_qual spec = []
+                | otherwise = compItem
+              qual
+                | is_qual spec = Map.singleton asMod compItem
+                | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)]
+              compItem = [toCompItem (is_mod spec) n]
+              asMod = showModName (is_as spec)
+              origMod = showModName (is_mod spec)
+          in (unqual,QualCompls qual)
+
+      varToCompl :: Var -> CompItem
+      varToCompl var = CI name (showModName curMod) typ label Nothing docs
+        where
+          typ = Just $ varType var
+          name = Var.varName var
+          label = T.pack $ showGhc name
+          docs = getDocumentation tcs name
+
+      toCompItem :: ModuleName -> Name -> CompItem
+      toCompItem mn n =
+        CI n (showModName mn) Nothing (T.pack $ showGhc n) Nothing (getDocumentation tcs n)
+
+      (unquals,quals) = getCompls rdrElts
+
+  return $ CC
+    { allModNamesAsNS = allModNamesAsNS
+    , unqualCompls = unquals
+    , qualCompls = quals
+    , importableModules = moduleNames
+    }
+
+newtype WithSnippets = WithSnippets Bool
+
+toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem
+toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x
+  | with && supported = x
+  | otherwise = x { _insertTextFormat = Just PlainText
+                  , _insertText       = Nothing
+                  }
+  where supported = fromMaybe False (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)
+
+-- | Returns the cached completions for the given module and position.
+getCompletions :: CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]
+getCompletions CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }
+               tm prefixInfo caps withSnippets = do
+  let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo
+      enteredQual = if T.null prefixModule then "" else prefixModule <> "."
+      fullPrefix  = enteredQual <> prefixText
+
+      -- default to value context if no explicit context
+      context = fromMaybe ValueContext $ getCContext pos (tm_parsed_module tm)
+
+      {- correct the position by moving 'foo :: Int -> String ->    '
+                                                                    ^
+          to                             'foo :: Int -> String ->    '
+                                                              ^
+      -}
+      pos =
+        let Position l c = VFS.cursorPos prefixInfo
+            typeStuff = [isSpace, (`elem` (">-." :: String))]
+            stripTypeStuff = T.dropWhileEnd (\x -> any (\f -> f x) typeStuff)
+            -- if oldPos points to
+            -- foo -> bar -> baz
+            --    ^
+            -- Then only take the line up to there, discard '-> bar -> baz'
+            partialLine = T.take c fullLine
+            -- drop characters used when writing incomplete type sigs
+            -- like '-> '
+            d = T.length fullLine - T.length (stripTypeStuff partialLine)
+        in Position l (c - d)
+
+      filtModNameCompls =
+        map mkModCompl
+          $ mapMaybe (T.stripPrefix enteredQual)
+          $ Fuzzy.simpleFilter fullPrefix allModNamesAsNS
+
+      filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False
+        where
+          isTypeCompl = isTcOcc . occName . origName
+          -- completions specific to the current context
+          ctxCompls' = case context of
+                        TypeContext -> filter isTypeCompl compls
+                        ValueContext -> filter (not . isTypeCompl) compls
+                        _ -> filter (not . isTypeCompl) compls
+          -- Add whether the text to insert has backticks
+          ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'
+
+          infixCompls :: Maybe Backtick
+          infixCompls = isUsedAsInfix fullLine prefixModule prefixText (VFS.cursorPos prefixInfo)
+
+          compls = if T.null prefixModule
+            then unqualCompls
+            else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls
+
+      filtListWith f list =
+        [ f label
+        | label <- Fuzzy.simpleFilter fullPrefix list
+        , enteredQual `T.isPrefixOf` label
+        ]
+
+      filtListWithSnippet f list suffix =
+        [ toggleSnippets caps withSnippets (f label (snippet <> suffix))
+        | (snippet, label) <- list
+        , Fuzzy.test fullPrefix label
+        ]
+
+      filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
+      filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas
+      filtOptsCompls   = filtListWith mkExtCompl
+
+      stripLeading :: Char -> String -> String
+      stripLeading _ [] = []
+      stripLeading c (s:ss)
+        | s == c = ss
+        | otherwise = s:ss
+
+      result
+        | "import " `T.isPrefixOf` fullLine
+        = filtImportCompls
+        | "{-# language" `T.isPrefixOf` T.toLower fullLine
+        = filtOptsCompls languagesAndExts
+        | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine
+        = filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False)
+        | "{-# " `T.isPrefixOf` fullLine
+        = filtPragmaCompls (pragmaSuffix fullLine)
+        | otherwise
+        = filtModNameCompls ++ map (toggleSnippets caps withSnippets
+                                      . mkCompl . stripAutoGenerated) filtCompls
+  
+  return result
+
+-- The supported languages and extensions
+languagesAndExts :: [T.Text]
+languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions
+  
+-- ---------------------------------------------------------------------
+-- helper functions for pragmas
+-- ---------------------------------------------------------------------
+
+validPragmas :: [(T.Text, T.Text)]
+validPragmas =
+  [ ("LANGUAGE ${1:extension}"        , "LANGUAGE")
+  , ("OPTIONS_GHC -${1:option}"       , "OPTIONS_GHC")
+  , ("INLINE ${1:function}"           , "INLINE")
+  , ("NOINLINE ${1:function}"         , "NOINLINE")
+  , ("INLINABLE ${1:function}"        , "INLINABLE")
+  , ("WARNING ${1:message}"           , "WARNING")
+  , ("DEPRECATED ${1:message}"        , "DEPRECATED")
+  , ("ANN ${1:annotation}"            , "ANN")
+  , ("RULES"                          , "RULES")
+  , ("SPECIALIZE ${1:function}"       , "SPECIALIZE")
+  , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE")
+  ]
+
+pragmaSuffix :: T.Text -> T.Text
+pragmaSuffix fullLine
+  |  "}" `T.isSuffixOf` fullLine = mempty
+  | otherwise = " #-}"
+
+-- ---------------------------------------------------------------------
+-- helper functions for infix backticks
+-- ---------------------------------------------------------------------
+
+hasTrailingBacktick :: T.Text -> Position -> Bool
+hasTrailingBacktick line Position { _character }
+    | T.length line > _character = (line `T.index` _character) == '`'
+    | otherwise = False
+
+isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick
+isUsedAsInfix line prefixMod prefixText pos
+    | hasClosingBacktick && hasOpeningBacktick = Just Surrounded
+    | hasOpeningBacktick = Just LeftSide
+    | otherwise = Nothing
+  where
+    hasOpeningBacktick = openingBacktick line prefixMod prefixText pos
+    hasClosingBacktick = hasTrailingBacktick line pos
+
+openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool
+openingBacktick line prefixModule prefixText Position { _character }
+  | backtickIndex < 0 = False
+  | otherwise = (line `T.index` backtickIndex) == '`'
+    where
+    backtickIndex :: Int
+    backtickIndex =
+      let
+          prefixLength = T.length prefixText
+          moduleLength = if prefixModule == ""
+                    then 0
+                    else T.length prefixModule + 1 {- Because of "." -}
+      in
+        -- Points to the first letter of either the module or prefix text
+        _character - (prefixLength + moduleLength) - 1
+
+
+-- ---------------------------------------------------------------------
+
+-- | Under certain circumstance GHC generates some extra stuff that we
+-- don't want in the autocompleted symbols
+stripAutoGenerated :: CompItem -> CompItem
+stripAutoGenerated ci =
+    ci {label = stripPrefix (label ci)}
+    {- When e.g. DuplicateRecordFields is enabled, compiler generates
+    names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors
+    https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation
+    -}
+
+-- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace.
+
+stripPrefix :: T.Text -> T.Text
+stripPrefix name = T.takeWhile (/=':') $ go prefixes
+  where
+    go [] = name
+    go (p:ps)
+      | T.isPrefixOf p name = T.drop (T.length p) name
+      | otherwise = go ps
+
+-- | Prefixes that can occur in a GHC OccName
+prefixes :: [T.Text]
+prefixes =
+  [
+    -- long ones
+    "$con2tag_"
+  , "$tag2con_"
+  , "$maxtag_"
+
+  -- four chars
+  , "$sel:"
+  , "$tc'"
+
+  -- three chars
+  , "$dm"
+  , "$co"
+  , "$tc"
+  , "$cp"
+  , "$fx"
+
+  -- two chars
+  , "$W"
+  , "$w"
+  , "$m"
+  , "$b"
+  , "$c"
+  , "$d"
+  , "$i"
+  , "$s"
+  , "$f"
+  , "$r"
+  , "C:"
+  , "N:"
+  , "D:"
+  , "$p"
+  , "$L"
+  , "$f"
+  , "$t"
+  , "$c"
+  , "$m"
+  ]

src/Development/IDE/Core/CompletionsTypes.hs

@@ -0,0 +1,62 @@
+module Development.IDE.Core.CompletionsTypes (
+  module Development.IDE.Core.CompletionsTypes
+) where
+
+import           Control.DeepSeq
+import qualified Data.Map  as Map
+import qualified Data.Text as T
+
+import           GHC
+import           Outputable
+import           DynFlags
+
+-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs
+
+showGhc :: Outputable a => a -> String
+showGhc = showPpr unsafeGlobalDynFlags
+
+data Backtick = Surrounded | LeftSide deriving Show
+data CompItem = CI
+  { origName     :: Name           -- ^ Original name, such as Maybe, //, or find.
+  , importedFrom :: T.Text         -- ^ From where this item is imported from.
+  , thingType    :: Maybe Type     -- ^ Available type information.
+  , label        :: T.Text         -- ^ Label to display to the user.
+  , isInfix      :: Maybe Backtick -- ^ Did the completion happen
+                                   -- in the context of an infix notation.
+  , docs         :: [T.Text]       -- ^ Available documentation.
+  }
+instance Show CompItem where
+  show CI { .. } = "CompItem { origName = \"" ++ showGhc origName ++ "\""
+                   ++ ", importedFrom = " ++ show importedFrom
+                   ++ ", thingType = " ++ show (fmap showGhc thingType)
+                   ++ ", label = " ++ show label
+                   ++ ", isInfix = " ++ show isInfix 
+                   ++ ", docs = " ++ show docs
+                   ++ " } "
+instance Eq CompItem where
+  ci1 == ci2 = origName ci1 == origName ci2
+instance Ord CompItem where
+  compare ci1 ci2 = origName ci1 `compare` origName ci2
+
+-- Associates a module's qualifier with its members
+newtype QualCompls
+  = QualCompls { getQualCompls :: Map.Map T.Text [CompItem] }
+  deriving Show
+instance Semigroup QualCompls where
+  (QualCompls a) <> (QualCompls b) = QualCompls $ Map.unionWith (++) a b
+instance Monoid QualCompls where
+  mempty = QualCompls Map.empty
+  mappend = (Prelude.<>)
+
+-- | End result of the completions
+data CachedCompletions = CC
+  { allModNamesAsNS :: [T.Text] -- ^ All module names in scope.
+                                -- Prelude is a single module
+  , unqualCompls :: [CompItem]  -- ^ All Possible completion items
+  , qualCompls :: QualCompls    -- ^ Completion items associated to
+                                -- to a specific module name.
+  , importableModules :: [T.Text] -- ^ All modules that may be imported.
+  } deriving Show
+
+instance NFData CachedCompletions where
+    rnf = rwhnf

src/Development/IDE/Core/RuleTypes.hs

@@ -27,6 +27,7 @@ import Module (InstalledUnitId)
 import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)
 import Development.IDE.GHC.Compat
 
+import           Development.IDE.Core.CompletionsTypes
 import           Development.IDE.Spans.Type
 
 
@@ -85,6 +86,9 @@ type instance RuleResult ReportImportCycles = ()
 -- | Read the given HIE file.
 type instance RuleResult GetHieFile = HieFile
 
+-- | Produce completions info for a file
+type instance RuleResult ProduceCompletions = (CachedCompletions, TcModuleResult)
+
 
 data GetParsedModule = GetParsedModule
     deriving (Eq, Show, Typeable, Generic)
@@ -153,3 +157,9 @@ data GetHieFile = GetHieFile FilePath
 instance Hashable GetHieFile
 instance NFData   GetHieFile
 instance Binary   GetHieFile
+
+data ProduceCompletions = ProduceCompletions
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable ProduceCompletions
+instance NFData   ProduceCompletions
+instance Binary   ProduceCompletions

src/Development/IDE/Core/Rules.hs

@@ -32,6 +32,7 @@ import Control.Monad
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
 import Development.IDE.Core.Compile
+import Development.IDE.Core.Completions
 import Development.IDE.Types.Options
 import Development.IDE.Spans.Calculate
 import Development.IDE.Import.DependencyInformation
@@ -304,6 +305,19 @@ generateCoreRule :: Rules ()
 generateCoreRule =
     define $ \GenerateCore -> generateCore
 
+produceCompletions :: Rules ()
+produceCompletions =
+    define $ \ProduceCompletions file -> do
+        deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file
+        tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)
+        tm <- fmap fst <$> useWithStale TypeCheck file
+        dflags <- fmap (hsc_dflags . hscEnv . fst) <$> useWithStale GhcSession file
+        case (tm, dflags) of
+            (Just tm', Just dflags') -> do
+                cdata <- liftIO $ cacheDataProducer dflags' (tmrModule tm') (map tmrModule tms)
+                return ([], Just (cdata, tm'))
+            _ -> return ([], Nothing)
+
 generateByteCodeRule :: Rules ()
 generateByteCodeRule =
     define $ \GenerateByteCode file -> do
@@ -361,6 +375,7 @@ mainRule = do
     generateByteCodeRule
     loadGhcSession
     getHieFileRule
+    produceCompletions
 
 ------------------------------------------------------------
 

src/Development/IDE/LSP/Completions.hs

@@ -0,0 +1,46 @@
+module Development.IDE.LSP.Completions (
+  setHandlersCompletion
+) where
+
+import Language.Haskell.LSP.Messages
+import Language.Haskell.LSP.Types
+import qualified Language.Haskell.LSP.Core as LSP
+import qualified Language.Haskell.LSP.VFS as VFS
+import Language.Haskell.LSP.Types.Capabilities
+
+import Development.IDE.Core.Service
+import Development.IDE.Core.Completions
+import Development.IDE.Types.Location
+import Development.IDE.Core.PositionMapping
+import Development.IDE.Core.RuleTypes
+import Development.IDE.Core.Shake
+import Development.IDE.LSP.Server
+
+-- | Generate code actions.
+getCompletionsLSP
+    :: LSP.LspFuncs ()
+    -> IdeState
+    -> CompletionParams
+    -> IO CompletionResponseResult
+getCompletionsLSP lsp ide CompletionParams{_textDocument=TextDocumentIdentifier uri,_position=position} = do
+    contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
+    case (contents, uriToFilePath' uri) of
+      (Just cnts, Just path) -> do
+        let npath = toNormalizedFilePath path
+        compls <- runAction ide (useWithStale ProduceCompletions npath)
+        case compls of
+          Just ((cci', tm'), mapping) -> do
+            let position' = fromCurrentPosition mapping position
+            pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'
+            case pfix of
+              Just pfix' -> do
+                let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing
+                Completions . List <$> getCompletions cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True)
+              _ -> return (Completions $ List [])
+          _ -> return (Completions $ List [])
+      _ -> return (Completions $ List [])
+
+setHandlersCompletion :: PartialHandlers
+setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{
+    LSP.completionHandler = withResponse RspCompletion getCompletionsLSP
+    }

src/Development/IDE/LSP/LanguageServer.hs

@@ -30,6 +30,7 @@ import Control.Monad.Extra
 
 import Development.IDE.LSP.HoverDefinition
 import Development.IDE.LSP.CodeAction
+import Development.IDE.LSP.Completions
 import Development.IDE.LSP.Notifications
 import Development.IDE.Core.Service
 import Development.IDE.Types.Logger
@@ -97,6 +98,7 @@ runLanguageServer options userHandlers getIdeState = do
             setHandlersIgnore <> -- least important
             setHandlersDefinition <> setHandlersHover <>
             setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override
+            setHandlersCompletion <>
             userHandlers <>
             setHandlersNotifications <> -- absolutely critical, join them with user notifications
             cancelHandler cancelRequest

stack-ghc-lib.yaml

@@ -8,6 +8,7 @@ extra-deps:
 - hie-bios-0.3.0
 - ghc-lib-parser-8.8.1
 - ghc-lib-8.8.1
+- fuzzy-0.1.0.0
 nix:
   packages: [zlib]
 flags:

stack.yaml

@@ -6,5 +6,6 @@ extra-deps:
 - haskell-lsp-types-0.19.0.0
 - lsp-test-0.9.0.0
 - hie-bios-0.3.0
+- fuzzy-0.1.0.0
 nix:
   packages: [zlib]

stack84.yaml

@@ -11,6 +11,7 @@ extra-deps:
 - filepattern-0.1.1
 - js-dgtable-0.5.2
 - hie-bios-0.3.0
+- fuzzy-0.1.0.0
 nix:
   packages: [zlib]
 allow-newer: true

stack88.yaml

@@ -6,6 +6,7 @@ extra-deps:
 - haskell-lsp-types-0.19.0.0
 - lsp-test-0.9.0.0
 - hie-bios-0.3.0
+- fuzzy-0.1.0.0
 allow-newer: true
 nix:
   packages: [zlib]

test/exe/Main.hs

@@ -10,6 +10,7 @@ module Main (main) where
 import Control.Applicative.Combinators
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
+import qualified Data.Aeson as Aeson
 import Data.Char (toLower)
 import Data.Foldable
 import Development.IDE.GHC.Util
@@ -37,6 +38,7 @@ main = defaultMain $ testGroup "HIE"
       closeDoc doc
       void (message :: Session WorkDoneProgressEndNotification)
   , initializeResponseTests
+  , completionTests
   , diagnosticTests
   , codeActionTests
   , codeLensesTests
@@ -59,7 +61,7 @@ initializeResponseTests = withResource acquire release tests where
     testGroup "initialize response capabilities"
     [ chk "   text doc sync"             _textDocumentSync  tds
     , chk "   hover"                         _hoverProvider (Just True)
-    , chk "NO completion"               _completionProvider  Nothing
+    , chk "   completion"               _completionProvider (Just $ CompletionOptions (Just False) Nothing Nothing)
     , chk "NO signature help"        _signatureHelpProvider  Nothing
     , chk "   goto definition"          _definitionProvider (Just True)
     , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)
@@ -960,6 +962,51 @@ thTests =
         expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
     ]
 
+completionTests :: TestTree
+completionTests
+  = testGroup "completion"
+    [ testSessionWait "variable" $ do
+        let source = T.unlines ["module A where", "f = hea"]
+        docId <- openDoc' "A.hs" "haskell" source
+        compls <- getCompletions docId (Position 1 7)
+        liftIO $ compls @?= [complItem "head" ["GHC.List", "base", "v", "head"] (Just CiFunction)]
+    , testSessionWait "type" $ do
+        let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
+        docId <- openDoc' "A.hs" "haskell" source
+        expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
+        changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
+        compls <- getCompletions docId (Position 2 7)
+        liftIO $ compls @?=
+            [ complItem "Bounded" ["GHC.Enum", "base", "t", "Bounded"] (Just CiClass)
+            , complItem "Bool" ["GHC.Types", "ghc-prim", "t", "Bool"] (Just CiClass)
+            ]
+    , testSessionWait "qualified" $ do
+        let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
+        docId <- openDoc' "A.hs" "haskell" source
+        expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
+        changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
+        compls <- getCompletions docId (Position 2 15)
+        liftIO $ compls @?= [complItem "head" ["GHC.List", "base", "v", "head"] (Just CiFunction)]
+    ]
+  where
+    complItem label xdata kind = CompletionItem
+      { _label = label
+      , _kind = kind
+      , _detail = Just "Prelude"
+      , _documentation = Just (CompletionDocMarkup (MarkupContent {_kind = MkMarkdown, _value = ""}))
+      , _deprecated = Nothing
+      , _preselect = Nothing
+      , _sortText = Nothing
+      , _filterText = Nothing
+      , _insertText = Nothing
+      , _insertTextFormat = Just PlainText
+      , _textEdit = Nothing
+      , _additionalTextEdits = Nothing
+      , _commitCharacters = Nothing
+      , _command = Nothing
+      , _xdata = Just (Aeson.toJSON (xdata :: [T.Text]))
+      }
+
 xfail :: TestTree -> String -> TestTree
 xfail = flip expectFailBecause