Cleanup Context module a bit

Author: crtschin

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

@@ -24,9 +24,9 @@ import           Development.IDE.GHC.Compat           hiding (getContext)
 import           GHC.Generics                         (Generic)
 import           GHC.Hs                               (HasLoc)
 
--- | 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
+-- | 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.
 data Context
   = TypeContext
   | ValueContext
@@ -53,22 +53,6 @@ data ContextGroup
   | DeclarationGroup
   deriving (Show, Eq, Ord)
 
-instance Pretty Context where
-  pretty = \case
-    TypeContext -> "type context"
-    ValueContext -> "value context"
-    ImportContext mod -> "import context " <> pretty mod
-    ImportListContext mod -> "import explicit context " <> pretty mod
-    ImportHidingContext mod -> "import hiding context " <> pretty mod
-    TopContext cg -> "top context " <> pretty cg
-    DefaultContext -> "unknown context"
-
-instance Pretty ContextGroup where
-  pretty = \case
-    HeaderGroup -> "header"
-    ImportGroup -> "imports"
-    DeclarationGroup -> "declarations"
-
 data GetContextMap = GetContextMap
   deriving (Eq, Show, Generic)
 instance Hashable GetContextMap
@@ -101,26 +85,27 @@ groupedChunks n group getPos locate xs = ContextMap $ go xs
               , context
               } : go rest
 
-data ContextResult
-  = NoContext
-  | ContextResult Range Context
+-- | 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
+instance Monoid ContextResult where mempty = NoContext
+instance Semigroup ContextResult where (<>) = tighten
 
-instance Semigroup ContextResult where
-  NoContext <> b = b
-  a <> NoContext = a
-  ar@(ContextResult a _) <> br@(ContextResult b _) = if a `dominates` b
-    then br
-    else ar
-
-instance Monoid ContextResult where
-  mempty = NoContext
+tighten :: ContextResult -> ContextResult -> ContextResult
+tighten NoContext b = b
+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)
 instance Show ContextMap where show _ = "<context map>"
 instance NFData ContextMap where rnf = rwhnf
 
--- | Build a 'ContextMap' from a parsed module.
+-- * Building
+
+-- | Build a @ContextMap@ from a parsed module.
 --
 -- Walks module header, exports, imports, and top-level declarations
 -- (one level into class bodies). Built once per file edit and cached
@@ -136,14 +121,6 @@ getContextMap pm =
 rangeOf :: HasLoc a => a -> Maybe Range
 rangeOf = srcSpanToRange . locA
 
-contextual :: HasLoc a => Context -> Bool -> Range -> a -> (ContextResult, Bool)
-contextual context shouldStop query s =
-  let range = rangeOf s
-   in case range of
-        Nothing -> (mempty, True)
-        Just range | outside query range -> (mempty, True)
-        Just range -> (ContextResult range context, shouldStop)
-
 getImportContext :: LImportDecl GhcPs -> Range -> ContextResult
 getImportContext imports query =
   everythingBut
@@ -158,6 +135,35 @@ getDeclContext declarations query =
     ((mempty, False) `mkQ` sigQ query `extQ` bindQ query `extQ` declQ query)
     declarations
 
+-- * Querying
+
+-- | 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
+    (_, 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)
+      | -- query is past this chunk
+        qLo > cHi = searchChunks False rest
+      | -- query is before this chunk
+        qHi < cLo = (if firstChunk then [HeaderGroup] else [], mempty)
+        -- this chunk is relevant, emit the group and all relevant intervals
+      | otherwise  = ([group], contextOf (Range qLo qHi)) <> searchChunks False rest
+
+-- * SYB queries types
+
 importQ :: Range -> LImportDecl GhcPs -> (ContextResult, Bool)
 importQ query impDecl'@(L _ impDecl) =
   let importModuleName = T.pack $ moduleNameString $ unLoc $ ideclName impDecl
@@ -190,33 +196,34 @@ sigQ = contextual TypeContext True
 bindQ :: Range -> LHsBind GhcPs -> (ContextResult, Bool)
 bindQ = contextual ValueContext False
 
+contextual :: HasLoc a => Context -> Bool -> Range -> a -> (ContextResult, Bool)
+contextual context shouldStop query s =
+  let range = rangeOf s
+   in case range of
+        Nothing -> (mempty, True)
+        Just range | outside query range -> (mempty, True)
+        Just range -> (ContextResult range context, shouldStop)
+
+-- * Helpers
+
 dominates :: Range -> Range -> Bool
 dominates (Range s e) (Range qs qe) = s <= qs && qe <= e
 
 outside :: Range -> Range -> Bool
 outside (Range ps pe) (Range qs qe) = pe < qs || ps > qe
 
--- | 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
-    (_, ContextResult _ found) -> found
-  where
-    (qLo, qHi) = case query of
-      PositionExact p   -> (p, p)
-      PositionRange l u -> (l, u)
+instance Pretty Context where
+  pretty = \case
+    TypeContext -> "type context"
+    ValueContext -> "value context"
+    ImportContext mod -> "import context " <> pretty mod
+    ImportListContext mod -> "import explicit context " <> pretty mod
+    ImportHidingContext mod -> "import hiding context " <> pretty mod
+    TopContext cg -> "top context " <> pretty cg
+    DefaultContext -> "unknown context"
 
-    searchChunks :: Bool -> [ContextChunk] -> ([ContextGroup], ContextResult)
-    searchChunks _ [] = ([], mempty)
-    searchChunks firstChunk (Chunk cLo cHi group contextOf : rest)
-      | -- query is past this chunk
-        qLo > cHi = searchChunks False rest
-      | -- query is before this chunk
-        qHi < cLo = (if firstChunk then [HeaderGroup] else [], mempty)
-        -- this chunk is relevant, emit the group and all relevant intervals
-      | otherwise  = ([group], contextOf (Range qLo qHi)) <> searchChunks False rest
+instance Pretty ContextGroup where
+  pretty = \case
+    HeaderGroup -> "header"
+    ImportGroup -> "imports"
+    DeclarationGroup -> "declarations"