Don't output module snippets when present

Author: crtschin

ghcide-test/exe/CompletionTests.hs

@@ -625,8 +625,6 @@ contextCompletionTests =
       (Position 4 8)
       [("Xxxtype", CompletionItemKind_Struct, "Xxxtype", False, True, Nothing)]
 
-  -- where-clause / local binding context tests
-
   , completionTest
       "type sig in where-clause gives type completions"
       [ "{-# OPTIONS_GHC -Wunused-binds #-}"
@@ -726,6 +724,25 @@ contextCompletionTests =
       ]
       (Position 5 19)  -- after "Xxx" in "  let helper :: Xxx"
       [("Xxxtype", CompletionItemKind_Struct, "Xxxtype", False, True, Nothing)]
+
+  , testSessionSingleFile "module header snippet shown when no module declaration" "A.hs"
+      [ "mod"
+      ] $ do
+      doc <- openDoc "A.hs" "haskell"
+      _ <- waitForDiagnostics
+      compls <- getCompletions doc (Position 0 3)
+      let moduleSnippets = filterSnippetsLabel "module" compls
+      liftIO $ length moduleSnippets @?= 1
+
+  , testSessionSingleFile "module header snippet not shown when module declaration exists" "A.hs"
+      [ "module A where"
+      , "mod"
+      ] $ do
+      doc <- openDoc "A.hs" "haskell"
+      _ <- waitForDiagnostics
+      compls <- getCompletions doc (Position 1 3)
+      let moduleSnippets = filterSnippetsLabel "module" compls
+      liftIO $ moduleSnippets @?= []
   ]
   where
     filterSnippetsLabel l snippets =

ghcide/src/Development/IDE/Plugin/Completions.hs

@@ -216,9 +216,10 @@ getCompletionsLSP recorder ide plId
                 let clientCaps = clientCapabilities $ shakeExtras ide
                     plugins = idePlugins $ shakeExtras ide
                     context = deduceContext ctxTree (cursorPos pfix)
+                    hasModuleHeader = maybe False (contextHasModuleHeader . fst) ctxTree
                 config <- liftIO $ runAction "" ide $ getCompletionsConfig plId
 
-                let allCompletions = getCompletions plugins ideOpts cci' context astres bindMap pfix clientCaps config moduleExports uri
+                let allCompletions = getCompletions plugins ideOpts cci' context hasModuleHeader astres bindMap pfix clientCaps config moduleExports uri
                 logWith recorder Debug $ LogDetectedContext context
                 pure $ InL (orderedCompletions allCompletions)
           _ -> return (InL [])

ghcide/src/Development/IDE/Plugin/Completions/Context.hs

@@ -8,15 +8,24 @@ module Development.IDE.Plugin.Completions.Context
   , ContextGroup (..)
   , ContextMap
   , GetContextMap (..)
+  , contextHasModuleHeader
   , getContext
   , getContextMap
   ) where
 
 import           Control.DeepSeq                      (NFData (..), rwhnf)
-import           Data.Generics                        (extQ, mkQ)
-import           Data.Generics.Schemes                (everythingBut)
+import           Data.Generics                        (Data (..), GenericQ,
+                                                       extQ, mkQ)
 import           Data.Hashable                        (Hashable)
-import           Data.Maybe                           (mapMaybe)
+import           Data.List.Extra                      (nubOrd)
+import           Data.Maybe                           (fromJust, isJust,
+                                                       mapMaybe)
+import           Data.List.Extra                      (nubOrd)
+import           Data.Maybe                           (isJust, mapMaybe,
+                                                       maybeToList)
+import           Data.List.Extra                      (nub)
+import           Data.Maybe                           (isJust, mapMaybe,
+                                                       maybeToList)
 import qualified Data.Text                            as T
 import           Development.IDE
 import           Development.IDE.Core.PositionMapping
@@ -68,31 +77,38 @@ type instance RuleResult GetContextMap = ContextMap
 data ContextChunk = Chunk
   { low     :: {-# UNPACK #-} !Position
   , high    :: {-# UNPACK #-} !Position
-  , group   :: {-# UNPACK #-} !ContextGroup
+  , group   :: !ContextGroup
   , context :: Range -> ContextResult
   }
 
 -- | Build lazy 'ContextChunk' by processing @n@ source items at a time.
-groupedChunks :: Int -> ContextGroup -> (a -> Maybe Range) -> (a -> Range -> ContextResult) -> [a] -> ContextMap
-groupedChunks n group getPos locate xs = ContextMap $ go xs
+groupedChunks :: Int -> ContextGroup -> (a -> Maybe Range) -> (a -> Range -> ContextResult) -> [a] -> [ContextChunk]
+groupedChunks n group getPos locate xs = go xs
   where
     go [] = []
     go xs =
       let (chunk, rest) = splitAt n xs
           context = foldMap locate chunk
-      in case chunk of
+          positions = mapMaybe getPos chunk
+      in case positions of
             [] -> go rest
-            _  -> Chunk
-              { low   = minimum (mapMaybe (fmap _start  . getPos) chunk)
-              , high  = maximum (mapMaybe (fmap _end  . getPos) chunk)
+            ps -> Chunk
+              { low   = minimum (fmap _start ps)
+              , high  = maximum (fmap _end ps)
               , group
               , context
               } : go rest
 
+-- | Build lazy 'ContextChunk' by processing @n@ source items at a time.
+singletonChunk :: ContextGroup -> (a -> Maybe Range) -> (a -> Range -> ContextResult) -> a -> ContextChunk
+singletonChunk group getPos locate inp = Chunk s e group (locate inp)
+  where
+    Range s e = fromJust $ getPos inp
+
 -- | Used during context finding, combines into the tightest interval.
 -- As an intuition, the primary interface is through
--- @Monoid (Position -> ContextResult)@.
-data ContextResult = NoContext | ContextResult Range Context
+-- @Monoid (Range -> ContextResult)@.
+data ContextResult = NoContext | ContextResult !Range !Context
 instance Monoid ContextResult where mempty = NoContext
 instance Semigroup ContextResult where (<>) = tighten
 
@@ -102,8 +118,14 @@ tighten a NoContext = a
 tighten ar@(ContextResult a _) br@(ContextResult b _) =
   if a `dominates` b then br else ar
 
-newtype ContextMap = ContextMap [ContextChunk]
-  deriving newtype (Monoid, Semigroup)
+-- | A context map, built from a parsed module. Stores whether the module
+-- already has a @module ... where@ header, so that the header snippet can
+-- be suppressed for files that already declare a module.
+data ContextMap = ContextMap !Bool [ContextChunk]
+instance Semigroup ContextMap where
+  ContextMap h1 c1 <> ContextMap h2 c2 = ContextMap (h1 || h2) (c1 <> c2)
+instance Monoid ContextMap where
+  mempty = ContextMap False []
 instance Show ContextMap where show _ = "<context map>"
 instance NFData ContextMap where rnf = rwhnf
 
@@ -116,10 +138,14 @@ instance NFData ContextMap where rnf = rwhnf
 -- as a Shake rule.
 getContextMap :: ParsedModule -> ContextMap
 getContextMap pm =
-  groupedChunks 10 ImportGroup rangeOf getImportContext hsmodImports
-    <> groupedChunks 5 DeclarationGroup rangeOf getDeclContext hsmodDecls
+  ContextMap (isJust hsmodName) $
+    -- These denote the size of the "jumps" of the cursor when traversing the AST.
+    -- Reduces the amount of data we have to look at with syb.
+  moduleChunk
+    <> groupedChunks 10 ImportGroup rangeOf getImportContext hsmodImports
+    <> groupedChunks 4 DeclarationGroup rangeOf getDeclContext hsmodDecls
   where
-    HsModule {hsmodImports, hsmodDecls} =
+    HsModule {hsmodName, hsmodImports, hsmodDecls} =
       unLoc (pm_parsed_source pm)
 
 #if MIN_VERSION_ghc(9,9,0)
@@ -130,47 +156,59 @@ rangeOf :: GenLocated (SrcSpanAnn' a) e -> Maybe Range
 rangeOf = srcSpanToRange . getLocA
 #endif
 
+getHeaderContext :: Data a => a -> Range -> ContextResult
+getHeaderContext decl query =
+  gather
+    (<>)
+    ((mempty, False) `mkQ` modNameQ query)
+    decl
+
 getImportContext :: LImportDecl GhcPs -> Range -> ContextResult
 getImportContext imports query =
-  everythingBut
+  gather
     (<>)
     ((mempty, False) `mkQ` importQ query)
     imports
 
 getDeclContext :: LHsDecl GhcPs -> Range -> ContextResult
 getDeclContext declarations query =
-  everythingBut
+  gather
     (<>)
     ((mempty, False) `mkQ` sigQ query `extQ` bindQ query `extQ` declQ query)
     declarations
 
 -- * Querying
 
+-- | Returns 'True' when the parsed module already has a @module ... where@
+-- declaration. Used downstream to suppress the module header snippet.
+contextHasModuleHeader :: ContextMap -> Bool
+contextHasModuleHeader (ContextMap h _) = h
+
 -- | Look up the completion context at a given position.
 -- Returns the innermost (most specific) context that contains the position.
 --
 -- Only the 'ContextChunks' up to and including the chunk containing the
 -- query position are forced; later chunks remain as unevaluated thunks.
 getContext :: ContextMap -> PositionResult Position -> Context
-getContext (ContextMap chunks) query =
-  case searchChunks True chunks of
-    (groups, NoContext)        -> TopContext groups
+getContext (ContextMap _ chunks) query =
+  case searchChunks HeaderGroup chunks mempty of
+    (groups, NoContext)        -> TopContext $ nub groups
     (_, ContextResult _ found) -> found
   where
     (qLo, qHi) = case query of
       PositionExact p   -> (p, p)
       PositionRange l u -> (l, u)
 
-    searchChunks :: Bool -> [ContextChunk] -> ([ContextGroup], ContextResult)
-    searchChunks _ [] = ([], mempty)
-    searchChunks firstChunk (Chunk cLo cHi group contextOf : rest)
+    searchChunks :: ContextGroup -> [ContextChunk] -> ([ContextGroup], ContextResult) -> ([ContextGroup], ContextResult)
+    searchChunks _ [] !acc = acc
+    searchChunks lastChunk (Chunk cLo cHi group contextOf : rest) !acc
       | -- query is past this chunk (line-only comparison so cursors
         -- past the last column on the final line still match)
-        _line qLo > _line cHi = searchChunks False rest
+        _line qLo > _line cHi = searchChunks group rest acc
       | -- query is before this chunk
-        qHi < cLo = (if firstChunk then [HeaderGroup] else [], mempty)
+        qHi < cLo = ([lastChunk, group], mempty) <> acc
         -- this chunk is relevant, emit the group and all relevant intervals
-      | otherwise  = ([group], contextOf (Range qLo qHi)) <> searchChunks False rest
+      | otherwise = searchChunks group rest (([group], contextOf (Range qLo qHi)) <> acc)
 
 -- * SYB queries types
 
@@ -200,6 +238,9 @@ declQ query (L (locA -> ss) decl) = case srcSpanToRange ss of
     SpliceD {} -> (ContextResult range (TopContext []), True)
     _          -> (ContextResult range DefaultContext, True)  -- DefD, WarningD, AnnD, RuleD, DocD, KindSigD
 
+modNameQ :: Range -> XRec GhcPs ModuleName -> (ContextResult, Bool)
+modNameQ = contextual (TopContext [HeaderGroup]) True
+
 sigQ :: Range -> LSig GhcPs -> (ContextResult, Bool)
 sigQ = contextual TypeContext True
 
@@ -247,3 +288,13 @@ instance Pretty ContextGroup where
     HeaderGroup -> "header"
     ImportGroup -> "imports"
     DeclarationGroup -> "declarations"
+
+-- | Variation of @Data.Generics.Schemes.everythingBut@, but uses foldl'.
+gather :: forall r. (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r
+gather k f = go
+  where
+    go :: GenericQ r
+    go x = let (v, stop) = f x
+           in if stop
+                then v
+                else foldl' k v (gmapQ go x)

ghcide/src/Development/IDE/Plugin/Completions/Logic.hs

@@ -453,6 +453,7 @@ getCompletions
     -> IdeOptions
     -> CachedCompletions
     -> Context
+    -> Bool
     -> Maybe (HieAstResult, PositionMapping)
     -> (Bindings, PositionMapping)
     -> PosPrefixInfo
@@ -466,6 +467,7 @@ getCompletions
     ideOpts
     CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}
     context
+    hasModuleHeader
     maybe_ast_res
     (localBindings, bmapping)
     prefixInfo@(PosPrefixInfo { fullLine, prefixScope, prefixText })
@@ -636,7 +638,7 @@ getCompletions
       filtTopContextCompls :: [Context.ContextGroup] -> [Scored CompletionItem]
       filtTopContextCompls groups
           | T.null prefixScope
-          = Fuzzy.filter chunkSize maxC fullPrefix (getContextSnippets groups) (view L.label)
+          = Fuzzy.filter chunkSize maxC fullPrefix (getContextSnippets hasModuleHeader groups) (view L.label)
           | otherwise = []
 
       -- We use this ordering to alphabetically sort suggestions while respecting

ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs

@@ -18,9 +18,14 @@ data SnippetCompletion = SnippetCompletion
   , snippetContents :: {-# UNPACK #-} !Text
   }
 
-getContextSnippets :: [ContextGroup] -> [CompletionItem]
-getContextSnippets [] = concatMap (fmap mkSnippetCompletion . snd) topContextSnippets
-getContextSnippets groups = concatMap (fmap mkSnippetCompletion . concat . maybeToList . (`lookup` topContextSnippets)) groups
+getContextSnippets :: Bool -> [ContextGroup] -> [CompletionItem]
+getContextSnippets hasModuleHeader groups =
+  let tbl = if hasModuleHeader
+              then filter ((/= HeaderGroup) . fst) topContextSnippets
+              else topContextSnippets
+  in fmap mkSnippetCompletion $ case groups of
+    [] -> concatMap snd tbl
+    _  -> concatMap (concat . maybeToList . (`lookup` tbl)) groups
 
 topContextSnippets :: [(ContextGroup, [SnippetCompletion])]
 topContextSnippets =