10
10
{-# LANGUAGE NamedFieldPuns #-}
11
11
{-# LANGUAGE OverloadedLabels #-}
12
12
{-# LANGUAGE OverloadedStrings #-}
13
- {-# LANGUAGE PackageImports #-}
14
13
{-# LANGUAGE PatternSynonyms #-}
15
14
{-# LANGUAGE RecordWildCards #-}
16
15
{-# LANGUAGE ScopedTypeVariables #-}
@@ -77,22 +76,22 @@ import Development.IDE.GHC.Compat (DynFlags,
77
76
topDir ,
78
77
wopt )
79
78
import qualified Development.IDE.GHC.Compat.Util as EnumSet
79
+ import qualified GHC.Data.Strict as Strict
80
+ import System.FilePath (takeFileName )
81
+ import System.IO.Temp
80
82
81
- #if MIN_GHC_API_VERSION(9,4,0)
82
- import qualified "ghc-lib-parser" GHC.Data.Strict as Strict
83
- #endif
83
+ -- TODO make this work for GHC < 9.2.8?
84
84
#if MIN_GHC_API_VERSION(9,0,0)
85
- import "ghc-lib-parser" GHC.Types.SrcLoc hiding
85
+ import GHC.Types.SrcLoc hiding
86
86
(RealSrcSpan )
87
- import qualified "ghc-lib-parser" GHC.Types.SrcLoc as GHC
87
+ import qualified GHC.Types.SrcLoc as GHC
88
88
#else
89
- import "ghc-lib-parser" SrcLoc hiding
89
+ import qualified SrcLoc as GHC
90
+ import SrcLoc hiding
90
91
(RealSrcSpan )
91
- import qualified "ghc-lib-parser" SrcLoc as GHC
92
92
#endif
93
- import "ghc-lib-parser" GHC.LanguageExtensions (Extension )
93
+ import GHC.LanguageExtensions (Extension )
94
94
import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension )
95
- import System.FilePath (takeFileName )
96
95
import System.IO (IOMode (WriteMode ),
97
96
hClose ,
98
97
hPutStr ,
@@ -101,21 +100,23 @@ import System.IO (IOMode (Wri
101
100
noNewlineTranslation ,
102
101
utf8 ,
103
102
withFile )
104
- import System.IO.Temp
105
103
#else
106
104
import Development.IDE.GHC.Compat hiding
107
105
(setEnv ,
108
106
(<+>) )
109
107
import GHC.Generics (Associativity (LeftAssociative , NotAssociative , RightAssociative ))
108
+ import Language.Haskell.GHC.ExactPrint (makeDeltaAst )
109
+ import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform )
110
110
#if MIN_GHC_API_VERSION(9,2,0)
111
- import Language.Haskell.GHC.ExactPrint.ExactPrint ( deltaOptions )
111
+ import qualified GHC.Types.Fixity as GHC
112
112
#else
113
113
import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions )
114
+ import System.IO.Temp
114
115
#endif
115
- import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform )
116
- import Language.Haskell.GHC.ExactPrint.Types (Rigidity (.. ))
117
116
import Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx (applyFixities )
118
117
import qualified Refact.Fixity as Refact
118
+ #if MIN_GHC_API_VERSION(9,2,0)
119
+ #endif
119
120
#endif
120
121
import Ide.Plugin.Config hiding
121
122
(Config )
@@ -132,7 +133,8 @@ import Language.LSP.Protocol.Message
132
133
import Language.LSP.Protocol.Types hiding
133
134
(Null )
134
135
import qualified Language.LSP.Protocol.Types as LSP
135
- import Language.LSP.Server (getVersionedTextDoc )
136
+ import Language.LSP.Server (getClientCapabilities ,
137
+ getVersionedTextDoc )
136
138
137
139
import qualified Development.IDE.Core.Shake as Shake
138
140
import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits ),
@@ -170,6 +172,11 @@ instance Pretty Log where
170
172
LogResolve msg -> pretty msg
171
173
172
174
#ifdef HLINT_ON_GHC_LIB
175
+ #if MIN_GHC_API_VERSION(9,4,0)
176
+ fromStrictMaybe :: Strict. Maybe a -> Maybe a
177
+ fromStrictMaybe (Strict. Just a ) = Just a
178
+ fromStrictMaybe Strict. Nothing = Nothing
179
+ #endif
173
180
-- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib
174
181
#if !MIN_GHC_API_VERSION(9,0,0)
175
182
type BufSpan = ()
@@ -185,11 +192,6 @@ pattern RealSrcSpan x y <- ((,Nothing) -> (GHC.RealSrcSpan x, y))
185
192
{-# COMPLETE RealSrcSpan, UnhelpfulSpan #-}
186
193
#endif
187
194
188
- #if MIN_GHC_API_VERSION(9,4,0)
189
- fromStrictMaybe :: Strict. Maybe a -> Maybe a
190
- fromStrictMaybe (Strict. Just a ) = Just a
191
- fromStrictMaybe Strict. Nothing = Nothing
192
- #endif
193
195
194
196
descriptor :: Recorder (WithPriority Log ) -> PluginId -> PluginDescriptor IdeState
195
197
descriptor recorder plId =
@@ -315,22 +317,20 @@ getIdeas recorder nfp = do
315
317
mbpm <- getParsedModuleWithComments nfp
316
318
return $ createModule <$> mbpm
317
319
where
318
- createModule pm = Right (createModuleEx anns (applyParseFlagsFixities modu))
319
- where anns = pm_annotations pm
320
- modu = pm_parsed_source pm
320
+ createModule = Right . createModuleEx . applyParseFlagsFixities . pm_parsed_source
321
321
322
322
applyParseFlagsFixities :: ParsedSource -> ParsedSource
323
- applyParseFlagsFixities modul = GhclibParserEx. applyFixities (parseFlagsToFixities _flags) modul
323
+ applyParseFlagsFixities = GhclibParserEx. applyFixities (parseFlagsToFixities _flags)
324
324
325
325
parseFlagsToFixities :: ParseFlags -> [(String , Fixity )]
326
326
parseFlagsToFixities = map toFixity . Hlint. fixities
327
327
328
328
toFixity :: FixityInfo -> (String , Fixity )
329
329
toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir)
330
330
where
331
- f LeftAssociative = InfixL
332
- f RightAssociative = InfixR
333
- f NotAssociative = InfixN
331
+ f LeftAssociative = GHC. InfixL
332
+ f RightAssociative = GHC. InfixR
333
+ f NotAssociative = GHC. InfixN
334
334
#else
335
335
moduleEx flags = do
336
336
mbpm <- getParsedModuleWithComments nfp
@@ -443,9 +443,10 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context
443
443
resolveProvider :: Recorder (WithPriority Log ) -> ResolveFunction IdeState HlintResolveCommands Method_CodeActionResolve
444
444
resolveProvider recorder ideState _plId ca uri resolveValue = do
445
445
file <- getNormalizedFilePathE uri
446
+ clientCapabilities <- lift getClientCapabilities
446
447
case resolveValue of
447
448
(ApplyHint verTxtDocId oneHint) -> do
448
- edit <- ExceptT $ liftIO $ applyHint recorder ideState file oneHint verTxtDocId
449
+ edit <- ExceptT $ liftIO $ applyHint clientCapabilities recorder ideState file oneHint verTxtDocId
449
450
pure $ ca & LSP. edit ?~ edit
450
451
(IgnoreHint verTxtDocId hintTitle ) -> do
451
452
edit <- ExceptT $ liftIO $ ignoreHint recorder ideState file verTxtDocId hintTitle
@@ -543,8 +544,8 @@ data OneHint =
543
544
, oneHintTitle :: HintTitle
544
545
} deriving (Generic , Eq , Show , ToJSON , FromJSON )
545
546
546
- applyHint :: Recorder (WithPriority Log ) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit )
547
- applyHint recorder ide nfp mhint verTxtDocId =
547
+ applyHint :: ClientCapabilities -> Recorder (WithPriority Log ) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit )
548
+ applyHint clientCapabilities recorder ide nfp mhint verTxtDocId =
548
549
runExceptT $ do
549
550
let runAction' :: Action a -> IO a
550
551
runAction' = runAction " applyHint" ide
@@ -573,7 +574,7 @@ applyHint recorder ide nfp mhint verTxtDocId =
573
574
hSetEncoding h utf8
574
575
hSetNewlineMode h noNewlineTranslation
575
576
hPutStr h (T. unpack txt)
576
- res <-
577
+ res <- do
577
578
liftIO $ withSystemTempFile (takeFileName fp) $ \ temp h -> do
578
579
hClose h
579
580
writeFileUTF8NoNewLineTranslation temp oldContent
@@ -587,22 +588,19 @@ applyHint recorder ide nfp mhint verTxtDocId =
587
588
mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
588
589
res <-
589
590
case mbParsedModule of
590
- Nothing -> throwError " Apply hint: error parsing the module"
591
+ Nothing -> throwError $ PluginInternalError " Apply hint: error parsing the module"
591
592
Just pm -> do
592
- let anns = pm_annotations pm
593
- let modu = pm_parsed_source pm
594
- -- apply-refact uses RigidLayout
595
- let rigidLayout = deltaOptions RigidLayout
596
- (anns', modu') <-
597
- ExceptT $ mapM (uncurry Refact. applyFixities)
598
- $ postParseTransform (Right (anns, [] , dflags, modu)) rigidLayout
599
- liftIO $ (Right <$> Refact. applyRefactorings' position commands anns' modu')
593
+ let modu = makeDeltaAst $ pm_parsed_source pm
594
+ modu' <-
595
+ ExceptT $ mapM Refact. applyFixities
596
+ $ postParseTransform (Right ([] , dflags, modu))
597
+ liftIO $ (Right <$> Refact. applyRefactorings' dflags position commands modu')
600
598
`catches` errorHandlers
601
599
#endif
602
600
case res of
603
601
Right appliedFile -> do
604
- let wsEdit = diffText' True (verTxtDocId, oldContent) (T. pack appliedFile) IncludeDeletions
605
- ExceptT $ return ( Right wsEdit)
602
+ let wsEdit = diffText clientCapabilities (verTxtDocId, oldContent) (T. pack appliedFile) IncludeDeletions
603
+ ExceptT $ pure $ Right wsEdit
606
604
Left err ->
607
605
throwError $ PluginInternalError $ T. pack err
608
606
where
@@ -628,6 +626,7 @@ bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where
628
626
h (Right a) = Right (g a)
629
627
{-# INLINE bimapExceptT #-}
630
628
629
+ #ifdef HLINT_ON_GHC_LIB
631
630
-- ---------------------------------------------------------------------------
632
631
-- Apply-refact compatability, documentation copied from upstream apply-refact
633
632
-- ---------------------------------------------------------------------------
@@ -679,3 +678,4 @@ applyRefactorings =
679
678
withRuntimeLibdir libdir = bracket_ (setEnv key libdir) (unsetEnv key)
680
679
where key = " GHC_EXACTPRINT_GHC_LIBDIR"
681
680
#endif
681
+ #endif
0 commit comments