{-# 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
  ( descriptor
  ) where

import           Control.Applicative              ((<|>))
import           Control.Lens                     hiding (List)
import           Control.Monad                    (join)
import           Control.Monad.IO.Class           (MonadIO (liftIO))
import           Control.Monad.Trans.State.Strict (State)
import           Data.Bits                        (Bits (bit, complement, setBit, (.&.)))
import           Data.Char                        (isSpace)
import qualified Data.Char                        as Char
import           Data.Coerce                      (coerce)
import           Data.Functor                     (void, ($>))
import qualified Data.HashMap.Strict              as H
import qualified Data.List                        as List
import           Data.List.Extra                  (nubOrdOn)
import qualified Data.Map.Strict                  as Map
import           Data.Maybe                       (catMaybes, listToMaybe,
                                                   mapMaybe)
import qualified Data.Maybe                       as Maybe
import           Data.Ord                         (Down (Down))
import           Data.Semigroup                   (Semigroup ((<>)))
import qualified Data.Text                        as T
import           Data.Word                        (Word64)
import           Development.IDE                  as D (Diagnostic (Diagnostic, _code, _message),
                                                        GhcSession (GhcSession),
                                                        HscEnvEq (hscEnv),
                                                        IdeState, List (List),
                                                        ParseResult (POk),
                                                        Position (Position),
                                                        Range (Range), Uri,
                                                        getFileContents,
                                                        getParsedModule,
                                                        printOutputable, runAction,
                                                        srcSpanToRange,
                                                        toNormalizedUri,
                                                        uriToFilePath',
                                                        useWithStale)
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Compat.Util  (StringBuffer, atEnd,
                                                   nextChar,
                                                   stringToStringBuffer)
import qualified Development.IDE.Spans.Pragmas    as Pragmas
import           Development.IDE.Types.HscEnvEq   (HscEnvEq, hscEnv)
import           Ide.Types
import qualified Language.LSP.Server              as LSP
import qualified Language.LSP.Types               as J
import qualified Language.LSP.Types.Lens          as J
import qualified Language.LSP.VFS                 as VFS
import qualified Text.Fuzzy                       as Fuzzy

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

descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId = (PluginId -> PluginDescriptor IdeState
forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
  { pluginHandlers :: PluginHandlers IdeState
pluginHandlers = SClientMethod 'TextDocumentCodeAction
-> PluginMethodHandler IdeState 'TextDocumentCodeAction
-> PluginHandlers IdeState
forall (m :: Method 'FromClient 'Request) ideState.
PluginMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod 'TextDocumentCodeAction
J.STextDocumentCodeAction PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider
                  PluginHandlers IdeState
-> PluginHandlers IdeState -> PluginHandlers IdeState
forall a. Semigroup a => a -> a -> a
<> SClientMethod 'TextDocumentCompletion
-> PluginMethodHandler IdeState 'TextDocumentCompletion
-> PluginHandlers IdeState
forall (m :: Method 'FromClient 'Request) ideState.
PluginMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod 'TextDocumentCompletion
J.STextDocumentCompletion PluginMethodHandler IdeState 'TextDocumentCompletion
completion
  }

-- ---------------------------------------------------------------------
-- | 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
showList :: [Pragma] -> ShowS
$cshowList :: [Pragma] -> ShowS
show :: Pragma -> String
$cshow :: Pragma -> String
showsPrec :: Int -> Pragma -> ShowS
$cshowsPrec :: Int -> Pragma -> ShowS
Show, Pragma -> Pragma -> Bool
(Pragma -> Pragma -> Bool)
-> (Pragma -> Pragma -> Bool) -> Eq Pragma
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pragma -> Pragma -> Bool
$c/= :: Pragma -> Pragma -> Bool
== :: Pragma -> Pragma -> Bool
$c== :: 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
min :: Pragma -> Pragma -> Pragma
$cmin :: Pragma -> Pragma -> Pragma
max :: Pragma -> Pragma -> Pragma
$cmax :: Pragma -> Pragma -> Pragma
>= :: Pragma -> Pragma -> Bool
$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
compare :: Pragma -> Pragma -> Ordering
$ccompare :: Pragma -> Pragma -> Ordering
$cp1Ord :: Eq Pragma
Ord)

codeActionProvider :: PluginMethodHandler IdeState 'J.TextDocumentCodeAction
codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider IdeState
state PluginId
_plId (J.CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly))
  | let J.TextDocumentIdentifier{ $sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri = Uri
uri } = TextDocumentIdentifier
docId
  , Just NormalizedFilePath
