{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# 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 qualified Data.HashMap.Strict        as H
import           Data.List
import           Data.List.Extra            (nubOrdOn)
import           Data.Maybe                 (catMaybes, listToMaybe)
import qualified Data.Text                  as T
import           Development.IDE            as D
import           Development.IDE.GHC.Compat
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)) = do
  let mFile :: Maybe NormalizedFilePath
mFile = TextDocumentIdentifier
docId TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
J.uri Uri -> (Uri -> Maybe String) -> Maybe String
forall a b. a -> (a -> b) -> b
& Uri -> Maybe String
J.uriToFilePath Maybe String
-> (String -> NormalizedFilePath) -> Maybe NormalizedFilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> String -> NormalizedFilePath
toNormalizedFilePath'
      uri :: Uri
uri = TextDocumentIdentifier
docId TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
J.uri
  Maybe ParsedModule
pm <- 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
$ (Maybe (Maybe ParsedModule) -> Maybe ParsedModule)
-> IO (Maybe (Maybe ParsedModule)) -> IO (Maybe ParsedModule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe ParsedModule) -> Maybe ParsedModule
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (Maybe (Maybe ParsedModule)) -> IO (Maybe ParsedModule))
-> IO (Maybe (Maybe ParsedModule)) -> IO (Maybe ParsedModule)
forall a b. (a -> b) -> a -> b
$ String
-> IdeState
-> Action (Maybe (Maybe ParsedModule))
-> IO (Maybe (Maybe ParsedModule))
forall a. String -> IdeState -> Action a -> IO a
runAction String
"Pragmas.GetParsedModule" IdeState
state (Action (Maybe (Maybe ParsedModule))
 -> IO (Maybe (Maybe ParsedModule)))
-> Action (Maybe (Maybe ParsedModule))
-> IO (Maybe (Maybe ParsedModule))
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (Maybe ParsedModule)
getParsedModule (NormalizedFilePath -> Action (Maybe ParsedModule))
-> Maybe NormalizedFilePath -> Action (Maybe (Maybe ParsedModule))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe NormalizedFilePath
mFile
  Maybe Text
mbContents <- IO (Maybe Text) -> LspT Config IO (Maybe Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Text) -> LspT Config IO (Maybe Text))
-> IO (Maybe Text) -> LspT Config IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ (Maybe (UTCTime, Maybe Text) -> Maybe Text)
-> IO (Maybe (UTCTime, Maybe Text)) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((UTCTime, Maybe Text) -> Maybe Text
forall a b. (a, b) -> b
snd ((UTCTime, Maybe Text) -> Maybe Text)
-> Maybe (UTCTime, Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (IO (Maybe (UTCTime, Maybe Text)) -> IO (Maybe Text))
-> IO (Maybe (UTCTime, Maybe Text)) -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ String
-> IdeState
-> Action (Maybe (UTCTime, Maybe Text))
-> IO (Maybe (UTCTime, Maybe Text))
forall a. String -> IdeState -> Action a -> IO a
runAction String
"Pragmas.GetFileContents" IdeState
state (Action (Maybe (UTCTime, Maybe Text))
 -> IO (Maybe (UTCTime, Maybe Text)))
-> Action (Maybe (UTCTime, Maybe Text))
-> IO (Maybe (UTCTime, Maybe Text))
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents (NormalizedFilePath -> Action (UTCTime, Maybe Text))
-> Maybe NormalizedFilePath -> Action (Maybe (UTCTime, Maybe Text))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe NormalizedFilePath
mFile
  let dflags :: Maybe DynFlags
dflags = 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
pm
      insertRange :: Range
insertRange = Range -> (Text -> Range) -> Maybe Text -> Range
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Position -> Position -> Range
Range (Int -> Int -> Position
Position Int
0 Int
0) (Int -> Int -> Position
Position Int
0 Int
0)) Text -> Range
endOfModuleHeader Maybe Text
mbContents
      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
dflags (Diagnostic -> [(Text, Pragma)])
-> [Diagnostic] -> [[(Text, Pragma)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Diagnostic]
diags
  Either ResponseError (List (Command |? CodeAction))
-> LspT
     Config IO (Either ResponseError (List (Command |? CodeAction)))
forall (m :: * -> *) a. Monad m => a -> m a
return (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 -> Range -> (Text, Pragma) -> Command |? CodeAction
pragmaEditToAction Uri
uri Range
insertRange ((Text, Pragma) -> Command |? CodeAction)
-> [(Text, Pragma)] -> [Command |? CodeAction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Pragma)]
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 -> Range -> PragmaEdit -> (J.Command J.|? J.CodeAction)
pragmaEditToAction :: Uri -> Range -> (Text, Pragma) -> Command |? CodeAction
pragmaEditToAction Uri
uri Range
range (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"
    textEdits :: List TextEdit
textEdits = [TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List [Range -> Text -> TextEdit
J.TextEdit Range
range (Text -> TextEdit) -> Text -> TextEdit
forall a b. (a -> b) -> a -> b
$ 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 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 (Int |? Text)
$sel:_code:Diagnostic :: Diagnostic -> Maybe (Int |? Text)
_code :: Maybe (Int |? Text)
_code}
  | Just (J.InR (Text -> Text -> Maybe Text
T.stripPrefix Text
"-W" -> Just Text
w)) <- Maybe (Int |? Text)
_code =
    (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 = []

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

-- | 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
$sel:_message:Diagnostic :: Diagnostic -> Text
_message :: 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
. String -> Text
T.pack (String -> Text)
-> (OnOff Extension -> String) -> OnOff Extension -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnOff Extension -> String
forall a. Outputable a => a -> String
prettyPrint (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?
  ]

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

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` PosPrefixInfo -> Text
VFS.fullLine PosPrefixInfo
pfix
                    = [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)
                    | Bool
otherwise
                    = [CompletionItem] -> List CompletionItem
forall a. [a] -> List a
J.List []
                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 []

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

-- | Find first line after (last pragma / last shebang / beginning of file).
-- Useful for inserting pragmas.
endOfModuleHeader :: T.Text -> Range
endOfModuleHeader :: Text -> Range
endOfModuleHeader Text
contents = Position -> Position -> Range
Range Position
loc Position
loc
    where
        loc :: Position
loc = Int -> Int -> Position
Position Int
line Int
0
        line :: Int
line = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 Int -> Int
forall a. Enum a => a -> a
succ (Text -> Maybe Int
lastLineWithPrefix Text
"{-#" Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Maybe Int
lastLineWithPrefix Text
"#!")
        lastLineWithPrefix :: Text -> Maybe Int
lastLineWithPrefix Text
pre = [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe ([Int] -> Maybe Int) -> [Int] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
findIndices (Text -> Text -> Bool
T.isPrefixOf Text
pre) ([Text] -> [Int]) -> [Text] -> [Int]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
contents