{-# 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
  -- For testing
  , validPragmas
  ) where

import           Control.Lens                       hiding (List)
import           Control.Monad.IO.Class             (MonadIO (liftIO))
import qualified Data.HashMap.Strict                as H
import           Data.List.Extra                    (nubOrdOn)
import           Data.Maybe                         (catMaybes)
import qualified Data.Text                          as T
import           Development.IDE
import           Development.IDE.GHC.Compat
import           Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority)
import qualified Development.IDE.Spans.Pragmas      as Pragmas
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 = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
  { pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentCodeAction
J.STextDocumentCodeAction PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider
                  forall a. Semigroup a => a -> a -> a
<> forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentCompletion
J.STextDocumentCompletion PluginMethodHandler IdeState 'TextDocumentCompletion
completion
  , pluginPriority :: Natural
pluginPriority = Natural
ghcideCompletionsPluginPriority forall a. Num a => a -> a -> a
+ Natural
1
  }

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

data Pragma = LangExt T.Text | OptGHC T.Text
  deriving (Int -> Pragma -> ShowS
[Pragma] -> ShowS
Pragma -> String
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
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
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
Ord)

codeActionProvider :: PluginMethodHandler IdeState 'J.TextDocumentCodeAction
codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider IdeState
state PluginId
_plId (J.CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
docId Range
_ (J.CodeActionContext (J.List [Diagnostic]
diags) Maybe (List CodeActionKind)
_monly))
  | let J.TextDocumentIdentifier{ $sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri = Uri
uri } = TextDocumentIdentifier
docId
  , Just NormalizedFilePath
normalizedFilePath <- NormalizedUri -> Maybe NormalizedFilePath
J.uriToNormalizedFilePath 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> IdeState -> Action a -> IO a
runAction String
"Pragmas.GhcSession" IdeState
state forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale GhcSession
GhcSession NormalizedFilePath
normalizedFilePath
      (UTCTime
_, Maybe Text
fileContents) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> IdeState -> Action a -> IO a
runAction String
"Pragmas.GetFileContents" IdeState
state forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
normalizedFilePath
      Maybe ParsedModule
parsedModule <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> IdeState -> Action a -> IO a
runAction String
"Pragmas.GetParsedModule" IdeState
state forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (Maybe ParsedModule)
getParsedModule NormalizedFilePath
normalizedFilePath
      let parsedModuleDynFlags :: Maybe DynFlags
parsedModuleDynFlags = ModSummary -> DynFlags
ms_hspp_opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> ModSummary
pm_mod_summary 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 = forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ Maybe DynFlags -> Diagnostic -> [(Text, Pragma)]
suggest Maybe DynFlags
parsedModuleDynFlags forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Diagnostic]
diags
          in
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
List forall a b. (a -> b) -> a -> b
$ Uri -> NextPragmaInfo -> (Text, Pragma) -> Command |? CodeAction
pragmaEditToAction Uri
uri NextPragmaInfo
nextPragmaInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Pragma)]
pedits
        Maybe (HscEnvEq, PositionMapping)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
List []
  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ 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) =
  forall a b. b -> a |? b
J.InR 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 (forall a. a -> Maybe a
Just CodeActionKind
J.CodeActionQuickFix) (forall a. a -> Maybe a
Just (forall a. [a] -> List a
J.List [])) forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just WorkspaceEdit
edit) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
  where
    render :: Pragma -> Text
render (OptGHC Text
x)  = Text
"{-# OPTIONS_GHC -Wno-" forall a. Semigroup a => a -> a -> a
<> Text
x forall a. Semigroup a => a -> a -> a
<> Text
" #-}\n"
    render (LangExt Text
x) = Text
"{-# LANGUAGE " forall a. Semigroup a => a -> a -> a
<> Text
x forall a. Semigroup a => a -> a -> a
<> Text
" #-}\n"
    pragmaInsertPosition :: Position
pragmaInsertPosition = UInt -> UInt -> Position
Position (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 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
        (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k v. Hashable k => k -> v -> HashMap k v
H.singleton Uri
uri (forall a. [a] -> List a
J.List [TextEdit]
textEdits))
        forall a. Maybe a
Nothing
        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
    forall a. [a] -> [a] -> [a]
++ Diagnostic -> [(Text, Pragma)]
suggestDisableWarning Diagnostic
diag

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

suggestDisableWarning :: Diagnostic -> [PragmaEdit]
suggestDisableWarning :: Diagnostic -> [(Text, Pragma)]
suggestDisableWarning Diagnostic {Maybe (Int32 |? Text)
$sel:_code:Diagnostic :: Diagnostic -> Maybe (Int32 |? Text)
_code :: Maybe (Int32 |? Text)
_code}
  | Just (J.InR (Text -> Text -> Maybe Text
T.stripPrefix Text
"-W" -> Just Text
w)) <- Maybe (Int32 |? Text)
_code
  , Text
w forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
warningBlacklist =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"Disable \"" forall a. Semigroup a => a -> a -> a
<> Text
w 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
$sel:_message:Diagnostic :: Diagnostic -> Text
_message :: Text
_message} = Text -> [(Text, Pragma)]
genPragma Text
_message
  where
    genPragma :: Text -> [(Text, Pragma)]
genPragma Text
target =
      [(Text
"Add \"" forall a. Semigroup a => a -> a -> a
<> Text
r forall a. Semigroup a => a -> a -> a
<> Text
"\"", Text -> Pragma
LangExt Text
r) | Text
r <- Text -> [Text]
findPragma Text
target, Text
r 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
        forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
"Off " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> Text
printOutputable 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 = 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" forall a. Eq a => a -> a -> Bool
/= Text
name
       ]

-- | All language pragmas, including the No- variants
allPragmas :: [T.Text]
allPragmas :: [Text]
allPragmas =
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Text
name, Text
"No" 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
    ]
  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"
#if MIN_VERSION_ghc(9,2,0)
  , Text
"GHC2021"
#endif
  ]

-- ---------------------------------------------------------------------
flags :: [T.Text]
flags :: [Text]
flags = forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
stripLeading Char
'-') 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
complParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
J.textDocument
        position :: Position
position = MessageParams 'TextDocumentCompletion
complParams forall s a. s -> Getting a s a -> a
^. forall s a. HasPosition s a => Lens' s a
J.position
    Maybe VirtualFile
contents <- forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
LSP.getVirtualFile forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> a |? b
J.InL) 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
                    = forall a. [a] -> List a
J.List forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> CompletionItem
buildCompletion
                        (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
                    = forall a. [a] -> List a
J.List forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> CompletionItem
buildCompletion
                        (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
                    = forall a. [a] -> List a
J.List forall a b. (a -> b) -> a -> b
$ [ Text -> Text -> Text -> CompletionItem
mkPragmaCompl (Text
a 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 forall a. Eq a => a -> a -> Bool
== AppearWhere
NewLine ]
                    | Bool
otherwise
                    = forall a. [a] -> List a
J.List forall a b. (a -> b) -> a -> b
$ [ Text -> Text -> Text -> CompletionItem
mkPragmaCompl (Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
a forall a. Semigroup a => a -> a -> a
<> Text
suffix) Text
b Text
c
                                | (Text
a, Text
b, Text
c, AppearWhere
_) <- [(Text, Text, Text, AppearWhere)]
validPragmas, forall s. TextualMonoid s => s -> s -> Bool
Fuzzy.test Text
word Text
b]
                    where
                        line :: Text
line = Text -> Text
T.toLower forall a b. (a -> b) -> a -> b
$ PosPrefixInfo -> Text
VFS.fullLine 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 = forall a. [a] -> List a
J.List []
        (Maybe VirtualFile, Maybe String)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
J.List []

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

-- | 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AppearWhere] -> ShowS
$cshowList :: [AppearWhere] -> ShowS
show :: AppearWhere -> String
$cshow :: AppearWhere -> String
showsPrec :: Int -> AppearWhere -> ShowS
$cshowsPrec :: Int -> AppearWhere -> ShowS
Show, AppearWhere -> AppearWhere -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AppearWhere -> AppearWhere -> Bool
$c/= :: AppearWhere -> AppearWhere -> Bool
== :: AppearWhere -> AppearWhere -> Bool
$c== :: 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 -> 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 (forall a. a -> Maybe a
Just CompletionItemKind
J.CiKeyword) forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Text
detail)
    forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Text
insertText) (forall a. a -> Maybe a
Just InsertTextFormat
J.Snippet)
    forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing


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


buildCompletion :: T.Text -> J.CompletionItem
buildCompletion :: Text -> CompletionItem
buildCompletion 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 (forall a. a -> Maybe a
Just CompletionItemKind
J.CiKeyword) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing