Reintroduce ghc-lib flag for hlint plugin

RaoulHC · RaoulHC · commit b6aa8e574e68 · 2023-09-15T12:15:09.000+01:00
The ghc-lib flag was removed in #3015, but it's still useful to be able to compile hls-hlint-plugin using the GHC API if you've done so for hlint and ghc-lib-parser-ex, rather than using ghc-lib-parser. A lot of the HLINT_ON_GHC_LIB gated code which has probably been bitrotting since this flag was removed has also been removed, and is probably from when hlint used to work on haskell-src-exts. As ghc-lib-parser has the same API as GHC itself, there's no need for code to be cpp gated.
diff --git a/configuration-ghc-94.nix b/configuration-ghc-94.nix
@@ -17,7 +17,14 @@ let
 
       fourmolu = dontCheck (hself.callCabal2nix "fourmolu" inputs.fourmolu-011 {});
 
-      stylish-haskell = appendConfigureFlag  hsuper.stylish-haskell "-fghc-lib";
+      stylish-haskell = appendConfigureFlag  hsuper.stylish-haskell "-f-ghc-lib";
+
+      ghc-lib-parser-ex = appendConfigureFlag hsuper.ghc-lib-parser-ex "-fno-ghc-lib";
+      hlint = hself.callCabal2nixWithOptions "hlint" inputs.hlint-35 "-f-ghc-lib" {};
+
+      hls-hlint-plugin =
+        hself.callCabal2nixWithOptions "hls-hlint-plugin" ./plugins/hls-hlint-plugin
+        (pkgs.lib.concatStringsSep " " [ "--no-check" "-f-ghc-lib" ]) { };
 
       lsp = hself.callCabal2nix "lsp" inputs.lsp {};
       lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {};
@@ -28,7 +35,7 @@ let
         hself.callCabal2nixWithOptions "haskell-language-server" ./.
         # Pedantic cannot be used due to -Werror=unused-top-binds
         # Check must be disabled due to some missing required files
