1{-# LANGUAGE BangPatterns               #-}
2{-# LANGUAGE CPP                        #-}
3{-# LANGUAGE ConstraintKinds            #-}
4{-# LANGUAGE DefaultSignatures          #-}
5{-# LANGUAGE DeriveAnyClass             #-}
6{-# LANGUAGE DeriveGeneric              #-}
7{-# LANGUAGE DerivingStrategies         #-}
8{-# LANGUAGE FlexibleContexts           #-}
9{-# LANGUAGE FlexibleInstances          #-}
10{-# LANGUAGE GADTs                      #-}
11{-# LANGUAGE GeneralizedNewtypeDeriving #-}
12{-# LANGUAGE OverloadedStrings          #-}
13{-# LANGUAGE PolyKinds                  #-}
14{-# LANGUAGE ScopedTypeVariables        #-}
15{-# LANGUAGE TypeFamilies               #-}
16{-# LANGUAGE UndecidableInstances       #-}
17{-# LANGUAGE ViewPatterns               #-}
18
19module Ide.Types
20    where
21
22#ifdef mingw32_HOST_OS
23import qualified System.Win32.Process            as P (getCurrentProcessId)
24#else
25import qualified System.Posix.Process            as P (getProcessID)
26import           System.Posix.Signals
27#endif
28import           Control.Lens                    ((^.))
29import           Control.Monad
30import           Data.Aeson                      hiding (defaultOptions)
31import qualified Data.DList                      as DList
32import qualified Data.Default
33import           Data.Dependent.Map              (DMap)
34import qualified Data.Dependent.Map              as DMap
35import           Data.GADT.Compare
36import           Data.List.NonEmpty              (NonEmpty (..), toList)
37import qualified Data.Map                        as Map
38import           Data.Maybe
39import           Data.Semigroup
40import           Data.String
41import qualified Data.Text                       as T
42import           Data.Text.Encoding              (encodeUtf8)
43import           Development.IDE.Graph
44import           DynFlags                        (DynFlags)
45import           GHC.Generics
46import           Ide.Plugin.Config
47import           Ide.Plugin.Properties
48import           Language.LSP.Server             (LspM, getVirtualFile)
49import           Language.LSP.Types              hiding (SemanticTokenAbsolute(length, line), SemanticTokenRelative(length), SemanticTokensEdit(_start))
50import           Language.LSP.Types.Capabilities (ClientCapabilities (ClientCapabilities),
51                                                  TextDocumentClientCapabilities (_codeAction, _documentSymbol))
52import           Language.LSP.Types.Lens         as J (HasChildren (children),
53                                                       HasCommand (command),
54                                                       HasContents (contents),
55                                                       HasDeprecated (deprecated),
56                                                       HasEdit (edit),
57                                                       HasKind (kind),
58                                                       HasName (name),
59                                                       HasOptions (..),
60                                                       HasRange (range),
61                                                       HasTextDocument (..),
62                                                       HasTitle (title),
63                                                       HasUri (..))
64import           Language.LSP.VFS
65import           OpenTelemetry.Eventlog
66import           Options.Applicative             (ParserInfo)
67import           System.IO.Unsafe
68import           Text.Regex.TDFA.Text            ()
69
70-- ---------------------------------------------------------------------
71
72newtype IdePlugins ideState = IdePlugins
73  { ipMap :: [(PluginId, PluginDescriptor ideState)]}
74  deriving newtype (Monoid, Semigroup)
75
76-- | Hooks for modifying the 'DynFlags' at different times of the compilation
77-- process. Plugins can install a 'DynFlagsModifications' via
78-- 'pluginModifyDynflags' in their 'PluginDescriptor'.
79data DynFlagsModifications =
80  DynFlagsModifications
81    { -- | Invoked immediately at the package level. Changes to the 'DynFlags'
82      -- made in 'dynFlagsModifyGlobal' are guaranteed to be seen everywhere in
83      -- the compilation pipeline.
84      dynFlagsModifyGlobal :: DynFlags -> DynFlags
85      -- | Invoked just before the parsing step, and reset immediately
86      -- afterwards. 'dynFlagsModifyParser' allows plugins to enable language
87      -- extensions only during parsing. for example, to let them enable
88      -- certain pieces of syntax.
89    , dynFlagsModifyParser :: DynFlags -> DynFlags
90    }
91
92instance Semigroup DynFlagsModifications where
93  DynFlagsModifications g1 p1 <> DynFlagsModifications g2 p2 =
94    DynFlagsModifications (g2 . g1) (p2 . p1)
95
96instance Monoid DynFlagsModifications where
97  mempty = DynFlagsModifications id id
98
99-- ---------------------------------------------------------------------
100
101newtype IdeCommand state = IdeCommand (state -> IO ())
102instance Show (IdeCommand st) where show _ = "<ide command>"
103
104-- ---------------------------------------------------------------------
105
106data PluginDescriptor ideState =
107  PluginDescriptor { pluginId           :: !PluginId
108                   , pluginRules        :: !(Rules ())
109                   , pluginCommands     :: ![PluginCommand ideState]
110                   , pluginHandlers     :: PluginHandlers ideState
111                   , pluginConfigDescriptor :: ConfigDescriptor
112                   , pluginNotificationHandlers :: PluginNotificationHandlers ideState
113                   , pluginModifyDynflags :: DynFlagsModifications
114                   , pluginCli            :: Maybe (ParserInfo (IdeCommand ideState))
115                   }
116
117-- | An existential wrapper of 'Properties'
118data CustomConfig = forall r. CustomConfig (Properties r)
119
120-- | Describes the configuration a plugin.
121-- A plugin may be configurable in such form:
122-- @
123-- {
124--  "plugin-id": {
125--    "globalOn": true,
126--    "codeActionsOn": true,
127--    "codeLensOn": true,
128--    "config": {
129--      "property1": "foo"
130--     }
131--   }
132-- }
133-- @
134-- @globalOn@, @codeActionsOn@, and @codeLensOn@ etc. are called generic configs,
135-- which can be inferred from handlers registered by the plugin.
136-- @config@ is called custom config, which is defined using 'Properties'.
137data ConfigDescriptor = ConfigDescriptor {
138  -- | Whether or not to generate generic configs.
139  configEnableGenericConfig :: Bool,
140  -- | Whether or not to generate @diagnosticsOn@ config.
141  -- Diagnostics emit in arbitrary shake rules,
142  -- so we can't know statically if the plugin produces diagnostics
143  configHasDiagnostics      :: Bool,
144  -- | Custom config.
145  configCustomConfig        :: CustomConfig
146}
147
148mkCustomConfig :: Properties r -> CustomConfig
149mkCustomConfig = CustomConfig
150
151defaultConfigDescriptor :: ConfigDescriptor
152defaultConfigDescriptor = ConfigDescriptor True False (mkCustomConfig emptyProperties)
153
154-- | Methods that can be handled by plugins.
155-- 'ExtraParams' captures any extra data the IDE passes to the handlers for this method
156-- Only methods for which we know how to combine responses can be instances of 'PluginMethod'
157class HasTracing (MessageParams m) => PluginMethod m where
158
159  -- | Parse the configuration to check if this plugin is enabled
160  pluginEnabled :: SMethod m -> PluginId -> Config -> Bool
161
162  -- | How to combine responses from different plugins
163  combineResponses
164    :: SMethod m
165    -> Config -- ^ IDE Configuration
166    -> ClientCapabilities
167    -> MessageParams m
168    -> NonEmpty (ResponseResult m) -> ResponseResult m
169
170  default combineResponses :: Semigroup (ResponseResult m)
171    => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (ResponseResult m) -> ResponseResult m
172  combineResponses _method _config _caps _params = sconcat
173
174instance PluginMethod TextDocumentCodeAction where
175  pluginEnabled _ = pluginEnabledConfig plcCodeActionsOn
176  combineResponses _method _config (ClientCapabilities _ textDocCaps _ _) (CodeActionParams _ _ _ _ context) resps =
177      fmap compat $ List $ filter wasRequested $ (\(List x) -> x) $ sconcat resps
178    where
179
180      compat :: (Command |? CodeAction) -> (Command |? CodeAction)
181      compat x@(InL _) = x
182      compat x@(InR action)
183        | Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport
184        = x
185        | otherwise = InL cmd
186        where
187          cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams)
188          cmdParams = [toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))]
189
190      wasRequested :: (Command |? CodeAction) -> Bool
191      wasRequested (InL _) = True
192      wasRequested (InR ca)
193        | Nothing <- _only context = True
194        | Just (List allowed) <- _only context
195        -- See https://github.com/microsoft/language-server-protocol/issues/970
196        -- This is somewhat vague, but due to the hierarchical nature of action kinds, we
197        -- should check whether the requested kind is a *prefix* of the action kind.
198        -- That means, for example, we will return actions with kinds `quickfix.import` and
199        -- `quickfix.somethingElse` if the requested kind is `quickfix`.
200        -- TODO: add helpers in `lsp` for handling code action hierarchies
201        -- For now we abuse the fact that the JSON representation gives us the hierarchical string.
202        , Just caKind <- ca ^. kind
203        , String caKindStr <- toJSON caKind =
204                any (\k -> k `T.isPrefixOf` caKindStr) [kstr | k <- allowed, let String kstr = toJSON k ]
205        | otherwise = False
206
207instance PluginMethod TextDocumentCodeLens where
208  pluginEnabled _ = pluginEnabledConfig plcCodeLensOn
209instance PluginMethod TextDocumentRename where
210  pluginEnabled _ = pluginEnabledConfig plcRenameOn
211instance PluginMethod TextDocumentHover where
212  pluginEnabled _ = pluginEnabledConfig plcHoverOn
213  combineResponses _ _ _ _ (catMaybes . toList -> hs) = h
214    where
215      r = listToMaybe $ mapMaybe (^. range) hs
216      h = case foldMap (^. contents) hs of
217            HoverContentsMS (List []) -> Nothing
218            hh                        -> Just $ Hover hh r
219
220instance PluginMethod TextDocumentDocumentSymbol where
221  pluginEnabled _ = pluginEnabledConfig plcSymbolsOn
222  combineResponses _ _ (ClientCapabilities _ tdc _ _) params xs = res
223    where
224      uri' = params ^. textDocument . uri
225      supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport)
226      dsOrSi = fmap toEither xs
227      res
228        | supportsHierarchy = InL $ sconcat $ fmap (either id (fmap siToDs)) dsOrSi
229        | otherwise = InR $ sconcat $ fmap (either (List . concatMap dsToSi) id) dsOrSi
230      siToDs (SymbolInformation name kind _tags dep (Location _uri range) cont)
231        = DocumentSymbol name cont kind Nothing dep range range Nothing
232      dsToSi = go Nothing
233      go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation]
234      go parent ds =
235        let children' :: [SymbolInformation]
236            children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children))
237            loc = Location uri' (ds ^. range)
238            name' = ds ^. name
239            si = SymbolInformation name' (ds ^. kind) Nothing (ds ^. deprecated) loc parent
240        in [si] <> children'
241
242instance PluginMethod TextDocumentCompletion where
243  pluginEnabled _ = pluginEnabledConfig plcCompletionOn
244  combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs
245      where
246        limit = maxCompletions conf
247        combine :: [List CompletionItem |? CompletionList] -> ((List CompletionItem) |? CompletionList)
248        combine cs = go True mempty cs
249
250        go !comp acc [] =
251          InR (CompletionList comp (List $ DList.toList acc))
252        go comp acc (InL (List ls) : rest) =
253          go comp (acc <> DList.fromList ls) rest
254        go comp acc (InR (CompletionList comp' (List ls)) : rest) =
255          go (comp && comp') (acc <> DList.fromList ls) rest
256
257        -- boolean disambiguators
258        isCompleteResponse, isIncompleteResponse :: Bool
259        isIncompleteResponse = True
260        isCompleteResponse = False
261
262        consumeCompletionResponse limit it@(InR (CompletionList _ (List xx))) =
263          case splitAt limit xx of
264            -- consumed all the items, return the result as is
265            (_, []) -> (limit - length xx, it)
266            -- need to crop the response, set the 'isIncomplete' flag
267            (xx', _) -> (0, InR (CompletionList isIncompleteResponse (List xx')))
268        consumeCompletionResponse n (InL (List xx)) =
269          consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx)))
270
271instance PluginMethod TextDocumentFormatting where
272  pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid
273  combineResponses _ _ _ _ (x :| _) = x
274
275instance PluginMethod TextDocumentRangeFormatting where
276  pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid
277  combineResponses _ _ _ _ (x :| _) = x
278
279instance PluginMethod TextDocumentPrepareCallHierarchy where
280  pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn
281
282instance PluginMethod CallHierarchyIncomingCalls where
283  pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn
284
285instance PluginMethod CallHierarchyOutgoingCalls where
286  pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn
287
288-- ---------------------------------------------------------------------
289
290-- | Methods which have a PluginMethod instance
291data IdeMethod (m :: Method FromClient Request) = PluginMethod m => IdeMethod (SMethod m)
292instance GEq IdeMethod where
293  geq (IdeMethod a) (IdeMethod b) = geq a b
294instance GCompare IdeMethod where
295  gcompare (IdeMethod a) (IdeMethod b) = gcompare a b
296
297-- | Methods which have a PluginMethod instance
298data IdeNotification (m :: Method FromClient Notification) = HasTracing (MessageParams m) => IdeNotification (SMethod m)
299instance GEq IdeNotification where
300  geq (IdeNotification a) (IdeNotification b) = geq a b
301instance GCompare IdeNotification where
302  gcompare (IdeNotification a) (IdeNotification b) = gcompare a b
303
304-- | Combine handlers for the
305newtype PluginHandler a (m :: Method FromClient Request)
306  = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))
307
308newtype PluginNotificationHandler a (m :: Method FromClient Notification)
309  = PluginNotificationHandler (PluginId -> a -> MessageParams m -> LspM Config ())
310
311newtype PluginHandlers a             = PluginHandlers             (DMap IdeMethod       (PluginHandler a))
312newtype PluginNotificationHandlers a = PluginNotificationHandlers (DMap IdeNotification (PluginNotificationHandler a))
313instance Semigroup (PluginHandlers a) where
314  (PluginHandlers a) <> (PluginHandlers b) = PluginHandlers $ DMap.unionWithKey go a b
315    where
316      go _ (PluginHandler f) (PluginHandler g) = PluginHandler $ \pid ide params ->
317        (<>) <$> f pid ide params <*> g pid ide params
318
319instance Monoid (PluginHandlers a) where
320  mempty = PluginHandlers mempty
321
322instance Semigroup (PluginNotificationHandlers a) where
323  (PluginNotificationHandlers a) <> (PluginNotificationHandlers b) = PluginNotificationHandlers $ DMap.unionWithKey go a b
324    where
325      go _ (PluginNotificationHandler f) (PluginNotificationHandler g) = PluginNotificationHandler $ \pid ide params ->
326        f pid ide params >> g pid ide params
327
328instance Monoid (PluginNotificationHandlers a) where
329  mempty = PluginNotificationHandlers mempty
330
331type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either ResponseError (ResponseResult m))
332
333type PluginNotificationMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config ()
334
335-- | Make a handler for plugins with no extra data
336mkPluginHandler
337  :: PluginMethod m
338  => SClientMethod m
339  -> PluginMethodHandler ideState m
340  -> PluginHandlers ideState
341mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler f')
342  where
343    f' pid ide params = pure <$> f ide pid params
344
345-- | Make a handler for plugins with no extra data
346mkPluginNotificationHandler
347  :: HasTracing (MessageParams m)
348  => SClientMethod (m :: Method FromClient Notification)
349  -> PluginNotificationMethodHandler ideState m
350  -> PluginNotificationHandlers ideState
351mkPluginNotificationHandler m f
352    = PluginNotificationHandlers $ DMap.singleton (IdeNotification m) (PluginNotificationHandler f')
353  where
354    f' pid ide = f ide pid
355
356defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState
357defaultPluginDescriptor plId =
358  PluginDescriptor
359    plId
360    mempty
361    mempty
362    mempty
363    defaultConfigDescriptor
364    mempty
365    mempty
366    Nothing
367
368newtype CommandId = CommandId T.Text
369  deriving (Show, Read, Eq, Ord)
370instance IsString CommandId where
371  fromString = CommandId . T.pack
372
373data PluginCommand ideState = forall a. (FromJSON a) =>
374  PluginCommand { commandId   :: CommandId
375                , commandDesc :: T.Text
376                , commandFunc :: CommandFunction ideState a
377                }
378
379-- ---------------------------------------------------------------------
380
381type CommandFunction ideState a
382  = ideState
383  -> a
384  -> LspM Config (Either ResponseError Value)
385
386-- ---------------------------------------------------------------------
387
388newtype PluginId = PluginId T.Text
389  deriving (Show, Read, Eq, Ord)
390instance IsString PluginId where
391  fromString = PluginId . T.pack
392
393configForPlugin :: Config -> PluginId -> PluginConfig
394configForPlugin config (PluginId plugin)
395    = Map.findWithDefault Data.Default.def plugin (plugins config)
396
397-- | Checks that a given plugin is both enabled and the specific feature is
398-- enabled
399pluginEnabledConfig :: (PluginConfig -> Bool) -> PluginId -> Config -> Bool
400pluginEnabledConfig f pid config = plcGlobalOn pluginConfig && f pluginConfig
401  where
402    pluginConfig = configForPlugin config pid
403
404-- ---------------------------------------------------------------------
405
406-- | Format the given Text as a whole or only a @Range@ of it.
407-- Range must be relative to the text to format.
408-- To format the whole document, read the Text from the file and use 'FormatText'
409-- as the FormattingType.
410data FormattingType = FormatText
411                    | FormatRange Range
412
413
414type FormattingMethod m =
415  ( J.HasOptions (MessageParams m) FormattingOptions
416  , J.HasTextDocument (MessageParams m) TextDocumentIdentifier
417  , ResponseResult m ~ List TextEdit
418  )
419
420type FormattingHandler a
421  =  a
422  -> FormattingType
423  -> T.Text
424  -> NormalizedFilePath
425  -> FormattingOptions
426  -> LspM Config (Either ResponseError (List TextEdit))
427
428mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a
429mkFormattingHandlers f = mkPluginHandler STextDocumentFormatting (provider STextDocumentFormatting)
430                      <> mkPluginHandler STextDocumentRangeFormatting (provider STextDocumentRangeFormatting)
431  where
432    provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m
433    provider m ide _pid params
434      | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
435        mf <- getVirtualFile $ toNormalizedUri uri
436        case mf of
437          Just vf -> do
438            let typ = case m of
439                  STextDocumentFormatting -> FormatText
440                  STextDocumentRangeFormatting -> FormatRange (params ^. J.range)
441                  _ -> error "mkFormattingHandlers: impossible"
442            f ide typ (virtualFileText vf) nfp opts
443          Nothing -> pure $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri
444
445      | otherwise = pure $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri
446      where
447        uri = params ^. J.textDocument . J.uri
448        opts = params ^. J.options
449
450-- ---------------------------------------------------------------------
451
452responseError :: T.Text -> ResponseError
453responseError txt = ResponseError InvalidParams txt Nothing
454
455-- ---------------------------------------------------------------------
456
457data FallbackCodeActionParams =
458  FallbackCodeActionParams
459    { fallbackWorkspaceEdit :: Maybe WorkspaceEdit
460    , fallbackCommand       :: Maybe Command
461    }
462  deriving (Generic, ToJSON, FromJSON)
463
464-- ---------------------------------------------------------------------
465
466otSetUri :: SpanInFlight -> Uri -> IO ()
467otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t)
468
469class HasTracing a where
470  traceWithSpan :: SpanInFlight -> a -> IO ()
471  traceWithSpan _ _ = pure ()
472
473instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where
474  traceWithSpan sp a = otSetUri sp (a ^. J.textDocument . J.uri)
475
476instance HasTracing Value
477instance HasTracing ExecuteCommandParams
478instance HasTracing DidChangeWatchedFilesParams
479instance HasTracing DidChangeWorkspaceFoldersParams
480instance HasTracing DidChangeConfigurationParams
481instance HasTracing InitializeParams
482instance HasTracing (Maybe InitializedParams)
483instance HasTracing WorkspaceSymbolParams where
484  traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query)
485instance HasTracing CallHierarchyIncomingCallsParams
486instance HasTracing CallHierarchyOutgoingCallsParams
487
488-- ---------------------------------------------------------------------
489
490{-# NOINLINE pROCESS_ID #-}
491{-# LANGUAGE DerivingStrategies         #-}
492{-# LANGUAGE GeneralizedNewtypeDeriving #-}
493pROCESS_ID :: T.Text
494pROCESS_ID = unsafePerformIO getPid
495
496mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [Value] -> Command
497mkLspCommand plid cn title args' = Command title cmdId args
498  where
499    cmdId = mkLspCmdId pROCESS_ID plid cn
500    args = List <$> args'
501
502mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text
503mkLspCmdId pid (PluginId plid) (CommandId cid)
504  = pid <> ":" <> plid <> ":" <> cid
505
506-- | Get the operating system process id for the running server
507-- instance. This should be the same for the lifetime of the instance,
508-- and different from that of any other currently running instance.
509getPid :: IO T.Text
510getPid = T.pack . show <$> getProcessID
511
512getProcessID :: IO Int
513installSigUsr1Handler :: IO () -> IO ()
514
515#ifdef mingw32_HOST_OS
516getProcessID = fromIntegral <$> P.getCurrentProcessId
517installSigUsr1Handler _ = return ()
518
519#else
520getProcessID = fromIntegral <$> P.getProcessID
521
522installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing
523#endif
524