normalizedFilePath <- NormalizedUri -> Maybe NormalizedFilePath
J.uriToNormalizedFilePath (NormalizedUri -> Maybe NormalizedFilePath)
-> NormalizedUri -> Maybe NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri = do
      -- ghc session to get some dynflags even if module isn't parsed
      Maybe (HscEnvEq, PositionMapping)
ghcSession <- IO (Maybe (HscEnvEq, PositionMapping))
-> LspT Config IO (Maybe (HscEnvEq, PositionMapping))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (HscEnvEq, PositionMapping))
 -> LspT Config IO (Maybe (HscEnvEq, PositionMapping)))
-> IO (Maybe (HscEnvEq, PositionMapping))
-> LspT Config IO (Maybe (HscEnvEq, PositionMapping))
forall a b. (a -> b) -> a -> b
$ String
-> IdeState
-> Action (Maybe (HscEnvEq, PositionMapping))
-> IO (Maybe (HscEnvEq, PositionMapping))
forall a. String -> IdeState -> Action a -> IO a
runAction String
"Pragmas.GhcSession" IdeState
state (Action (Maybe (HscEnvEq, PositionMapping))
 -> IO (Maybe (HscEnvEq, PositionMapping)))
-> Action (Maybe (HscEnvEq, PositionMapping))
-> IO (Maybe (HscEnvEq, PositionMapping))
forall a b. (a -> b) -> a -> b
$ GhcSession
-> NormalizedFilePath -> Action (Maybe (HscEnvEq, PositionMapping))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale GhcSession
GhcSession NormalizedFilePath
normalizedFilePath
      (UTCTime
_, Maybe Text
fileContents) <- IO (UTCTime, Maybe Text) -> LspT Config IO (UTCTime, Maybe Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTCTime, Maybe Text) -> LspT Config IO (UTCTime, Maybe Text))
-> IO (UTCTime, Maybe Text) -> LspT Config IO (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) -> LspT Config IO (Maybe ParsedModule)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ParsedModule) -> LspT Config IO (Maybe ParsedModule))
-> IO (Maybe ParsedModule) -> LspT Config IO (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

      case Maybe (HscEnvEq, PositionMapping)
ghcSession of
        Just (HscEnvEq -> HscEnv
hscEnv -> HscEnv -> DynFlags
hsc_dflags -> DynFlags
sessionDynFlags, PositionMapping
_) ->
          let nextPragmaInfo :: NextPragmaInfo
nextPragmaInfo = DynFlags -> Maybe Text -> NextPragmaInfo
Pragmas.getNextPragmaInfo DynFlags
sessionDynFlags Maybe Text
fileContents
              pedits :: [(Text, Pragma)]
pedits = ((Text, Pragma) -> Pragma) -> [(Text, Pragma)] -> [(Text, Pragma)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn (Text, Pragma) -> Pragma
forall a b. (a, b) -> b
snd ([(Text, Pragma)] -> [(Text, Pragma)])
-> ([[(Text, Pragma)]] -> [(Text, Pragma)])
-> [[(Text, Pragma)]]
-> [(Text, Pragma)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Text, Pragma)]] -> [(Text, Pragma)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Text, Pragma)]] -> [(Text, Pragma)])
-> [[(Text, Pragma)]] -> [(Text, Pragma)]
forall a b. (a -> b) -> a -> b
$ Maybe DynFlags -> Diagnostic -> [(Text, Pragma)]
suggest Maybe DynFlags
parsedModuleDynFlags (Diagnostic -> [(Text, Pragma)])
-> [Diagnostic] -> [[(Text, Pragma)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Diagnostic]
diags
          in
            Either ResponseError (List (Command |? CodeAction))
-> LspT
     Config IO (Either ResponseError (List (Command |? CodeAction)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (List (Command |? CodeAction))
 -> LspT
      Config IO (Either ResponseError (List (Command |? CodeAction))))
-> Either ResponseError (List (Command |? CodeAction))
-> LspT
     Config IO (Either ResponseError (List (Command |? CodeAction)))
forall a b. (a -> b) -> a -> b
$ List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. b -> Either a b
Right (List (Command |? CodeAction)
 -> Either ResponseError (List (Command |? CodeAction)))
-> List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> List (Command |? CodeAction)
forall a. [a] -> List a
List ([Command |? CodeAction] -> List (Command |? CodeAction))
-> [Command |? CodeAction] -> List (Command |? CodeAction)
forall a b. (a -> b) -> a -> b
$ Uri -> NextPragmaInfo -> (Text, Pragma) -> Command |? CodeAction
pragmaEditToAction Uri
uri NextPragmaInfo
nextPragmaInfo ((Text, Pragma) -> Command |? CodeAction)
-> [(Text, Pragma)] -> [Command |? CodeAction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Pragma)]
pedits
        Maybe (HscEnvEq, PositionMapping)
Nothing -> Either ResponseError (List (Command |? CodeAction))
-> LspT
     Config IO (Either ResponseError (List (Command |? CodeAction)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (List (Command |? CodeAction))
 -> LspT
      Config IO (Either ResponseError (List (Command |? CodeAction))))
-> Either ResponseError (List (Command |? CodeAction))
-> LspT
     Config IO (Either ResponseError (List (Command |? CodeAction)))
forall a b. (a -> b) -> a -> b
$ List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. b -> Either a b
Right (List (Command |? CodeAction)
 -> Either ResponseError (List (Command |? CodeAction)))
-> List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> List (Command |? CodeAction)
forall a. [a] -> List a
List []
  | Bool
otherwise = Either ResponseError (List (Command |? CodeAction))
-> LspT
     Config IO (Either ResponseError (List (Command |? CodeAction)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (List (Command |? CodeAction))
 -> LspT
      Config IO (Either ResponseError (List (Command |? CodeAction))))
-> Either ResponseError (List (Command |? CodeAction))
-> LspT
     Config IO (Either ResponseError (List (Command |? CodeAction)))
forall a b. (a -> b) -> a -> b
$ List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. b -> Either a b
Right (List (Command |? CodeAction)
 -> Either ResponseError (List (Command |? CodeAction)))
-> List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> List (Command |? CodeAction)
forall a. [a] -> List a
List []


-- | 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 -> (J.Command J.|? J.CodeAction)
pragmaEditToAction :: Uri -> NextPragmaInfo -> (Text, Pragma) -> Command |? CodeAction
pragmaEditToAction Uri
uri Pragmas.NextPragmaInfo{ Int
$sel:nextPragmaLine:NextPragmaInfo :: NextPragmaInfo -> Int
nextPragmaLine :: Int
nextPragmaLine, Maybe LineSplitTextEdits
$sel:lineSplitTextEdits:NextPragmaInfo :: NextPragmaInfo -> Maybe LineSplitTextEdits
lineSplitTextEdits :: Maybe LineSplitTextEdits
lineSplitTextEdits } (Text
title, Pragma
p) =
  CodeAction -> Command |? CodeAction
forall a b. b -> a |? b
J.InR (CodeAction -> Command |? CodeAction)
-> CodeAction -> Command |? CodeAction
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe CodeActionKind
-> Maybe (List Diagnostic)
-> Maybe Bool
-> Maybe Reason
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
J.CodeAction Text
title (CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just CodeActionKind
J.CodeActionQuickFix) (List Diagnostic -> Maybe (List Diagnostic)
forall a. a -> Maybe a
Just ([Diagnostic] -> List Diagnostic
forall a. [a] -> List a
J.List [])) Maybe Bool
forall a. Maybe a
Nothing Maybe Reason
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 J.TextEdit{ Range
$sel:_range:TextEdit :: TextEdit -> Range
_range :: Range
_range, Text
$sel:_newText:TextEdit :: TextEdit -> Text
_newText :: Text
_newText } = TextEdit
insertTextEdit ->
             [Range -> Text -> TextEdit
J.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
J.TextEdit Range
pragmaInsertRange (Pragma -> Text
render Pragma
p)]

    edit :: WorkspaceEdit
edit =
      Maybe WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
J.WorkspaceEdit
        (WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a. a -> Maybe a
Just (WorkspaceEditMap -> Maybe WorkspaceEditMap)
-> WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a b. (a -> b) -> a -> b
$ Uri -> List TextEdit -> WorkspaceEditMap
forall k v. Hashable k => k -> v -> HashMap k v
H.singleton Uri
uri ([TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List [TextEdit]
textEdits))
        Maybe (List DocumentChange)
forall a. Maybe a
Nothing
        Maybe ChangeAnnotationMap
forall a. Maybe a
Nothing

suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
suggest :: Maybe DynFlags -> Diagnostic -> [(Text, Pragma)]
suggest Maybe DynFlags
dflags Diagnostic
diag =
  Maybe DynFlags -> Diagnostic -> [(Text, Pragma)]
suggestAddPragma Maybe DynFlags
dflags Diagnostic
diag
    [(Text, Pragma)] -> [(Text, Pragma)] -> [(Text, Pragma)]
forall a. [a] -> [a] -> [a]
++ Diagnostic -> [(Text, Pragma)]
suggestDisableWarning Diagnostic
diag

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

suggestDisableWarning :: Diagnostic -> [PragmaEdit]
suggestDisableWarning :: Diagnostic -> [(Text, Pragma)]
suggestDisableWarning Diagnostic {Maybe (Int32 |? Text)
_code :: Maybe (Int32 |? Text)
$sel:_code:Diagnostic :: Diagnostic -> Maybe (Int32 |? Text)
_code}
  | Just (J.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 =
    (Text, Pragma) -> [(Text, Pragma)]
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 -> [(Text, Pragma)]
suggestAddPragma Maybe DynFlags
mDynflags Diagnostic {Text
_message :: Text
$sel:_message:Diagnostic :: Diagnostic -> Text
_message} = Text -> [(Text, Pragma)]
genPragma Text
_message
  where
    genPragma :: Text -> [(Text, Pragma)]
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.
        []

-- | 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"
    -- Maybe, GHC 2021 after its release?
  ]

-- ---------------------------------------------------------------------
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 'J.TextDocumentCompletion
completion :: PluginMethodHandler IdeState 'TextDocumentCompletion
completion IdeState
_ide PluginId
_ MessageParams 'TextDocumentCompletion
complParams = do
    let (J.TextDocumentIdentifier Uri
uri) = MessageParams 'TextDocumentCompletion
CompletionParams
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
J.textDocument
        position :: Position
position = MessageParams 'TextDocumentCompletion
CompletionParams
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
J.position
    Maybe VirtualFile
contents <- NormalizedUri -> LspT Config IO (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
LSP.getVirtualFile (NormalizedUri -> LspT Config IO (Maybe VirtualFile))
-> NormalizedUri -> LspT Config IO (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri
    (List CompletionItem
 -> Either ResponseError (List CompletionItem |? CompletionList))
-> LspT Config IO (List CompletionItem)
-> LspT
     Config
     IO
     (Either ResponseError (List CompletionItem |? CompletionList))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((List CompletionItem |? CompletionList)
-> Either ResponseError (List CompletionItem |? CompletionList)
forall a b. b -> Either a b
Right ((List CompletionItem |? CompletionList)
 -> Either ResponseError (List CompletionItem |? CompletionList))
-> (List CompletionItem -> List CompletionItem |? CompletionList)
-> List CompletionItem
-> Either ResponseError (List CompletionItem |? CompletionList)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List CompletionItem -> List CompletionItem |? CompletionList
forall a b. a -> a |? b
J.InL) (LspT Config IO (List CompletionItem)
 -> LspT
      Config
      IO
      (Either ResponseError (List CompletionItem |? CompletionList)))
-> LspT Config IO (List CompletionItem)
-> LspT
     Config
     IO
     (Either ResponseError (List CompletionItem |? CompletionList))
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 -> List CompletionItem
result (Maybe PosPrefixInfo -> List CompletionItem)
-> LspT Config IO (Maybe PosPrefixInfo)
-> LspT Config IO (List CompletionItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position -> VirtualFile -> LspT Config IO (Maybe PosPrefixInfo)
forall (m :: * -> *).
Monad m =>
Position -> VirtualFile -> m (Maybe PosPrefixInfo)
VFS.getCompletionPrefix Position
position VirtualFile
cnts
            where
                result :: Maybe PosPrefixInfo -> List CompletionItem
result (Just PosPrefixInfo
pfix)
                    | Text
"{-# language" Text -> Text -> Bool
`T.isPrefixOf` Text
line
                    = [CompletionItem] -> List CompletionItem
forall a. [a] -> List a
J.List ([CompletionItem] -> List CompletionItem)
-> [CompletionItem] -> List CompletionItem
forall a b. (a -> b) -> a -> b
$ (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
                    = [CompletionItem] -> List CompletionItem
forall a. [a] -> List a
J.List ([CompletionItem] -> List CompletionItem)
-> [CompletionItem] -> List CompletionItem
forall a b. (a -> b) -> a -> b
$ (Text -> CompletionItem) -> [Text] -> [CompletionItem]
forall a b. (a -> b) -> [a] -> [b]
map Text -> CompletionItem
mkExtCompl
                        (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
                    = [CompletionItem] -> List CompletionItem
forall a. [a] -> List a
J.List ([CompletionItem] -> List CompletionItem)
-> [CompletionItem] -> List CompletionItem
forall a b. (a -> b) -> a -> b
$ ((Text, Text, Text) -> CompletionItem)
-> [(Text, Text, Text)] -> [CompletionItem]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
a, Text
b, Text
c) -> Text -> Text -> Text -> CompletionItem
mkPragmaCompl (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffix) Text
b Text
c) [(Text, Text, Text)]
validPragmas
                    | Bool
otherwise
                    = [CompletionItem] -> List CompletionItem
forall a. [a] -> List a
J.List []
                    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
                        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
" #-"
                            | Bool
otherwise                 = Text
" #-}"
                result Maybe PosPrefixInfo
Nothing = [CompletionItem] -> List CompletionItem
forall a. [a] -> List a
J.List []
                buildCompletion :: Text -> CompletionItem
buildCompletion Text
p =
                    CompletionItem :: Text
-> Maybe CompletionItemKind
-> Maybe (List CompletionItemTag)
-> Maybe Text
-> Maybe CompletionDoc
-> Maybe Bool
-> Maybe Bool
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe InsertTextFormat
-> Maybe InsertTextMode
-> Maybe CompletionEdit
-> Maybe (List TextEdit)
-> Maybe (List Text)
-> Maybe Command
-> Maybe Value
-> CompletionItem
J.CompletionItem
                      { $sel:_label:CompletionItem :: Text
_label = Text
p,
                        $sel:_kind:CompletionItem :: Maybe CompletionItemKind
_kind = CompletionItemKind -> Maybe CompletionItemKind
forall a. a -> Maybe a
Just CompletionItemKind
J.CiKeyword,
                        $sel:_tags:CompletionItem :: Maybe (List CompletionItemTag)
_tags = Maybe (List CompletionItemTag)
forall a. Maybe a
Nothing,
                        $sel:_detail:CompletionItem :: Maybe Text
_detail = Maybe Text
forall a. Maybe a
Nothing,
                        $sel:_documentation:CompletionItem :: Maybe CompletionDoc
_documentation = Maybe CompletionDoc
forall a. Maybe a
Nothing,
                        $sel:_deprecated:CompletionItem :: Maybe Bool
_deprecated = Maybe Bool
forall a. Maybe a
Nothing,
                        $sel:_preselect:CompletionItem :: Maybe Bool
_preselect = Maybe Bool
forall a. Maybe a
Nothing,
                        $sel:_sortText:CompletionItem :: Maybe Text
_sortText = Maybe Text
forall a. Maybe a
Nothing,
                        $sel:_filterText:CompletionItem :: Maybe Text
_filterText = Maybe Text
forall a. Maybe a
Nothing,
                        $sel:_insertText:CompletionItem :: Maybe Text
_insertText = Maybe Text
forall a. Maybe a
Nothing,
                        $sel:_insertTextFormat:CompletionItem :: Maybe InsertTextFormat
_insertTextFormat = Maybe InsertTextFormat
forall a. Maybe a
Nothing,
                        $sel:_insertTextMode:CompletionItem :: Maybe InsertTextMode
_insertTextMode = Maybe InsertTextMode
forall a. Maybe a
Nothing,
                        $sel:_textEdit:CompletionItem :: Maybe CompletionEdit
_textEdit = Maybe CompletionEdit
forall a. Maybe a
Nothing,
                        $sel:_additionalTextEdits:CompletionItem :: Maybe (List TextEdit)
_additionalTextEdits = Maybe (List TextEdit)
forall a. Maybe a
Nothing,
                        $sel:_commitCharacters:CompletionItem :: Maybe (List Text)
_commitCharacters = Maybe (List Text)
forall a. Maybe a
Nothing,
                        $sel:_command:CompletionItem :: Maybe Command
_command = Maybe Command
forall a. Maybe a
Nothing,
                        $sel:_xdata:CompletionItem :: Maybe Value
_xdata = Maybe Value
forall a. Maybe a
Nothing
                      }
        (Maybe VirtualFile, Maybe String)
_ -> List CompletionItem -> LspT Config IO (List CompletionItem)
forall (m :: * -> *) a. Monad m => a -> m a
return (List CompletionItem -> LspT Config IO (List CompletionItem))
-> List CompletionItem -> LspT Config IO (List CompletionItem)
forall a b. (a -> b) -> a -> b
$ [CompletionItem] -> List CompletionItem
forall a. [a] -> List a
J.List []

-----------------------------------------------------------------------
validPragmas :: [(T.Text, T.Text, T.Text)]
validPragmas :: [(Text, Text, Text)]
validPragmas =
  [ (Text
"LANGUAGE ${1:extension}"         , Text
"LANGUAGE",           Text
"{-# LANGUAGE #-}")
  , (Text
"OPTIONS_GHC -${1:option}"        , Text
"OPTIONS_GHC",        Text
"{-# OPTIONS_GHC #-}")
  , (Text
"INLINE ${1:function}"            , Text
"INLINE",             Text
"{-# INLINE #-}")
  , (Text
"NOINLINE ${1:function}"          , Text
"NOINLINE",           Text
"{-# NOINLINE #-}")
  , (Text
"INLINABLE ${1:function}"         , Text
"INLINABLE",          Text
"{-# INLINABLE #-}")
  , (Text
"WARNING ${1:message}"            , Text
"WARNING",            Text
"{-# WARNING #-}")
  , (Text
"DEPRECATED ${1:message}"         , Text
"DEPRECATED",         Text
"{-# DEPRECATED  #-}")
  , (Text
"ANN ${1:annotation}"             , Text
"ANN",                Text
"{-# ANN #-}")
  , (Text
"RULES"                           , Text
"RULES",              Text
"{-# RULES #-}")
  , (Text
"SPECIALIZE ${1:function}"        , Text
"SPECIALIZE",         Text
"{-# SPECIALIZE #-}")
  , (Text
"SPECIALIZE INLINE ${1:function}" , Text
"SPECIALIZE INLINE",  Text
"{-# SPECIALIZE INLINE #-}")
  ]


mkPragmaCompl :: T.Text -> T.Text -> T.Text -> J.CompletionItem
mkPragmaCompl :: Text -> Text -> Text -> CompletionItem
mkPragmaCompl Text
insertText Text
label Text
detail =
  Text
-> Maybe CompletionItemKind
-> Maybe (List CompletionItemTag)
-> Maybe Text
-> Maybe CompletionDoc
-> Maybe Bool
-> Maybe Bool
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe InsertTextFormat
-> Maybe InsertTextMode
-> Maybe CompletionEdit
-> Maybe (List TextEdit)
-> Maybe (List Text)
-> Maybe Command
-> Maybe Value
-> CompletionItem
J.CompletionItem Text
label (CompletionItemKind -> Maybe CompletionItemKind
forall a. a -> Maybe a
Just CompletionItemKind
J.CiKeyword) Maybe (List CompletionItemTag)
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
detail)
    Maybe CompletionDoc
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
J.Snippet)
    Maybe InsertTextMode
forall a. Maybe a
Nothing Maybe CompletionEdit
forall a. Maybe a
Nothing Maybe (List TextEdit)
forall a. Maybe a
Nothing Maybe (List 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


mkExtCompl :: T.Text -> J.CompletionItem
mkExtCompl :: Text -> CompletionItem
mkExtCompl Text
label =
  Text
-> Maybe CompletionItemKind
-> Maybe (List CompletionItemTag)
-> Maybe Text
-> Maybe CompletionDoc
-> Maybe Bool
-> Maybe Bool
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe InsertTextFormat
-> Maybe InsertTextMode
-> Maybe CompletionEdit
-> Maybe (List TextEdit)
-> Maybe (List Text)
-> Maybe Command
-> Maybe Value
-> CompletionItem
J.CompletionItem Text
label (CompletionItemKind -> Maybe CompletionItemKind
forall a. a -> Maybe a
Just CompletionItemKind
J.CiKeyword) Maybe (List CompletionItemTag)
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
    Maybe CompletionDoc
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 CompletionEdit
forall a. Maybe a
Nothing Maybe (List TextEdit)
forall a. Maybe a
Nothing Maybe (List Text)
forall a. Maybe a
Nothing Maybe Command
forall a. Maybe a
Nothing Maybe Value
forall a. Maybe a
Nothing