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