-        (pkgs.lib.concatStringsSep " " [ "--no-check" "-f-pedantic" "-f-hlint" ]) { };
+        (pkgs.lib.concatStringsSep " " [ "--no-check" "-f-pedantic" ]) { };
     });
 in {
   inherit disabledPlugins;
diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal
@@ -29,6 +29,13 @@ flag pedantic
   default:     False
   manual:      True
 
+flag ghc-lib
+  description:
+    Use ghc-lib-parser rather than the ghc library (requires hlint and
+    ghc-lib-parser-ex to also be built with it)
+  default: True
+  manual: True
+
 library
   exposed-modules:    Ide.Plugin.Hlint
   hs-source-dirs:     src
@@ -59,11 +66,19 @@ library
     , text
     , transformers
     , unordered-containers
-    , ghc-lib-parser
     , ghc-lib-parser-ex
     , apply-refact
 
-  cpp-options:   -DHLINT_ON_GHC_LIB
+  if flag(ghc-lib)
+    cpp-options:   -DGHC_LIB
+    build-depends:
+        ghc-lib-parser
+  else
+    build-depends:
+        ghc
+      , ghc-boot
+      , ghc-boot-th
+
   ghc-options:
     -Wall -Wredundant-constraints -Wno-name-shadowing
     -Wno-unticked-promoted-constructors
diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs
@@ -10,7 +10,6 @@
 {-# LANGUAGE NamedFieldPuns            #-}
 {-# LANGUAGE OverloadedLabels          #-}
 {-# LANGUAGE OverloadedStrings         #-}
-{-# LANGUAGE PackageImports            #-}
 {-# LANGUAGE PatternSynonyms           #-}
 {-# LANGUAGE RecordWildCards           #-}
 {-# LANGUAGE ScopedTypeVariables       #-}
@@ -26,7 +25,7 @@
 -- lots of CPP, we just disable the warning until later.
 {-# OPTIONS_GHC -Wno-redundant-constraints   #-}
 
-#ifdef HLINT_ON_GHC_LIB
+#ifdef GHC_LIB
 #define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib_parser(x,y,z)
 #else
 #define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z)
@@ -69,7 +68,6 @@ import           Development.IDE.Core.Shake                         (getDiagnost
 import qualified Refact.Apply                                       as Refact
 import qualified Refact.Types                                       as Refact
 
-#ifdef HLINT_ON_GHC_LIB
 import           Development.IDE.GHC.Compat                         (DynFlags,
                                                                      WarningFlag (Opt_WarnUnrecognisedPragmas),
                                                                      extensionFlags,
@@ -79,18 +77,18 @@ import           Development.IDE.GHC.Compat                         (DynFlags,
 import qualified Development.IDE.GHC.Compat.Util                    as EnumSet
 
 #if MIN_GHC_API_VERSION(9,4,0)
-import qualified "ghc-lib-parser" GHC.Data.Strict                   as Strict
+import qualified GHC.Data.Strict                                    as Strict
 #endif
 #if MIN_GHC_API_VERSION(9,0,0)
-import           "ghc-lib-parser" GHC.Types.SrcLoc                  hiding
+import           GHC.Types.SrcLoc                                   hiding
                                                                     (RealSrcSpan)
-import qualified "ghc-lib-parser" GHC.Types.SrcLoc                  as GHC
+import qualified GHC.Types.SrcLoc                                   as GHC
 #else
-import           "ghc-lib-parser" SrcLoc                            hiding
+import qualified SrcLoc                                             as GHC
+import           SrcLoc                                             hiding
                                                                     (RealSrcSpan)
-import qualified "ghc-lib-parser" SrcLoc                            as GHC
 #endif
-import           "ghc-lib-parser" GHC.LanguageExtensions            (Extension)
+import           GHC.LanguageExtensions                             (Extension)
 import           Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
 import           System.FilePath                                    (takeFileName)
 import           System.IO                                          (IOMode (WriteMode),
@@ -102,21 +100,7 @@ import           System.IO                                          (IOMode (Wri
                                                                      utf8,
                                                                      withFile)
 import           System.IO.Temp
-#else
-import           Development.IDE.GHC.Compat                         hiding
-                                                                    (setEnv,
-                                                                     (<+>))
-import           GHC.Generics                                       (Associativity (LeftAssociative, NotAssociative, RightAssociative))
-#if MIN_GHC_API_VERSION(9,2,0)
-import           Language.Haskell.GHC.ExactPrint.ExactPrint         (deltaOptions)
-#else
-import           Language.Haskell.GHC.ExactPrint.Delta              (deltaOptions)
-#endif
-import           Language.Haskell.GHC.ExactPrint.Parsers            (postParseTransform)
-import           Language.Haskell.GHC.ExactPrint.Types              (Rigidity (..))
-import           Language.Haskell.GhclibParserEx.Fixity             as GhclibParserEx (applyFixities)
-import qualified Refact.Fixity                                      as Refact
-#endif
+
 import           Ide.Plugin.Config                                  hiding
                                                                     (Config)
 import           Ide.Plugin.Error
@@ -169,7 +153,6 @@ instance Pretty Log where
     LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp
     LogResolve msg -> pretty msg
 
-#ifdef HLINT_ON_GHC_LIB
 -- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib
 #if !MIN_GHC_API_VERSION(9,0,0)
 type BufSpan = ()
@@ -183,7 +166,6 @@ pattern RealSrcSpan x y = GHC.RealSrcSpan x y
 pattern RealSrcSpan x y <- ((,Nothing) -> (GHC.RealSrcSpan x, y))
 #endif
 {-# COMPLETE RealSrcSpan, UnhelpfulSpan #-}
-#endif
 
 #if MIN_GHC_API_VERSION(9,4,0)
 fromStrictMaybe :: Strict.Maybe a -> Maybe a
@@ -310,28 +292,6 @@ getIdeas recorder nfp = do
   fmap applyHints' (moduleEx flags)
 
   where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
-#ifndef HLINT_ON_GHC_LIB
-        moduleEx _flags = do
-          mbpm <- getParsedModuleWithComments nfp
-          return $ createModule <$> mbpm
-          where
-            createModule pm = Right (createModuleEx anns (applyParseFlagsFixities modu))
-                  where anns = pm_annotations pm
-                        modu = pm_parsed_source pm
-
-            applyParseFlagsFixities :: ParsedSource -> ParsedSource
-            applyParseFlagsFixities modul = GhclibParserEx.applyFixities (parseFlagsToFixities _flags) modul
-
-            parseFlagsToFixities :: ParseFlags -> [(String, Fixity)]
-            parseFlagsToFixities = map toFixity . Hlint.fixities
-
-            toFixity :: FixityInfo -> (String, Fixity)
-            toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir)
-                where
-                    f LeftAssociative  = InfixL
-                    f RightAssociative = InfixR
-                    f NotAssociative   = InfixN
-#else
         moduleEx flags = do
           mbpm <- getParsedModuleWithComments nfp
           -- If ghc was not able to parse the module, we disable hlint diagnostics
@@ -354,11 +314,6 @@ getIdeas recorder nfp = do
 -- and the ModSummary dynflags. However using the parsedFlags extensions
 -- can sometimes interfere with the hlint parsing of the file.
 -- See https://github.com/haskell/haskell-language-server/issues/1279
---
--- Note: this is used when HLINT_ON_GHC_LIB is defined. We seem to need
--- these extensions to construct dynflags to parse the file again. Therefore
--- using hlint default extensions doesn't seem to be a problem when
--- HLINT_ON_GHC_LIB is not defined because we don't parse the file again.
 getExtensions :: NormalizedFilePath -> Action [Extension]
 getExtensions nfp = do
     dflags <- getFlags
@@ -369,7 +324,6 @@ getExtensions nfp = do
         getFlags = do
           modsum <- use_ GetModSummary nfp
           return $ ms_hspp_opts $ msrModSummary modsum
-#endif
 
 -- ---------------------------------------------------------------------
 
@@ -567,7 +521,6 @@ applyHint recorder ide nfp mhint verTxtDocId =
     -- But "Idea"s returned by HLint point to starting position of the expressions
     -- that contain refactorings, so they are often outside the refactorings' boundaries.
     let position = Nothing
-#ifdef HLINT_ON_GHC_LIB
     let writeFileUTF8NoNewLineTranslation file txt =
             withFile file WriteMode $ \h -> do
                 hSetEncoding h utf8
@@ -583,22 +536,6 @@ applyHint recorder ide nfp mhint verTxtDocId =
             let refactExts = map show $ enabled ++ disabled
             (Right <$> applyRefactorings (topDir dflags) position commands temp refactExts)
                 `catches` errorHandlers
-#else
-    mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
-    res <-
-        case mbParsedModule of
-            Nothing -> throwError "Apply hint: error parsing the module"
-            Just pm -> do
-                let anns = pm_annotations pm
-                let modu = pm_parsed_source pm
-                -- apply-refact uses RigidLayout
-                let rigidLayout = deltaOptions RigidLayout
-                (anns', modu') <-
-                    ExceptT $ mapM (uncurry Refact.applyFixities)
-                            $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout
-                liftIO $ (Right <$> Refact.applyRefactorings' position commands anns' modu')
-                            `catches` errorHandlers
-#endif
     case res of
       Right appliedFile -> do
         let wsEdit = diffText' True (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions
