{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiWayIf            #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE ViewPatterns          #-}

-- | Provides code actions to add missing pragmas (whenever GHC suggests to)
module Ide.Plugin.Pragmas
  ( suggestPragmaDescriptor
  , completionDescriptor
  , suggestDisableWarningDescriptor
  -- For testing
  , validPragmas
  , AppearWhere(..)
  ) where

import           Control.Lens                       hiding (List)
import           Control.Monad.IO.Class             (MonadIO (liftIO))
import           Control.Monad.Trans.Class          (lift)
import           Data.List.Extra                    (nubOrdOn)
import qualified Data.Map                           as M
import           Data.Maybe                         (catMaybes)
import qualified Data.Text                          as T
import           Development.IDE
import           Development.IDE.Core.Compile       (sourceParser,
                                                     sourceTypecheck)
import           Development.IDE.Core.PluginUtils
import           Development.IDE.GHC.Compat
import           Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority)
import qualified Development.IDE.Spans.Pragmas      as Pragmas
import           Ide.Plugin.Error
import           Ide.Types
import qualified Language.LSP.Protocol.Lens         as L
import qualified Language.LSP.Protocol.Message      as LSP
import qualified Language.LSP.Protocol.Types        as LSP
import qualified Language.LSP.Server                as LSP
import qualified Language.LSP.VFS                   as VFS
import qualified Text.Fuzzy                         as Fuzzy

-- ---------------------------------------------------------------------

suggestPragmaDescriptor :: PluginId -> PluginDescriptor IdeState
suggestPragmaDescriptor :: PluginId -> PluginDescriptor IdeState
suggestPragmaDescriptor PluginId
plId = (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
"Provides a code action to add missing LANGUAGE pragmas")
  { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction suggestPragmaProvider
  , pluginPriority = defaultPluginPriority + 1000
  }

completionDescriptor :: PluginId -> PluginDescriptor IdeState
completionDescriptor :: PluginId -> PluginDescriptor IdeState
completionDescriptor PluginId
plId = (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
"Provides completion of LANGAUGE pragmas")
  { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCompletion completion
  , pluginPriority = ghcideCompletionsPluginPriority + 1
  }

suggestDisableWarningDescriptor :: PluginId -> PluginDescriptor IdeState
suggestDisableWarningDescriptor :: PluginId -> PluginDescriptor IdeState
suggestDisableWarningDescriptor PluginId
plId = (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
"Provides a code action to disable warnings")
  { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction suggestDisableWarningProvider
    -- #3636 Suggestions to disable warnings should appear last.
  , pluginPriority = 0
  }

-- ---------------------------------------------------------------------
-- | Title and pragma
type PragmaEdit = (T.Text, Pragma)

data Pragma = LangExt T.Text | OptGHC T.Text
  deriving (Int -> Pragma -> ShowS
[Pragma] -> ShowS
Pragma -> String
(Int -> Pragma -> ShowS)
-> (Pragma -> String) -> ([Pragma] -> ShowS) -> Show Pragma
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pragma -> ShowS
showsPrec :: Int -> Pragma -> ShowS
$cshow :: Pragma -> String
show :: Pragma -> String
$cshowList :: [Pragma] -> ShowS
showList :: [Pragma] -> ShowS
Show, Pragma -> Pragma -> Bool
(Pragma -> Pragma -> Bool)
-> (Pragma -> Pragma -> Bool) -> Eq Pragma
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pragma -> Pragma -> Bool
== :: Pragma -> Pragma -> Bool
$c/= :: Pragma -> Pragma -> Bool
/= :: Pragma -> Pragma -> Bool
Eq, Eq Pragma
Eq Pragma =>
(Pragma -> Pragma -> Ordering)
-> (Pragma -> Pragma -> Bool)
-> (Pragma -> Pragma -> Bool)
-> (Pragma -> Pragma -> Bool)
-> (Pragma -> Pragma -> Bool)
-> (Pragma -> Pragma -> Pragma)
-> (Pragma -> Pragma -> Pragma)
-> Ord Pragma
Pragma -> Pragma -> Bool
Pragma -> Pragma -> Ordering
Pragma -> Pragma -> Pragma
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Pragma -> Pragma -> Ordering
compare :: Pragma -> Pragma -> Ordering
$c< :: Pragma -> Pragma -> Bool
< :: Pragma -> Pragma -> Bool
$c<= :: Pragma -> Pragma -> Bool
<= :: Pragma -> Pragma -> Bool
$c> :: Pragma -> Pragma -> Bool
> :: Pragma -> Pragma -> Bool
$c>= :: Pragma -> Pragma -> Bool
>= :: Pragma -> Pragma -> Bool
$cmax :: Pragma -> Pragma -> Pragma
max :: Pragma -> Pragma -> Pragma
$cmin :: Pragma -> Pragma -> Pragma
min :: Pragma -> Pragma -> Pragma
Ord)

suggestPragmaProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
suggestPragmaProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
suggestPragmaProvider = (Maybe DynFlags -> Diagnostic -> [PragmaEdit])
-> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
mkCodeActionProvider Maybe DynFlags -> Diagnostic -> [PragmaEdit]
suggest

suggestDisableWarningProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
suggestDisableWarningProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
suggestDisableWarningProvider = (Maybe DynFlags -> Diagnostic -> [PragmaEdit])
-> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
mkCodeActionProvider ((Maybe DynFlags -> Diagnostic -> [PragmaEdit])
 -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction)
-> (Maybe DynFlags -> Diagnostic -> [PragmaEdit])
-> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
forall a b. (a -> b) -> a -> b
$ (Diagnostic -> [PragmaEdit])
-> Maybe DynFlags -> Diagnostic -> [PragmaEdit]
forall a b. a -> b -> a
const Diagnostic -> [PragmaEdit]
suggestDisableWarning

mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit])
-> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
mkCodeActionProvider Maybe DynFlags -> Diagnostic -> [PragmaEdit]
mkSuggest IdeState
state PluginId
_plId
  (LSP.CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ LSP.TextDocumentIdentifier{ $sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri = Uri
uri } Range
_ (LSP.CodeActionContext [Diagnostic]
diags Maybe [CodeActionKind]
_monly Maybe CodeActionTriggerKind
_)) = do
    NormalizedFilePath
normalizedFilePath <- Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
    -- ghc session to get some dynflags even if module isn't parsed
    (HscEnvEq -> HscEnv
hscEnv -> HscEnv -> DynFlags
hsc_dflags -> DynFlags
sessionDynFlags, PositionMapping
_) <-
      String
-> IdeState
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError (LspM Config) (HscEnvEq, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"Pragmas.GhcSession" IdeState
state (ExceptT PluginError Action (HscEnvEq, PositionMapping)
 -> ExceptT PluginError (LspM Config) (HscEnvEq, PositionMapping))
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError (LspM Config) (HscEnvEq, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GhcSession
-> NormalizedFilePath
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GhcSession
GhcSession NormalizedFilePath
normalizedFilePath
    (UTCTime
_, Maybe Text
fileContents) <- IO (UTCTime, Maybe Text)
-> ExceptT PluginError (LspM Config) (UTCTime, Maybe Text)
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTCTime, Maybe Text)
 -> ExceptT PluginError (LspM Config) (UTCTime, Maybe Text))
-> IO (UTCTime, Maybe Text)
-> ExceptT PluginError (LspM Config) (UTCTime, Maybe Text)
forall a b. (a -> b) -> a -> b
$ String
-> IdeState
-> Action (UTCTime, Maybe Text)
-> IO (UTCTime, Maybe Text)
forall a. String -> IdeState -> Action a -> IO a
runAction String
"Pragmas.GetFileContents" IdeState
state (Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text))
-> Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
normalizedFilePath
    Maybe ParsedModule
parsedModule <- IO (Maybe ParsedModule)
-> ExceptT PluginError (LspM Config) (Maybe ParsedModule)
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ParsedModule)
 -> ExceptT PluginError (LspM Config) (Maybe ParsedModule))
-> IO (Maybe ParsedModule)
-> ExceptT PluginError (LspM Config) (Maybe ParsedModule)
forall a b. (a -> b) -> a -> b
$ String
-> IdeState
-> Action (Maybe ParsedModule)
-> IO (Maybe ParsedModule)
forall a. String -> IdeState -> Action a -> IO a
runAction String
"Pragmas.GetParsedModule" IdeState
state (Action (Maybe ParsedModule) -> IO (Maybe ParsedModule))
-> Action (Maybe ParsedModule) -> IO (Maybe ParsedModule)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (Maybe ParsedModule)
getParsedModule NormalizedFilePath
normalizedFilePath
    let parsedModuleDynFlags :: Maybe DynFlags
parsedModuleDynFlags = ModSummary -> DynFlags
ms_hspp_opts (ModSummary -> DynFlags)
-> (ParsedModule -> ModSummary) -> ParsedModule -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> ModSummary
pm_mod_summary (ParsedModule -> DynFlags) -> Maybe ParsedModule -> Maybe DynFlags
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ParsedModule
parsedModule
        nextPragmaInfo :: NextPragmaInfo
nextPragmaInfo = DynFlags -> Maybe Text -> NextPragmaInfo
Pragmas.getNextPragmaInfo DynFlags
sessionDynFlags Maybe Text
fileContents
        pedits :: [PragmaEdit]
