1+ {-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE CPP #-}
23{-# LANGUAGE DeriveAnyClass #-}
34{-# LANGUAGE DeriveGeneric #-}
@@ -33,18 +34,25 @@ import qualified Data.Text as T
3334import qualified Data.Text.IO as T
3435import Data.Typeable
3536import Development.IDE
36- import Development.IDE.Core.Rules (defineNoFile )
37+ import Development.IDE.Core.Rules (getParsedModuleWithComments , defineNoFile )
3738import Development.IDE.Core.Shake (getDiagnostics )
3839
39- #ifdef GHC_LIB
40+ #ifdef HLINT_ON_GHC_LIB
4041import Data.List (nub )
41- import "ghc-lib" GHC hiding (DynFlags (.. ))
42+ import "ghc-lib" GHC hiding (DynFlags (.. ), ms_hspp_opts )
43+ import "ghc-lib-parser" GHC.LanguageExtensions (Extension )
4244import "ghc" GHC as RealGHC (DynFlags (.. ))
43- import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags )
45+ import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags , ms_hspp_opts )
4446import qualified "ghc" EnumSet as EnumSet
4547import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension )
48+ import System.FilePath (takeFileName )
49+ import System.IO (hPutStr , noNewlineTranslation , hSetNewlineMode , utf8 , hSetEncoding , IOMode (WriteMode ), withFile , hClose )
50+ import System.IO.Temp
4651#else
4752import Development.IDE.GHC.Compat hiding (DynFlags (.. ))
53+ import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform )
54+ import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions )
55+ import Language.Haskell.GHC.ExactPrint.Types (Rigidity (.. ))
4856#endif
4957
5058import Ide.Logger
@@ -53,12 +61,12 @@ import Ide.Plugin.Config
5361import Ide.PluginUtils
5462import Language.Haskell.HLint as Hlint
5563import Language.Haskell.LSP.Core
64+ ( LspFuncs (withIndefiniteProgress ),
65+ ProgressCancellable (Cancellable ) )
5666import Language.Haskell.LSP.Types
5767import qualified Language.Haskell.LSP.Types as LSP
5868import qualified Language.Haskell.LSP.Types.Lens as LSP
59- import System.FilePath (takeFileName )
60- import System.IO (hPutStr , noNewlineTranslation , hSetNewlineMode , utf8 , hSetEncoding , IOMode (WriteMode ), withFile , hClose )
61- import System.IO.Temp
69+
6270import Text.Regex.TDFA.Text ()
6371import GHC.Generics (Generic )
6472
@@ -176,7 +184,14 @@ getIdeas nfp = do
176184 fmap applyHints' (moduleEx flags)
177185
178186 where moduleEx :: ParseFlags -> Action (Maybe Either ParseError ModuleEx ))
179- #ifdef GHC_LIB
187+ #ifndef HLINT_ON_GHC_LIB
188+ moduleEx _flags = do
189+ mbpm <- getParsedModule nfp
190+ return $ createModule <$> mbpm
191+ where createModule pm = Right
192+ where anns = pm_annotations pm
193+ modu = pm_parsed_source pm
194+ #else
180195 moduleEx flags = do
181196 mbpm <- getParsedModule nfp
182197 -- If ghc was not able to parse the module, we disable hlint diagnostics
@@ -190,20 +205,21 @@ getIdeas nfp = do
190205 Just <$> (liftIO $ parseModuleEx flags' fp contents')
191206
192207 setExtensions flags = do
193- hsc <- hscEnv <$> use_ GhcSession nfp
194- let dflags = hsc_dflags hsc
195- let hscExts = EnumSet. toList (extensionFlags dflags)
196- let hscExts' = mapMaybe (GhclibParserEx. readExtension . show ) hscExts
197- let hlintExts = nub $ enabledExtensions flags ++ hscExts'
208+ hlintExts <- getExtensions flags nfp
198209 logm $ " hlint:getIdeas:setExtensions:" ++ show hlintExts
199210 return $ flags { enabledExtensions = hlintExts }
200- #else
201- moduleEx _flags = do
202- mbpm <- getParsedModule nfp
203- return $ createModule <$> mbpm
204- where createModule pm = Right
205- where anns = pm_annotations pm
206- modu = pm_parsed_source pm
211+
212+ getExtensions :: ParseFlags -> NormalizedFilePath -> Action [Extension ]
213+ getExtensions pflags nfp = do
214+ dflags <- getFlags
215+ let hscExts = EnumSet. toList (extensionFlags dflags)
216+ let hscExts' = mapMaybe (GhclibParserEx. readExtension . show ) hscExts
217+ let hlintExts = nub $ enabledExtensions pflags ++ hscExts'
218+ return hlintExts
219+ where getFlags :: Action DynFlags
220+ getFlags = do
221+ (modsum, _) <- use_ GetModSummary nfp
222+ return $ ms_hspp_opts modsum
207223#endif
208224
209225-- ---------------------------------------------------------------------
@@ -334,10 +350,18 @@ applyOneCmd lf ide (AOP uri pos title) = do
334350applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO Either String WorkspaceEdit )
335351applyHint ide nfp mhint =
336352 runExceptT $ do
337- ideas <- bimapExceptT showParseError id $ ExceptT $ liftIO $ runAction " applyHint" $ getIdeas nfp
353+ let runAction' :: Action a -> IO a
354+ runAction' = runAction " applyHint"
355+ let errorHandlers = [ Handler $ \ e -> return (Left show (e :: IOException )))
356+ , Handler $ \ e -> return (Left show (e :: ErrorCall )))
357+ ]
358+ ideas <- bimapExceptT showParseError id $ ExceptT $ runAction' $ getIdeas nfp
338359 let ideas' = maybe ideas (`filterIdeas` ideas) mhint
339- let commands = map ( show &&& ideaRefactoring) ideas'
360+ let commands = map ideaRefactoring ideas'
340361 liftIO $ logm $ " applyHint:apply=" ++ show commands
362+ let fp = fromNormalizedFilePath nfp
363+ (_, mbOldContent) <- liftIO $ runAction' $ getFileContents nfp
364+ oldContent <- maybe (liftIO $ T. readFile fp) return mbOldContent
341365 -- set Nothing as "position" for "applyRefactorings" because
342366 -- applyRefactorings expects the provided position to be _within_ the scope
343367 -- of each refactoring it will apply.
@@ -353,27 +377,48 @@ applyHint ide nfp mhint =
353377 -- If we provide "applyRefactorings" with "Just (1,13)" then
354378 -- the "Redundant bracket" hint will never be executed
355379 -- because SrcSpan (1,20,??,??) doesn't contain position (1,13).
356- let fp = fromNormalizedFilePath nfp
357- (_, mbOldContent) <- liftIO $ runAction " hlint" $ getFileContents nfp
358- oldContent <- maybe (liftIO $ T. readFile fp) return mbOldContent
359- -- We need to save a file with last edited contents cause `apply-refact`
360- -- doesn't expose a function taking directly contents instead a file path.
361- -- Ideally we should try to expose that function upstream and remove this.
362- res <- liftIO $ withSystemTempFile (takeFileName fp) $ \ temp h -> do
380+ #ifdef HLINT_ON_GHC_LIB
381+ let writeFileUTF8NoNewLineTranslation file txt =
382+ withFile file WriteMode $ \ h -> do
383+ hSetEncoding h utf8
384+ hSetNewlineMode h noNewlineTranslation
385+ hPutStr h (T. unpack txt)
386+ res <-
387+ liftIO $ withSystemTempFile (takeFileName fp) $ \ temp h -> do
363388 hClose h
364389 writeFileUTF8NoNewLineTranslation temp oldContent
365- (Right <$> applyRefactorings Nothing commands temp) `catches`
366- [ Handler $ \ e -> return (Left show (e :: IOException )))
367- , Handler $ \ e -> return (Left show (e :: ErrorCall )))
368- ]
390+ (pflags, _, _) <- runAction' $ useNoFile_ GetHlintSettings
391+ exts <- runAction' $ getExtensions pflags nfp
392+ -- We have to reparse extensions to remove the invalid ones
393+ let (enabled, disabled, _invalid) = parseExtensions $ map show exts
394+ let refactExts = map show $ enabled ++ disabled
395+ (Right <$> applyRefactorings Nothing commands temp refactExts)
396+ `catches` errorHandlers
397+ #else
398+ mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
399+ res <-
400+ case mbParsedModule of
401+ Nothing -> throwE " Apply hint: error parsing the module"
402+ Just pm -> do
403+ let anns = pm_annotations pm
404+ let modu = pm_parsed_source pm
405+ (modsum, _) <- liftIO $ runAction' $ use_ GetModSummary nfp
406+ let dflags = ms_hspp_opts modsum
407+ -- apply-refact uses RigidLayout
408+ let rigidLayout = deltaOptions RigidLayout
409+ (anns', modu') <-
410+ ExceptT $ return $ postParseTransform (Right [] , dflags, modu)) rigidLayout
411+ liftIO $ (Right <$> applyRefactorings' Nothing commands anns' modu')
412+ `catches` errorHandlers
413+ #endif
369414 case res of
370415 Right -> do
371416 let uri = fromNormalizedUri (filePathToUri' nfp)
372417 let wsEdit = diffText' True T. pack appliedFile) IncludeDeletions
373418 liftIO $ logm $ " hlint:applyHint:diff=" ++ show wsEdit
374419 ExceptT $ return (Right
375420 Left ->
376- throwE ( show err)
421+ throwE err
377422 where
378423 -- | If we are only interested in applying a particular hint then
379424 -- let's filter out all the irrelevant ideas
@@ -396,10 +441,3 @@ bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where
396441 h (Left = Left
397442 h (Right = Right
398443{-# INLINE bimapExceptT #-}
399-
400- writeFileUTF8NoNewLineTranslation :: FilePath -> T. Text-> IO ()
401- writeFileUTF8NoNewLineTranslation file txt =
402- withFile file WriteMode $ \ h -> do
403- hSetEncoding h utf8
404- hSetNewlineMode h noNewlineTranslation
405- hPutStr h (T. unpack txt)
0 commit comments