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