1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3{-# LANGUAGE DerivingStrategies #-} 4{-# LANGUAGE DuplicateRecordFields #-} 5{-# LANGUAGE FlexibleContexts #-} 6{-# LANGUAGE GADTs #-} 7{-# LANGUAGE LambdaCase #-} 8{-# LANGUAGE MagicHash #-} 9{-# LANGUAGE NamedFieldPuns #-} 10{-# LANGUAGE OverloadedStrings #-} 11{-# LANGUAGE RankNTypes #-} 12{-# LANGUAGE RecordWildCards #-} 13{-# LANGUAGE ScopedTypeVariables #-} 14{-# LANGUAGE TupleSections #-} 15{-# LANGUAGE TypeApplications #-} 16{-# LANGUAGE TypeFamilies #-} 17{-# LANGUAGE ViewPatterns #-} 18 19module Ide.Plugin.Splice 20 ( descriptor, 21 ) 22where 23 24import Control.Applicative (Alternative ((<|>))) 25import Control.Arrow 26import qualified Control.Foldl as L 27import Control.Lens (Identity (..), ix, view, (%~), 28 (<&>), (^.)) 29import Control.Monad 30import Control.Monad.Extra (eitherM) 31import qualified Control.Monad.Fail as Fail 32import Control.Monad.IO.Unlift 33import Control.Monad.Trans.Class 34import Control.Monad.Trans.Except 35import Control.Monad.Trans.Maybe 36import Data.Aeson 37import Data.Foldable (Foldable (foldl')) 38import Data.Function 39import Data.Generics 40import qualified Data.Kind as Kinds 41import Data.List (sortOn) 42import Data.Maybe (fromMaybe, listToMaybe, 43 mapMaybe) 44import qualified Data.Text as T 45import Development.IDE 46import Development.IDE.GHC.Compat hiding (getLoc) 47import Development.IDE.GHC.ExactPrint 48import Exception 49import GHC.Exts 50import GhcMonad 51import GhcPlugins hiding (Var, getLoc, (<>)) 52import Ide.Plugin.Splice.Types 53import Ide.Types 54import Language.Haskell.GHC.ExactPrint (setPrecedingLines, 55 uniqueSrcSpanT) 56import Language.LSP.Server 57import Language.LSP.Types 58import Language.LSP.Types.Capabilities 59import qualified Language.LSP.Types.Lens as J 60import RnSplice 61import TcRnMonad 62 63descriptor :: PluginId -> PluginDescriptor IdeState 64descriptor plId = 65 (defaultPluginDescriptor plId) 66 { pluginCommands = commands 67 , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction 68 } 69 70commands :: [PluginCommand IdeState] 71commands = 72 [ PluginCommand expandInplaceId inplaceCmdName $ expandTHSplice Inplace 73 -- , PluginCommand expandCommentedId commentedCmdName $ expandTHSplice Commented 74 ] 75 76newtype SubSpan = SubSpan {runSubSpan :: SrcSpan} 77 78instance Eq SubSpan where 79 (==) = (==) `on` runSubSpan 80 81instance Ord SubSpan where 82 (<=) = coerce isSubspanOf 83 84expandTHSplice :: 85 -- | Inplace? 86 ExpandStyle -> 87 CommandFunction IdeState ExpandSpliceParams 88expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do 89 clientCapabilities <- getClientCapabilities 90 rio <- askRunInIO 91 let reportEditor :: ReportEditor 92 reportEditor msgTy msgs = liftIO $ rio $ sendNotification SWindowShowMessage (ShowMessageParams msgTy (T.unlines msgs)) 93 expandManually fp = do 94 mresl <- 95 liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck fp 96 (TcModuleResult {..}, _) <- 97 maybe 98 (throwE "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (errornous) macro and expand splice again." 99 ) 100 pure mresl 101 reportEditor 102 MtWarning 103 [ "Expansion in type-checking phase failed;" 104 , "trying to expand manually, but note that it is less rigorous." 105 ] 106 pm <- 107 liftIO $ 108 runAction "expandTHSplice.fallback.GetParsedModule" ideState $ 109 use_ GetParsedModule fp 110 (ps, hscEnv, _dflags) <- setupHscEnv ideState fp pm 111 112 manualCalcEdit 113 clientCapabilities 114 reportEditor 115 range 116 ps 117 hscEnv 118 tmrTypechecked 119 spliceSpan 120 _eStyle 121 params 122 123 withTypeChecked fp TcModuleResult {..} = do 124 (ps, _hscEnv, dflags) <- setupHscEnv ideState fp tmrParsed 125 let Splices {..} = tmrTopLevelSplices 126 let exprSuperSpans = 127 listToMaybe $ findSubSpansDesc srcSpan exprSplices 128 _patSuperSpans = 129#if __GLASGOW_HASKELL__ == 808 130 fmap (second dL) $ 131#endif 132 listToMaybe $ findSubSpansDesc srcSpan patSplices 133 typeSuperSpans = 134 listToMaybe $ findSubSpansDesc srcSpan typeSplices 135 declSuperSpans = 136 listToMaybe $ findSubSpansDesc srcSpan declSplices 137 138 graftSpliceWith :: 139 forall ast. 140 HasSplice ast => 141 Maybe (SrcSpan, Located (ast GhcPs)) -> 142 Maybe (Either String WorkspaceEdit) 143 graftSpliceWith expandeds = 144 expandeds <&> \(_, expanded) -> 145 transform 146 dflags 147 clientCapabilities 148 uri 149 (graft (RealSrcSpan spliceSpan) expanded) 150 ps 151 maybe (throwE "No splice information found") (either throwE pure) $ 152 case spliceContext of 153 Expr -> graftSpliceWith exprSuperSpans 154 Pat -> 155 156 graftSpliceWith _patSuperSpans 157 158 HsType -> graftSpliceWith typeSuperSpans 159 HsDecl -> 160 declSuperSpans <&> \(_, expanded) -> 161 transform 162 dflags 163 clientCapabilities 164 uri 165 (graftDecls (RealSrcSpan spliceSpan) expanded) 166 ps 167 <&> 168 -- FIXME: Why ghc-exactprint sweeps preceeding comments? 169 adjustToRange uri range 170 171 res <- liftIO $ runMaybeT $ do 172 173 fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri uri 174 eedits <- 175 ( lift . runExceptT . withTypeChecked fp 176 =<< MaybeT 177 (runAction "expandTHSplice.TypeCheck" ideState $ use TypeCheck fp) 178 ) 179 <|> lift (runExceptT $ expandManually fp) 180 181 case eedits of 182 Left err -> do 183 reportEditor 184 MtError 185 ["Error during expanding splice: " <> T.pack err] 186 pure (Left $ responseError $ T.pack err) 187 Right edits -> 188 pure (Right edits) 189 case res of 190 Nothing -> pure $ Right Null 191 Just (Left err) -> pure $ Left err 192 Just (Right edit) -> do 193 _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) 194 pure $ Right Null 195 196 where 197 range = realSrcSpanToRange spliceSpan 198 srcSpan = RealSrcSpan spliceSpan 199 200 201setupHscEnv 202 :: IdeState 203 -> NormalizedFilePath 204 -> ParsedModule 205 -> ExceptT String IO (Annotated ParsedSource, HscEnv, DynFlags) 206setupHscEnv ideState fp pm = do 207 hscEnvEq <- 208 liftIO $ 209 runAction "expandTHSplice.fallback.ghcSessionDeps" ideState $ 210 use_ GhcSessionDeps fp 211 let ps = annotateParsedSource pm 212 hscEnv0 = hscEnvWithImportPaths hscEnvEq 213 modSum = pm_mod_summary pm 214 df' <- liftIO $ setupDynFlagsForGHCiLike hscEnv0 $ ms_hspp_opts modSum 215 let hscEnv = hscEnv0 { hsc_dflags = df' } 216 pure (ps, hscEnv, df') 217 218setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags 219setupDynFlagsForGHCiLike env dflags = do 220 let dflags3 = 221 dflags 222 { hscTarget = HscInterpreted 223 , ghcMode = CompManager 224 , ghcLink = LinkInMemory 225 } 226 platform = targetPlatform dflags3 227 dflags3a = updateWays $ dflags3 {ways = interpWays} 228 dflags3b = 229 foldl gopt_set dflags3a $ 230 concatMap (wayGeneralFlags platform) interpWays 231 dflags3c = 232 foldl gopt_unset dflags3b $ 233 concatMap (wayUnsetGeneralFlags platform) interpWays 234 dflags4 = 235 dflags3c 236 `gopt_set` Opt_ImplicitImportQualified 237 `gopt_set` Opt_IgnoreOptimChanges 238 `gopt_set` Opt_IgnoreHpcChanges 239 `gopt_unset` Opt_DiagnosticsShowCaret 240 initializePlugins env dflags4 241 242adjustToRange :: Uri -> Range -> WorkspaceEdit -> WorkspaceEdit 243adjustToRange uri ran (WorkspaceEdit mhult mlt x) = 244 WorkspaceEdit (adjustWS <$> mhult) (fmap adjustDoc <$> mlt) x 245 where 246 adjustTextEdits :: Traversable f => f TextEdit -> f TextEdit 247 adjustTextEdits eds = 248 let Just minStart = 249 L.fold 250 (L.premap (view J.range) L.minimum) 251 eds 252 in adjustLine minStart <$> eds 253 254 adjustATextEdits :: Traversable f => f (TextEdit |? AnnotatedTextEdit) -> f (TextEdit |? AnnotatedTextEdit) 255 adjustATextEdits = fmap $ \case 256 InL t -> InL $ runIdentity $ adjustTextEdits (Identity t) 257 InR AnnotatedTextEdit{_range, _newText, _annotationId} -> 258 let oldTE = TextEdit{_range,_newText} 259 in let TextEdit{_range,_newText} = runIdentity $ adjustTextEdits (Identity oldTE) 260 in InR $ AnnotatedTextEdit{_range,_newText,_annotationId} 261 262 adjustWS = ix uri %~ adjustTextEdits 263 adjustDoc :: DocumentChange -> DocumentChange 264 adjustDoc (InR es) = InR es 265 adjustDoc (InL es) 266 | es ^. J.textDocument . J.uri == uri = 267 InL $ es & J.edits %~ adjustATextEdits 268 | otherwise = InL es 269 270 adjustLine :: Range -> TextEdit -> TextEdit 271 adjustLine bad = 272 J.range %~ \r -> 273 if r == bad then ran else bad 274 275findSubSpansDesc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)] 276findSubSpansDesc srcSpan = 277 sortOn (Down . SubSpan . fst) 278 . mapMaybe 279 ( \(L spn _, e) -> do 280 guard (spn `isSubspanOf` srcSpan) 281 pure (spn, e) 282 ) 283 284data SpliceClass where 285 OneToOneAST :: HasSplice ast => Proxy# ast -> SpliceClass 286 IsHsDecl :: SpliceClass 287 288class (Outputable (ast GhcRn), ASTElement (ast GhcPs)) => HasSplice ast where 289 type SpliceOf ast :: Kinds.Type -> Kinds.Type 290 type SpliceOf ast = HsSplice 291 matchSplice :: Proxy# ast -> ast GhcPs -> Maybe (SpliceOf ast GhcPs) 292 expandSplice :: Proxy# ast -> SpliceOf ast GhcPs -> RnM (Either (ast GhcPs) (ast GhcRn), FreeVars) 293 294instance HasSplice HsExpr where 295 matchSplice _ (HsSpliceE _ spl) = Just spl 296 matchSplice _ _ = Nothing 297 expandSplice _ = fmap (first Right) . rnSpliceExpr 298 299instance HasSplice Pat where 300 matchSplice _ (SplicePat _ spl) = Just spl 301 matchSplice _ _ = Nothing 302 expandSplice _ = rnSplicePat 303 304 305instance HasSplice HsType where 306 matchSplice _ (HsSpliceTy _ spl) = Just spl 307 matchSplice _ _ = Nothing 308 expandSplice _ = fmap (first Right) . rnSpliceType 309 310classifyAST :: SpliceContext -> SpliceClass 311classifyAST = \case 312 Expr -> OneToOneAST @HsExpr proxy# 313 HsDecl -> IsHsDecl 314 Pat -> OneToOneAST @Pat proxy# 315 HsType -> OneToOneAST @HsType proxy# 316 317type ReportEditor = forall m. MonadIO m => MessageType -> [T.Text] -> m () 318 319manualCalcEdit :: 320 ClientCapabilities -> 321 ReportEditor -> 322 Range -> 323 Annotated ParsedSource -> 324 HscEnv -> 325 TcGblEnv -> 326 RealSrcSpan -> 327 ExpandStyle -> 328 ExpandSpliceParams -> 329 ExceptT String IO WorkspaceEdit 330manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {..} = do 331 (warns, resl) <- 332 ExceptT $ do 333 ((warns, errs), eresl) <- 334 initTcWithGbl hscEnv typechkd srcSpan $ 335 case classifyAST spliceContext of 336 IsHsDecl -> fmap (fmap $ adjustToRange uri ran) $ 337 flip (transformM dflags clientCapabilities uri) ps $ 338 graftDeclsWithM (RealSrcSpan srcSpan) $ \case 339 (L _spn (SpliceD _ (SpliceDecl _ (L _ spl) _))) -> do 340 eExpr <- 341 eitherM (fail . show) pure 342 $ lift 343 ( lift $ 344 gtry @_ @SomeException $ 345 (fst <$> rnTopSpliceDecls spl) 346 ) 347 pure $ Just eExpr 348 _ -> pure Nothing 349 OneToOneAST astP -> 350 flip (transformM dflags clientCapabilities uri) ps $ 351 graftWithM (RealSrcSpan srcSpan) $ \case 352 (L _spn (matchSplice astP -> Just spl)) -> do 353 eExpr <- 354 eitherM (fail . show) pure 355 $ lift 356 ( lift $ 357 gtry @_ @SomeException $ 358 (fst <$> expandSplice astP spl) 359 ) 360 Just <$> either (pure . L _spn) (unRenamedE dflags) eExpr 361 _ -> pure Nothing 362 pure $ (warns,) <$> fromMaybe (Left $ show errs) eresl 363 364 unless 365 (null warns) 366 $ reportEditor 367 MtWarning 368 [ "Warning during expanding: " 369 , "" 370 , T.pack (show warns) 371 ] 372 pure resl 373 where 374 dflags = hsc_dflags hscEnv 375 376-- | FIXME: Is thereAny "clever" way to do this exploiting TTG? 377unRenamedE :: 378 forall ast m. 379 (Fail.MonadFail m, HasSplice ast) => 380 DynFlags -> 381 ast GhcRn -> 382 TransformT m (Located (ast GhcPs)) 383unRenamedE dflags expr = do 384 uniq <- show <$> uniqueSrcSpanT 385 (anns, expr') <- 386 either (fail . show) pure $ 387 parseAST @(ast GhcPs) dflags uniq $ 388 showSDoc dflags $ ppr expr 389 let _anns' = setPrecedingLines expr' 0 1 anns 390 pure expr' 391 392data SearchResult r = 393 Continue | Stop | Here r 394 deriving (Read, Show, Eq, Ord, Data, Typeable) 395 396fromSearchResult :: SearchResult a -> Maybe a 397fromSearchResult (Here r) = Just r 398fromSearchResult _ = Nothing 399 400-- TODO: workaround when HieAst unavailable (e.g. when the module itself errors) 401-- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs? 402codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction 403codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $ 404 fmap (maybe (Right $ List []) Right) $ 405 runMaybeT $ do 406 fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri 407 ParsedModule {..} <- 408 MaybeT . runAction "splice.codeAction.GitHieAst" state $ 409 use GetParsedModule fp 410 let spn = rangeToRealSrcSpan fp ran 411 mouterSplice = something' (detectSplice spn) pm_parsed_source 412 mcmds <- forM mouterSplice $ 413 \(spliceSpan, spliceContext) -> 414 forM expandStyles $ \(_, (title, cmdId)) -> do 415 let params = ExpandSpliceParams {uri = theUri, ..} 416 act = mkLspCommand plId cmdId title (Just [toJSON params]) 417 pure $ 418 InR $ 419 CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing Nothing Nothing (Just act) Nothing 420 421 pure $ maybe mempty List mcmds 422 where 423 theUri = docId ^. J.uri 424 detectSplice :: 425 RealSrcSpan -> 426 GenericQ (SearchResult (RealSrcSpan, SpliceContext)) 427 detectSplice spn = 428 mkQ 429 Continue 430 ( \case 431 (L l@(RealSrcSpan spLoc) expr :: LHsExpr GhcPs) 432 | RealSrcSpan spn `isSubspanOf` l -> 433 case expr of 434 HsSpliceE {} -> Here (spLoc, Expr) 435 _ -> Continue 436 _ -> Stop 437 ) 438 `extQ` \case 439#if __GLASGOW_HASKELL__ == 808 440 (dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc) pat :: Located (Pat GhcPs)) 441#else 442 (L l@(RealSrcSpan spLoc) pat :: LPat GhcPs) 443#endif 444 | RealSrcSpan spn `isSubspanOf` l -> 445 case pat of 446 SplicePat{} -> Here (spLoc, Pat) 447 _ -> Continue 448 _ -> Stop 449 `extQ` \case 450 (L l@(RealSrcSpan spLoc) ty :: LHsType GhcPs) 451 | RealSrcSpan spn `isSubspanOf` l -> 452 case ty of 453 HsSpliceTy {} -> Here (spLoc, HsType) 454 _ -> Continue 455 _ -> Stop 456 `extQ` \case 457 (L l@(RealSrcSpan spLoc) decl :: LHsDecl GhcPs) 458 | RealSrcSpan spn `isSubspanOf` l -> 459 case decl of 460 SpliceD {} -> Here (spLoc, HsDecl) 461 _ -> Continue 462 _ -> Stop 463 464-- | Like 'something', but performs top-down searching, cutoffs when 'Stop' received, 465-- and picks inenrmost result. 466something' :: forall a. GenericQ (SearchResult a) -> GenericQ (Maybe a) 467something' f = go 468 where 469 go :: GenericQ (Maybe a) 470 go x = 471 case f x of 472 Stop -> Nothing 473 resl -> foldl' (flip (<|>)) (fromSearchResult resl) (gmapQ go x) 474