pedits = ((PragmaEdit -> Pragma) -> [PragmaEdit] -> [PragmaEdit]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn PragmaEdit -> Pragma
forall a b. (a, b) -> b
snd ([PragmaEdit] -> [PragmaEdit])
-> ([[PragmaEdit]] -> [PragmaEdit])
-> [[PragmaEdit]]
-> [PragmaEdit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[PragmaEdit]] -> [PragmaEdit]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PragmaEdit]] -> [PragmaEdit]) -> [[PragmaEdit]] -> [PragmaEdit]
forall a b. (a -> b) -> a -> b
$ Maybe DynFlags -> Diagnostic -> [PragmaEdit]
mkSuggest Maybe DynFlags
parsedModuleDynFlags (Diagnostic -> [PragmaEdit]) -> [Diagnostic] -> [[PragmaEdit]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Diagnostic]
diags)
    ([Command |? CodeAction] |? Null)
-> ExceptT
     PluginError (LspM Config) ([Command |? CodeAction] |? Null)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure  (([Command |? CodeAction] |? Null)
 -> ExceptT
      PluginError (LspM Config) ([Command |? CodeAction] |? Null))
-> ([Command |? CodeAction] |? Null)
-> ExceptT
     PluginError (LspM Config) ([Command |? CodeAction] |? Null)
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> [Command |? CodeAction] |? Null
forall a b. a -> a |? b
LSP.InL ([Command |? CodeAction] -> [Command |? CodeAction] |? Null)
-> [Command |? CodeAction] -> [Command |? CodeAction] |? Null
forall a b. (a -> b) -> a -> b
$ Uri -> NextPragmaInfo -> PragmaEdit -> Command |? CodeAction
pragmaEditToAction Uri
uri NextPragmaInfo
nextPragmaInfo (PragmaEdit -> Command |? CodeAction)
-> [PragmaEdit] -> [Command |? CodeAction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PragmaEdit]
pedits



-- | Add a Pragma to the given URI at the top of the file.
-- It is assumed that the pragma name is a valid pragma,
-- thus, not validated.
pragmaEditToAction :: Uri -> Pragmas.NextPragmaInfo -> PragmaEdit -> (LSP.Command LSP.|? LSP.CodeAction)
pragmaEditToAction :: Uri -> NextPragmaInfo -> PragmaEdit -> Command |? CodeAction
pragmaEditToAction Uri
uri Pragmas.NextPragmaInfo{ Int
nextPragmaLine :: Int
$sel:nextPragmaLine:NextPragmaInfo :: NextPragmaInfo -> Int
nextPragmaLine, Maybe LineSplitTextEdits
lineSplitTextEdits :: Maybe LineSplitTextEdits
$sel:lineSplitTextEdits:NextPragmaInfo :: NextPragmaInfo -> Maybe LineSplitTextEdits
lineSplitTextEdits } (Text
title, Pragma
p) =
  CodeAction -> Command |? CodeAction
forall a b. b -> a |? b
LSP.InR (CodeAction -> Command |? CodeAction)
-> CodeAction -> Command |? CodeAction
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe CodeActionKind
-> Maybe [Diagnostic]
-> Maybe Bool
-> Maybe (Rec (("reason" .== Text) .+ Empty))
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
LSP.CodeAction Text
title (CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just CodeActionKind
LSP.CodeActionKind_QuickFix) ([Diagnostic] -> Maybe [Diagnostic]
forall a. a -> Maybe a
Just []) Maybe Bool
forall a. Maybe a
Nothing Maybe (Rec (("reason" .== Text) .+ Empty))
Maybe (Rec ('R '["reason" ':-> Text]))
forall a. Maybe a
Nothing (WorkspaceEdit -> Maybe WorkspaceEdit
forall a. a -> Maybe a
Just WorkspaceEdit
edit) Maybe Command
forall a. Maybe a
Nothing Maybe Value
forall a. Maybe a
Nothing
  where
    render :: Pragma -> Text
render (OptGHC Text
x)  = Text
"{-# OPTIONS_GHC -Wno-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #-}\n"
    render (LangExt Text
x) = Text
"{-# LANGUAGE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #-}\n"
    pragmaInsertPosition :: Position
pragmaInsertPosition = UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nextPragmaLine) UInt
0
    pragmaInsertRange :: Range
pragmaInsertRange = Position -> Position -> Range
Range Position
pragmaInsertPosition Position
pragmaInsertPosition
    -- workaround the fact that for some reason lsp-test applies text
    -- edits in reverse order than lsp (tried in both coc.nvim and vscode)
    textEdits :: [TextEdit]
textEdits =
      if | Just (Pragmas.LineSplitTextEdits TextEdit
insertTextEdit TextEdit
deleteTextEdit) <- Maybe LineSplitTextEdits
lineSplitTextEdits
         , let LSP.TextEdit{ Range
_range :: Range
$sel:_range:TextEdit :: TextEdit -> Range
_range, Text
_newText :: Text
$sel:_newText:TextEdit :: TextEdit -> Text
_newText } = TextEdit
insertTextEdit ->
             [Range -> Text -> TextEdit
LSP.TextEdit Range
_range (Pragma -> Text
render Pragma
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
_newText), TextEdit
deleteTextEdit]
         | Bool
otherwise -> [Range -> Text -> TextEdit
LSP.TextEdit Range
pragmaInsertRange (Pragma -> Text
render Pragma
p)]

    edit :: WorkspaceEdit
edit =
      Maybe (Map Uri [TextEdit])
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
LSP.WorkspaceEdit
        (Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a. a -> Maybe a
Just (Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit]))
-> Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a b. (a -> b) -> a -> b
$ Uri -> [TextEdit] -> Map Uri [TextEdit]
forall k a. k -> a -> Map k a
M.singleton Uri
uri [TextEdit]
textEdits)
        Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing
        Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
forall a. Maybe a
Nothing

suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
suggest Maybe DynFlags
dflags Diagnostic
diag =
  Maybe DynFlags -> Diagnostic -> [PragmaEdit]
suggestAddPragma Maybe DynFlags
dflags Diagnostic
diag

-- ---------------------------------------------------------------------

suggestDisableWarning :: Diagnostic -> [PragmaEdit]
suggestDisableWarning :: Diagnostic -> [PragmaEdit]
suggestDisableWarning Diagnostic {Maybe (Int32 |? Text)
_code :: Maybe (Int32 |? Text)
$sel:_code:Diagnostic :: Diagnostic -> Maybe (Int32 |? Text)
_code}
  | Just (LSP.InR (Text -> Text -> Maybe Text
T.stripPrefix Text
"-W" -> Just Text
w)) <- Maybe (Int32 |? Text)
_code
  , Text
w Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
warningBlacklist =
    PragmaEdit -> [PragmaEdit]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"Disable \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
w Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" warnings", Text -> Pragma
OptGHC Text
w)
  | Bool
otherwise = []

-- Don't suggest disabling type errors as a solution to all type errors
warningBlacklist :: [T.Text]
-- warningBlacklist = []
warningBlacklist :: [Text]
warningBlacklist = [Text
"deferred-type-errors"]

-- ---------------------------------------------------------------------

-- | Offer to add a missing Language Pragma to the top of a file.
-- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'.
suggestAddPragma :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
suggestAddPragma :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
suggestAddPragma Maybe DynFlags
mDynflags Diagnostic {Text
_message :: Text
$sel:_message:Diagnostic :: Diagnostic -> Text
_message, Maybe Text
_source :: Maybe Text
$sel:_source:Diagnostic :: Diagnostic -> Maybe Text
_source}
    | Maybe Text
_source Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
sourceTypecheck Bool -> Bool -> Bool
|| Maybe Text
_source Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
sourceParser = Text -> [PragmaEdit]
genPragma Text
_message
  where
    genPragma :: Text -> [PragmaEdit]
genPragma Text
target =
      [(Text
"Add \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"", Text -> Pragma
LangExt Text
r) | Text
r <- Text -> [Text]
findPragma Text
target, Text
r Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
disabled]
    disabled :: [Text]
disabled
      | Just DynFlags
dynFlags <- Maybe DynFlags
mDynflags =
        -- GHC does not export 'OnOff', so we have to view it as string
        [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> [Text]) -> [Maybe Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
"Off " (Text -> Maybe Text)
-> (OnOff Extension -> Text) -> OnOff Extension -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnOff Extension -> Text
forall a. Outputable a => a -> Text
printOutputable (OnOff Extension -> Maybe Text)
-> [OnOff Extension] -> [Maybe Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> [OnOff Extension]
extensions DynFlags
dynFlags
      | Bool
otherwise =
        -- When the module failed to parse, we don't have access to its
        -- dynFlags. In that case, simply don't disable any pragmas.
        []
suggestAddPragma Maybe DynFlags
_ Diagnostic
_ = []

-- | Find all Pragmas are an infix of the search term.
findPragma :: T.Text -> [T.Text]
findPragma :: Text -> [Text]
findPragma Text
str = (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Text]
check [Text]
possiblePragmas
  where
    check :: Text -> [Text]
check Text
p = [Text
p | Text -> Text -> Bool
T.isInfixOf Text
p Text
str]

    -- We exclude the Strict extension as it causes many false positives, see
    -- the discussion at https://github.com/haskell/ghcide/pull/638
    --
    -- We don't include the No- variants, as GHC never suggests disabling an
    -- extension in an error message.
    possiblePragmas :: [T.Text]
    possiblePragmas :: [Text]
possiblePragmas =
       [ Text
name
       | FlagSpec{flagSpecName :: forall flag. FlagSpec flag -> String
flagSpecName = String -> Text
T.pack -> Text
name} <- [FlagSpec Extension]
xFlags
       , Text
"Strict" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
name
       ]

-- | All language pragmas, including the No- variants
allPragmas :: [T.Text]
allPragmas :: [Text]
allPragmas =
  [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Text
name, Text
"No" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name]
    | FlagSpec{flagSpecName :: forall flag. FlagSpec flag -> String
flagSpecName = String -> Text
T.pack -> Text
name} <- [FlagSpec Extension]
xFlags
    ]
  [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<>
  -- These pragmas are not part of xFlags as they are not reversable
  -- by prepending "No".
  [ -- Safe Haskell
    Text
"Unsafe"
  , Text
"Trustworthy"
  , Text
"Safe"

    -- Language Version Extensions
  , Text
"Haskell98"
  , Text
"Haskell2010"
  , Text
"GHC2021"
  ]

-- ---------------------------------------------------------------------
flags :: [T.Text]
flags :: [Text]
flags = (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> ShowS -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
stripLeading Char
'-') ([String] -> [Text]) -> [String] -> [Text]
forall a b. (a -> b) -> a -> b
$ Bool -> [String]
flagsForCompletion Bool
False

completion :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion
completion :: PluginMethodHandler IdeState 'Method_TextDocumentCompletion
completion IdeState
_ide PluginId
_ MessageParams 'Method_TextDocumentCompletion
complParams = do
    let (LSP.TextDocumentIdentifier Uri
uri) = CompletionParams
MessageParams 'Method_TextDocumentCompletion
complParams CompletionParams
-> Getting
     TextDocumentIdentifier CompletionParams TextDocumentIdentifier
-> TextDocumentIdentifier
forall s a. s -> Getting a s a -> a
^. Getting
  TextDocumentIdentifier CompletionParams TextDocumentIdentifier
forall s a. HasTextDocument s a => Lens' s a
Lens' CompletionParams TextDocumentIdentifier
L.textDocument
        position :: Position
position = CompletionParams
MessageParams 'Method_TextDocumentCompletion
complParams CompletionParams
-> Getting Position CompletionParams Position -> Position
forall s a. s -> Getting a s a -> a
^. Getting Position CompletionParams Position
forall s a. HasPosition s a => Lens' s a
Lens' CompletionParams Position
L.position
    Maybe VirtualFile
contents <- LspM Config (Maybe VirtualFile)
-> ExceptT PluginError (LspM Config) (Maybe VirtualFile)
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspM Config (Maybe VirtualFile)
 -> ExceptT PluginError (LspM Config) (Maybe VirtualFile))
-> LspM Config (Maybe VirtualFile)
-> ExceptT PluginError (LspM Config) (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ NormalizedUri -> LspM Config (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
LSP.getVirtualFile (NormalizedUri -> LspM Config (Maybe VirtualFile))
-> NormalizedUri -> LspM Config (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri
    ([CompletionItem] -> [CompletionItem] |? (CompletionList |? Null))
-> ExceptT PluginError (LspM Config) [CompletionItem]
-> ExceptT
     PluginError
     (LspM Config)
     ([CompletionItem] |? (CompletionList |? Null))
forall a b.
(a -> b)
-> ExceptT PluginError (LspM Config) a
-> ExceptT PluginError (LspM Config) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([CompletionItem] -> [CompletionItem] |? (CompletionList |? Null)
forall a b. a -> a |? b
LSP.InL) (ExceptT PluginError (LspM Config) [CompletionItem]
 -> ExceptT
      PluginError
      (LspM Config)
      ([CompletionItem] |? (CompletionList |? Null)))
-> ExceptT PluginError (LspM Config) [CompletionItem]
-> ExceptT
     PluginError
     (LspM Config)
     ([CompletionItem] |? (CompletionList |? Null))
forall a b. (a -> b) -> a -> b
$ case (Maybe VirtualFile
contents, Uri -> Maybe String
uriToFilePath' Uri
uri) of
        (Just VirtualFile
cnts, Just String
_path) ->
            Maybe PosPrefixInfo -> [CompletionItem]
result (Maybe PosPrefixInfo -> [CompletionItem])
-> ExceptT PluginError (LspM Config) (Maybe PosPrefixInfo)
-> ExceptT PluginError (LspM Config) [CompletionItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position
-> VirtualFile
-> ExceptT PluginError (LspM Config) (Maybe PosPrefixInfo)
forall (m :: * -> *).
Monad m =>
Position -> VirtualFile -> m (Maybe PosPrefixInfo)
VFS.getCompletionPrefix Position
position VirtualFile
cnts
            where
                result :: Maybe PosPrefixInfo -> [CompletionItem]
result (Just PosPrefixInfo
pfix)
                    | Text
"{-# language" Text -> Text -> Bool
`T.isPrefixOf` Text
line
                    = (Text -> CompletionItem) -> [Text] -> [CompletionItem]
forall a b. (a -> b) -> [a] -> [b]
map Text -> CompletionItem
buildCompletion
                        (Text -> [Text] -> [Text]
forall s. TextualMonoid s => s -> [s] -> [s]
Fuzzy.simpleFilter (PosPrefixInfo -> Text
VFS.prefixText PosPrefixInfo
pfix) [Text]
allPragmas)
                    | Text
"{-# options_ghc" Text -> Text -> Bool
`T.isPrefixOf` Text
line
                    =  (Text -> CompletionItem) -> [Text] -> [CompletionItem]
forall a b. (a -> b) -> [a] -> [b]
map Text -> CompletionItem
buildCompletion
                        (Text -> [Text] -> [Text]
forall s. TextualMonoid s => s -> [s] -> [s]
Fuzzy.simpleFilter (PosPrefixInfo -> Text
VFS.prefixText PosPrefixInfo
pfix) [Text]
flags)
                    | Text
"{-#" Text -> Text -> Bool
`T.isPrefixOf` Text
line
                    = [ Text -> Text -> Text -> CompletionItem
mkPragmaCompl (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffix) Text
b Text
c
                      | (Text
a, Text
b, Text
c, AppearWhere
w) <- [(Text, Text, Text, AppearWhere)]
validPragmas, AppearWhere
w AppearWhere -> AppearWhere -> Bool
forall a. Eq a => a -> a -> Bool
== AppearWhere
NewLine
                      ]
                    | -- Do not suggest any pragmas any of these conditions:
                      -- 1. Current line is a an import
                      -- 2. There is a module name right before the current word.
                      --    Something like `Text.la` shouldn't suggest adding the
                      --    'LANGUAGE' pragma.
                      -- 3. The user has not typed anything yet.
                      Text
"import" Text -> Text -> Bool
`T.isPrefixOf` Text
line Bool -> Bool -> Bool
|| Bool -> Bool
not (Text -> Bool
T.null Text
module_) Bool -> Bool -> Bool
|| Text -> Bool
T.null Text
word
                    = []
                    | Bool
otherwise
                    = [ Text -> Text -> Text -> CompletionItem
mkPragmaCompl (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pragmaTemplate Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffix) Text
matcher Text
detail
                      | (Text
pragmaTemplate, Text
matcher, Text
detail, AppearWhere
appearWhere) <- [(Text, Text, Text, AppearWhere)]
validPragmas
                      , -- Only suggest a pragma that needs its own line if the whole line
                        -- fuzzily matches the pragma
                        (AppearWhere
appearWhere AppearWhere -> AppearWhere -> Bool
forall a. Eq a => a -> a -> Bool
== AppearWhere
NewLine Bool -> Bool -> Bool
&& Text -> Text -> Bool
forall s. TextualMonoid s => s -> s -> Bool
Fuzzy.test Text
line Text
matcher ) Bool -> Bool -> Bool
||
                        -- Only suggest a pragma that appears in the middle of a line when
                        -- the current word is not the only thing in the line and the
                        -- current word fuzzily matches the pragma
                        (AppearWhere
appearWhere AppearWhere -> AppearWhere -> Bool
forall a. Eq a => a -> a -> Bool
== AppearWhere
CanInline Bool -> Bool -> Bool
&& Text
line Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
word Bool -> Bool -> Bool
&& Text -> Text -> Bool
forall s. TextualMonoid s => s -> s -> Bool
Fuzzy.test Text
word Text
matcher)
                      ]
                    where
                        line :: Text
line = Text -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ PosPrefixInfo -> Text
VFS.fullLine PosPrefixInfo
pfix
                        module_ :: Text
module_ = PosPrefixInfo -> Text
VFS.prefixModule PosPrefixInfo
pfix
                        word :: Text
word = PosPrefixInfo -> Text
VFS.prefixText PosPrefixInfo
pfix
                        -- Not completely correct, may fail if more than one "{-#" exist
                        -- , we can ignore it since it rarely happen.
                        prefix :: Text
prefix
                            | Text
"{-# "  Text -> Text -> Bool
`T.isInfixOf` Text
line = Text
""
                            | Text
"{-#"   Text -> Text -> Bool
`T.isInfixOf` Text
line = Text
" "
                            | Bool
otherwise                 = Text
"{-# "
                        suffix :: Text
suffix
                            | Text
" #-}" Text -> Text -> Bool
`T.isSuffixOf` Text
line = Text
""
                            | Text
"#-}"  Text -> Text -> Bool
`T.isSuffixOf` Text
line = Text
" "
                            | Text
"-}"   Text -> Text -> Bool
`T.isSuffixOf` Text
line = Text
" #"
                            | Text
"}"    Text -> Text -> Bool
`T.isSuffixOf` Text
line = Text
" #-"
                            | Bool
otherwise                 = Text
" #-}"
                result Maybe PosPrefixInfo
Nothing = []
        (Maybe VirtualFile, Maybe String)
_ -> [CompletionItem]
-> ExceptT PluginError (LspM Config) [CompletionItem]
forall a. a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CompletionItem]
 -> ExceptT PluginError (LspM Config) [CompletionItem])
-> [CompletionItem]
-> ExceptT PluginError (LspM Config) [CompletionItem]
forall a b. (a -> b) -> a -> b
$ []

-----------------------------------------------------------------------

-- | Pragma where exist
data AppearWhere =
  NewLine
  -- ^Must be on a new line
  | CanInline
  -- ^Can appear in the line
  deriving (Int -> AppearWhere -> ShowS
[AppearWhere] -> ShowS
AppearWhere -> String
(Int -> AppearWhere -> ShowS)
-> (AppearWhere -> String)
-> ([AppearWhere] -> ShowS)
-> Show AppearWhere
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AppearWhere -> ShowS
showsPrec :: Int -> AppearWhere -> ShowS
$cshow :: AppearWhere -> String
show :: AppearWhere -> String
$cshowList :: [AppearWhere] -> ShowS
showList :: [AppearWhere] -> ShowS
Show, AppearWhere -> AppearWhere -> Bool
(AppearWhere -> AppearWhere -> Bool)
-> (AppearWhere -> AppearWhere -> Bool) -> Eq AppearWhere
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AppearWhere -> AppearWhere -> Bool
== :: AppearWhere -> AppearWhere -> Bool
$c/= :: AppearWhere -> AppearWhere -> Bool
/= :: AppearWhere -> AppearWhere -> Bool
Eq)

validPragmas :: [(T.Text, T.Text, T.Text, AppearWhere)]
validPragmas :: [(Text, Text, Text, AppearWhere)]
validPragmas =
  [ (Text
"LANGUAGE ${1:extension}"        , Text
"LANGUAGE"         , Text
"{-# LANGUAGE #-}"         ,   AppearWhere
NewLine)
  , (Text
"OPTIONS_GHC -${1:option}"       , Text
"OPTIONS_GHC"      , Text
"{-# OPTIONS_GHC #-}"      ,   AppearWhere
NewLine)
  , (Text
"INLINE ${1:function}"           , Text
"INLINE"           , Text
"{-# INLINE #-}"           ,   AppearWhere
NewLine)
  , (Text
"NOINLINE ${1:function}"         , Text
"NOINLINE"         , Text
"{-# NOINLINE #-}"         ,   AppearWhere
NewLine)
  , (Text
"INLINABLE ${1:function}"        , Text
"INLINABLE"        , Text
"{-# INLINABLE #-}"        ,   AppearWhere
NewLine)
  , (Text
"WARNING ${1:message}"           , Text
"WARNING"          , Text
"{-# WARNING #-}"          , AppearWhere
CanInline)
  , (Text
"DEPRECATED ${1:message}"        , Text
"DEPRECATED"       , Text
"{-# DEPRECATED  #-}"      , AppearWhere
CanInline)
  , (Text
"ANN ${1:annotation}"            , Text
"ANN"              , Text
"{-# ANN #-}"              ,   AppearWhere
NewLine)
  , (Text
"RULES"                          , Text
"RULES"            , Text
"{-# RULES #-}"            ,   AppearWhere
NewLine)
  , (Text
"SPECIALIZE ${1:function}"       , Text
"SPECIALIZE"       , Text
"{-# SPECIALIZE #-}"       ,   AppearWhere
NewLine)
  , (Text
"SPECIALIZE INLINE ${1:function}", Text
"SPECIALIZE INLINE", Text
"{-# SPECIALIZE INLINE #-}",   AppearWhere
NewLine)
  , (Text
"SPECIALISE ${1:function}"       , Text
"SPECIALISE"       , Text
"{-# SPECIALISE #-}"       ,   AppearWhere
NewLine)
  , (Text
"SPECIALISE INLINE ${1:function}", Text
"SPECIALISE INLINE", Text
"{-# SPECIALISE INLINE #-}",   AppearWhere
NewLine)
  , (Text
"MINIMAL ${1:functions}"         , Text
"MINIMAL"          , Text
"{-# MINIMAL #-}"          , AppearWhere
CanInline)
  , (Text
"UNPACK"                         , Text
"UNPACK"           , Text
"{-# UNPACK #-}"           , AppearWhere
CanInline)
  , (Text
"NOUNPACK"                       , Text
"NOUNPACK"         , Text
"{-# NOUNPACK #-}"         , AppearWhere
CanInline)
  , (Text
"COMPLETE ${1:function}"         , Text
"COMPLETE"         , Text
"{-# COMPLETE #-}"         ,   AppearWhere
NewLine)
  , (Text
"OVERLAPPING"                    , Text
"OVERLAPPING"      , Text
"{-# OVERLAPPING #-}"      , AppearWhere
CanInline)
  , (Text
"OVERLAPPABLE"                   , Text
"OVERLAPPABLE"     , Text
"{-# OVERLAPPABLE #-}"     , AppearWhere
CanInline)
  , (Text
"OVERLAPS"                       , Text
"OVERLAPS"         , Text
"{-# OVERLAPS #-}"         , AppearWhere
CanInline)
  , (Text
"INCOHERENT"                     , Text
"INCOHERENT"       , Text
"{-# INCOHERENT #-}"       , AppearWhere
CanInline)
  ]

mkPragmaCompl :: T.Text -> T.Text -> T.Text -> LSP.CompletionItem
mkPragmaCompl :: Text -> Text -> Text -> CompletionItem
mkPragmaCompl Text
insertText Text
label Text
detail =
  Text
-> Maybe CompletionItemLabelDetails
-> Maybe CompletionItemKind
-> Maybe [CompletionItemTag]
-> Maybe Text
-> Maybe (Text |? MarkupContent)
-> Maybe Bool
-> Maybe Bool
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe InsertTextFormat
-> Maybe InsertTextMode
-> Maybe (TextEdit |? InsertReplaceEdit)
-> Maybe Text
-> Maybe [TextEdit]
-> Maybe [Text]
-> Maybe Command
-> Maybe Value
-> CompletionItem
LSP.CompletionItem Text
label Maybe CompletionItemLabelDetails
forall a. Maybe a
Nothing (CompletionItemKind -> Maybe CompletionItemKind
forall a. a -> Maybe a
Just CompletionItemKind
LSP.CompletionItemKind_Keyword) Maybe [CompletionItemTag]
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
detail)
    Maybe (Text |? MarkupContent)
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
insertText) (InsertTextFormat -> Maybe InsertTextFormat
forall a. a -> Maybe a
Just InsertTextFormat
LSP.InsertTextFormat_Snippet)
    Maybe InsertTextMode
forall a. Maybe a
Nothing Maybe (TextEdit |? InsertReplaceEdit)
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe [TextEdit]
forall a. Maybe a
Nothing Maybe [Text]
forall a. Maybe a
Nothing Maybe Command
forall a. Maybe a
Nothing Maybe Value
forall a. Maybe a
Nothing


stripLeading :: Char -> String -> String
stripLeading :: Char -> ShowS
stripLeading Char
_ [] = []
stripLeading Char
c (Char
s:String
ss)
  | Char
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c = String
ss
  | Bool
otherwise = Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:String
ss


buildCompletion :: T.Text -> LSP.CompletionItem
buildCompletion :: Text -> CompletionItem
buildCompletion Text
label =
  Text
-> Maybe CompletionItemLabelDetails
-> Maybe CompletionItemKind
-> Maybe [CompletionItemTag]
-> Maybe Text
-> Maybe (Text |? MarkupContent)
-> Maybe Bool
-> Maybe Bool
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe InsertTextFormat
-> Maybe InsertTextMode
-> Maybe (TextEdit |? InsertReplaceEdit)
-> Maybe Text
-> Maybe [TextEdit]
-> Maybe [Text]
-> Maybe Command
-> Maybe Value
-> CompletionItem
LSP.CompletionItem Text
label Maybe CompletionItemLabelDetails
forall a. Maybe a
Nothing (CompletionItemKind -> Maybe CompletionItemKind
forall a. a -> Maybe a
Just CompletionItemKind
LSP.CompletionItemKind_Keyword) Maybe [CompletionItemTag]
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
    Maybe (Text |? MarkupContent)
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe InsertTextFormat
forall a. Maybe a
Nothing
    Maybe InsertTextMode
forall a. Maybe a
Nothing Maybe (TextEdit |? InsertReplaceEdit)
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe [TextEdit]
forall a. Maybe a
Nothing Maybe [Text]
forall a. Maybe a
Nothing Maybe Command
forall a. Maybe a
Nothing Maybe Value
forall a. Maybe a
Nothing