hsinspect 0.0.18 → 0.1.0

raw patch · 11 files changed

+503/−269 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• exe/Main.hs +6/−8
• hsinspect.cabal +2/−3
• library/HsInspect/Imports.hs +33/−8
• library/HsInspect/Index.hs +184/−63
• library/HsInspect/Json.hs +22/−14
• library/HsInspect/Packages.hs +0/−80
• library/HsInspect/Runner.hs +34/−10
• library/HsInspect/Sexp.hs +9/−15
• library/HsInspect/Types.hs +98/−17
• library/HsInspect/Util.hs +18/−5
• library/HsInspect/Workarounds.hs +97/−46

@@ -4,16 +4,19 @@  module Main where +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+import qualified GHC.Version as GHC+#else import qualified Config as GHC+#endif+ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Except (runExceptT) import qualified Data.Text.IO as T-import DynFlags (unsafeGlobalDynFlags) import HsInspect.Imports import HsInspect.Index import HsInspect.Json-import HsInspect.Packages import HsInspect.Runner import HsInspect.Sexp as S import HsInspect.Types@@ -35,7 +38,6 @@   "                             along with their locally qualified (and\n" ++   "                             unqualified) names.\n" ++   "  index                    - list all dependency packages, modules, terms and types.\n" ++-  "  packages /path/to/dir    - list all packages that are referenced by sources in this dir.\n\n" ++   " If --ghcflags is used, the flags and path will be automatically inferred from\n" ++   " .ghc.flags and .ghc.path files based on the file and current directory. Otherwise the\n" ++   " PATH, PWD and ghcflags must be provided."@@ -64,18 +66,14 @@         if (elem "--json" rest)         then case sexpToJson a of           Left err -> error err-          Right j -> putStrLn $ encodeJson unsafeGlobalDynFlags j+          Right j -> putStrLn $ encodeJson j         else T.putStrLn $ S.render a-   runGhcAndJamMasterShe flags True $ case args of     "imports" : file : rest -> do       quals <- imports file       respond rest quals     "index" : rest -> do       hits <- index-      respond rest hits-    "packages" : rest -> do-      hits <- packages       respond rest hits     "types" : file : rest -> do       hits <- types file

@@ -1,13 +1,13 @@ cabal-version: 2.2 name:          hsinspect-version:       0.0.18+version:       0.1.0 synopsis:      Inspect Haskell source files. license:       GPL-3.0-or-later license-file:  LICENSE author:        Tseen She maintainer:    Tseen She copyright:     2019 Tseen She-tested-with:   GHC ^>=8.8.3 || ^>=8.10.4+tested-with:   GHC ^>=8.8.3 || ^>=8.10.7 || ^>=9.0.2 || ^>=9.2.7 || ^>=9.4.5 || ^>=9.6.1 category:      Building description:   Inspect @.hs@ files using the ghc api. @@ -61,7 +61,6 @@     HsInspect.Imports     HsInspect.Index     HsInspect.Json-    HsInspect.Packages     HsInspect.Runner     HsInspect.Sexp     HsInspect.Types

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-}@@ -8,38 +9,62 @@   ) where +#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+import qualified GHC.Types.Target as GHC+#endif++#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+import qualified GHC.Driver.Env.Types as GHC+import qualified GHC.Unit.Env as GHC+import qualified GHC.Data.Bag as GHC+import qualified GHC.Types.Name.Reader as GHC+#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+import qualified GHC.Types.Name.Reader as GHC+#else+import qualified HscTypes as GHC+import qualified RdrName as GHC+#endif+ import Data.List (sort) import Data.Maybe (fromJust) import Data.Text (Text) import qualified Data.Text as T import qualified GHC as GHC-import HscTypes (TargetId(..)) import HsInspect.Sexp import HsInspect.Util import HsInspect.Workarounds-import RdrName (GlobalRdrElt(..), ImpDeclSpec(..), ImportSpec(..),-                globalRdrEnvElts)  imports :: GHC.GhcMonad m => FilePath -> m [Qualified] imports file = do   (fromJust -> m, target) <- importsOnly mempty file -  GHC.removeTarget $ TargetModule m+  GHC.removeTarget $ GHC.TargetModule m   GHC.addTarget target    -- performance can be very bad here if the user hasn't compiled recently. We   -- could do the Index hack and only load things that have .hi files but that   -- will result in very bizarre behaviour and we don't expect the user's code   -- to be compilable at this point.+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+  sess <- GHC.getSession+  let unitid = GHC.ue_current_unit $ GHC.hsc_unit_env sess+  _ <- GHC.load $ GHC.LoadUpTo (GHC.mkModule unitid m)+#else   _ <- GHC.load $ GHC.LoadUpTo m+#endif    rdr_env <- minf_rdr_env' m-  pure . sort $ describe =<< globalRdrEnvElts rdr_env+  pure . sort $ describe =<< GHC.globalRdrEnvElts rdr_env -describe :: GlobalRdrElt -> [Qualified]-describe GRE {gre_name, gre_imp} = describe' <$> gre_imp+describe :: GHC.GlobalRdrElt -> [Qualified]+describe GHC.GRE {GHC.gre_name, GHC.gre_imp} =+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+  describe' <$> GHC.bagToList gre_imp+#else+  describe' <$> gre_imp+#endif   where-    describe' ImpSpec {is_decl = ImpDeclSpec {is_mod, is_as, is_qual}} =+    describe' GHC.ImpSpec {GHC.is_decl = GHC.ImpDeclSpec {GHC.is_mod, GHC.is_as, GHC.is_qual}} =       let ln =             if is_qual               then Nothing

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}@@ -9,9 +11,53 @@   ) where -import Avail (AvailInfo(..))-import BinIface (CheckHiWay(..), TraceBinIFaceReading(..), readBinIface)+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+import qualified GHC.Driver.Session as GHC+#endif++#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+import qualified GHC.Data.ShortText as GHC+import qualified GHC.Driver.Env.Types as GHC+import qualified GHC.Driver.Ppr as GHC+import qualified GHC.Unit.Env as GHC+#endif++#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+import qualified GHC.Core.ConLike as GHC+import qualified GHC.Core.PatSyn as GHC+import qualified GHC.Core.TyCon as GHC+import qualified GHC.Data.FastString as GHC+import qualified GHC.Iface.Binary as GHC+import qualified GHC.Tc.Types as GHC+import qualified GHC.Tc.Utils.Env as GHC+import qualified GHC.Tc.Utils.Monad as GHC+import qualified GHC.Types.Avail as GHC+import qualified GHC.Types.Id as GHC+import qualified GHC.Types.Name as GHC+import qualified GHC.Unit.Database as GHC+import qualified GHC.Unit.State as GHC+import qualified GHC.Unit.Types as GHC+import qualified GHC.Utils.Outputable as GHC+#else+import qualified Avail as GHC+import qualified BinIface as GHC import qualified ConLike as GHC+import qualified DynFlags as GHC+import qualified FastString as GHC+import qualified GHC.PackageDb as GHC+import qualified Id as GHC+import qualified Module as GHC+import qualified Name as GHC+import qualified Outputable as GHC+import qualified PackageConfig as GHC+import qualified Packages as GHC+import qualified PatSyn as GHC+import qualified TcEnv as GHC+import qualified TcRnMonad as GHC+import qualified TyCon as GHC+#endif+import qualified GHC+ import Control.Monad import Control.Monad.IO.Class import Data.List (isInfixOf, sort)@@ -20,28 +66,8 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T-import qualified DataCon as GHC-import qualified DynFlags as GHC-import qualified GHC-import GHC.PackageDb-import qualified GHC.PackageDb as GHC-import HsInspect.Json () import HsInspect.Sexp import HsInspect.Util-import qualified Id as GHC-import Module as GHC-import qualified Name as GHC-import Outputable (showPpr, showSDoc)-import qualified Outputable as GHC-import PackageConfig-import qualified PackageConfig as GHC-import Packages (explicitPackages, lookupPackage)---import System.IO (hPutStrLn, stderr)-import qualified PatSyn as GHC-import TcEnv (tcLookup)-import TcRnMonad (initTcInteractive)-import qualified TcRnTypes as GHC-import qualified TyCon as GHC  -- TODO export unexposed modules too, since they could be exposed by an export elsewhere --@@ -50,12 +76,34 @@ index = do   dflags <- GHC.getSessionDynFlags -  let explicit = explicitPackages $ GHC.pkgState dflags-      pkgcfgs = maybeToList . lookupPackage dflags =<< explicit+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+  let unarg as = fst <$> as+#elif MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+  let unarg = id+#endif+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+  sess <- GHC.getSession+  let unit_state = GHC.ue_units $ GHC.hsc_unit_env sess+      explicit = GHC.explicitUnits unit_state+      pkgcfgs = maybeToList . GHC.lookupUnit unit_state =<< unarg explicit+#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+  let unit_state = GHC.unitState dflags+      explicit = GHC.explicitUnits unit_state+      pkgcfgs = maybeToList . GHC.lookupUnit unit_state =<< explicit+#else+  let explicit = GHC.explicitPackages $ GHC.pkgState dflags+      pkgcfgs = maybeToList . GHC.lookupPackage dflags =<< explicit+#endif   deps <- traverse getPkgSymbols pkgcfgs    loadCompiledModules+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+  let unitid = GHC.homeUnitId_ dflags+#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+  let unitid = GHC.homeUnitId dflags+#else   let unitid = GHC.thisPackage dflags+#endif       dirs = maybeToList $ GHC.hiDir dflags   home_mods <- getTargetModules   home_entries <- getSymbols unitid True [] home_mods dirs@@ -84,43 +132,108 @@   provided <- getTargetModules   his <- liftIO $ walkSuffix ".hi" dir   modules <- catMaybes <$> traverse (flip withHi (pure . GHC.mi_module)) his-  let toTarget m =+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+  sess <- GHC.getSession+  let unitid = GHC.ue_current_unit $ GHC.hsc_unit_env sess+      mkTarget m = GHC.Target (GHC.TargetModule m) True unitid Nothing+#else+  let mkTarget m = GHC.Target (GHC.TargetModule m) True Nothing+#endif+      toTarget m =         if Set.member m provided-          then Just $ GHC.Target (GHC.TargetModule m) True Nothing+          then Just $ mkTarget m           else Nothing-  pure $ mapMaybe (toTarget . moduleName) modules+  pure $ mapMaybe (toTarget . GHC.moduleName) modules  -- Perform an operation given the parsed .hi file. tcLookup will only succeed if -- the module is on the packagedb or is a home module that has been loaded. withHi :: GHC.GhcMonad m => FilePath -> (GHC.ModIface -> (GHC.TcRnIf GHC.TcGblEnv GHC.TcLclEnv) a) -> m (Maybe a) withHi hi f = do   env <- GHC.getSession-  (_, res) <- liftIO . initTcInteractive env $ do-    iface <- readBinIface IgnoreHiWay QuietBinIFaceReading hi-    f iface+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+  dflags <- GHC.getSessionDynFlags+  let profile = GHC.targetProfile dflags+      name_cache = GHC.hsc_NC env+  (_, res) <- liftIO $ do+        iface <- GHC.readBinIface profile name_cache GHC.IgnoreHiWay GHC.QuietBinIFace hi+        GHC.initTcInteractive env $ f iface+#elif MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+  (_, res) <- liftIO . GHC.initTcInteractive env $ do+        iface <- GHC.readBinIface GHC.IgnoreHiWay GHC.QuietBinIFace hi+        f iface+#else+  (_, res) <- liftIO . GHC.initTcInteractive env $ do+        iface <- GHC.readBinIface GHC.IgnoreHiWay GHC.QuietBinIFaceReading hi+        f iface+#endif   pure res -getPkgSymbols :: GHC.GhcMonad m => PackageConfig -> m PackageEntries+#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+getPkgSymbols :: GHC.GhcMonad m => GHC.UnitInfo -> m PackageEntries+#else+getPkgSymbols :: GHC.GhcMonad m => GHC.PackageConfig -> m PackageEntries+#endif getPkgSymbols pkg =-  let unitid = GHC.packageConfigId pkg-      inplace = "-inplace" `isInfixOf` (GHC.unitIdString unitid)-      exposed = Set.fromList $ fst <$> exposedModules pkg-      dirs = (importDirs pkg)+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+  let exposed = Set.fromList $ fst <$> GHC.unitExposedModules pkg+      GHC.GenericUnitInfo {GHC.unitId = unitid} = pkg+      dirs = GHC.unpack <$> (GHC.unitImportDirs pkg)+      haddocks = GHC.unpack <$> GHC.unitHaddockHTMLs pkg+#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+  let exposed = Set.fromList $ fst <$> GHC.unitExposedModules pkg+      GHC.GenericUnitInfo {GHC.unitId = unitid} = pkg+      dirs = GHC.unitImportDirs pkg+      haddocks = GHC.unitHaddockHTMLs pkg+#else+  let exposed = Set.fromList $ fst <$> GHC.exposedModules pkg+      unitid = GHC.packageConfigId pkg+      dirs = (GHC.importDirs pkg)       haddocks = GHC.haddockHTMLs pkg+#endif+      unit_string = GHC.unitIdString unitid+      inplace = "-inplace" `isInfixOf` unit_string    in getSymbols unitid inplace haddocks exposed dirs -getSymbols :: GHC.GhcMonad m => UnitId -> Bool -> [FilePath] -> Set GHC.ModuleName -> [FilePath] -> m PackageEntries+getSymbols :: GHC.GhcMonad m => GHC.UnitId -> Bool -> [FilePath] -> Set GHC.ModuleName -> [FilePath] -> m PackageEntries getSymbols unitid inplace haddocks exposed dirs = do   let findHis dir = liftIO $ walkSuffix ".hi" dir   his <- join <$> traverse findHis dirs   dflags <- GHC.getSessionDynFlags-  let srcid = sourcePackageId <$> lookupPackage dflags unitid+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+  sess <- GHC.getSession+  let unit_state = GHC.ue_units . GHC.hsc_unit_env $ sess+      findPid unitid' = GHC.unitPackageId <$> GHC.lookupUnitId unit_state unitid'+      findUnitId = GHC.toUnitId . GHC.moduleUnit+      mkPackageId (GHC.PackageId fs) = PackageId . T.pack $ GHC.unpackFS fs+#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+  let unit_state = GHC.unitState dflags+      findPid unitid' = GHC.unitPackageId <$> GHC.lookupUnitId unit_state unitid'+      findUnitId = GHC.toUnitId . GHC.moduleUnit+      mkPackageId (GHC.PackageId fs) = PackageId . T.pack $ GHC.unpackFS fs+#else+  let findPid unitid' = GHC.sourcePackageId <$> GHC.lookupPackage dflags unitid'+      findUnitId = GHC.moduleUnitId+      mkPackageId (GHC.SourcePackageId fs) = PackageId . T.pack $ GHC.unpackFS fs+#endif+      srcid =  findPid unitid   symbols <- catMaybes <$> traverse (hiToSymbols exposed) his   let entries = sort $ uncurry mkEntries <$> symbols-      mkEntries m things = ModuleEntries (moduleName m) (sort $ renderThings things)-      renderThings things = catMaybes $ (uncurry $ tyrender dflags unitid) <$> things-  pure $ PackageEntries srcid inplace entries (T.pack <$> haddocks)+      mkModuleName :: GHC.Module -> ModuleName+      mkModuleName = ModuleName . T.pack . GHC.moduleNameString . GHC.moduleName+      mkEntries m things = ModuleEntries (mkModuleName m) (sort $ renderThings things) +      -- for the given module, only including the packageid if it is different+      -- than the package of the module under inspection.+      mkExported m =+        let unitid' = findUnitId m+            pid = if unitid == unitid'+                    then Nothing+                    else findPid unitid'+         in Exported (mkPackageId <$> pid) (mkModuleName m)++      renderThings things = catMaybes $ (\(mm, thing) -> tyrender dflags (mkExported <$> mm) thing) <$> things+  pure $ PackageEntries (mkPackageId <$> srcid) inplace entries (T.pack <$> haddocks)+ -- for a .hi file returns the module and a list of all things (with types -- resolved) in that module and their original module if they are re-exported. hiToSymbols@@ -135,37 +248,51 @@   if not $ Set.member (GHC.moduleName m) exposed     then pure Nothing     else do-      let thing (Avail name) = traverse tcLookup' [name]+      let thing (GHC.Avail name) = traverse tcLookup' [name]           -- TODO the fields in AvailTC-          thing (AvailTC _ members _) = traverse tcLookup' members+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+          thing (GHC.AvailTC _ members) = traverse tcLookup' members+#else+          thing (GHC.AvailTC _ members _) = traverse tcLookup' members+#endif           reexport name = do             modl <- GHC.nameModule_maybe name             if m == modl then Nothing else Just modl-          tcLookup' name = (reexport name,) <$> tcLookup name+          tcLookup' name =+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+            let name' = GHC.greNameMangledName name+#else+            let name' = name+#endif+             in (reexport name',) <$> GHC.tcLookup name'       things <- join <$> traverse thing (GHC.mi_exports iface)       pure . Just $ (m, things) -tyrender :: GHC.DynFlags -> UnitId -> Maybe GHC.Module -> GHC.TcTyThing -> Maybe Entry-tyrender dflags unitid m' (GHC.AGlobal thing) =+-- TODO should we lose the dflags and use the unsafe variant?+tyrender :: GHC.DynFlags -> Maybe Exported -> GHC.TcTyThing -> Maybe Entry+tyrender dflags m (GHC.AGlobal thing) =   let-    m = mkExported dflags unitid <$> m'-    shw :: GHC.Outputable m => m -> Text-    shw = T.pack . showPpr dflags-   in case thing of+    shw :: GHC.Outputable o => o -> Text+    shw = T.pack . GHC.showPpr dflags+    in case thing of     (GHC.AnId var) -> Just $ IdEntry m       (shw $ GHC.idName var)       (shw $ GHC.idType var)     (GHC.AConLike (GHC.RealDataCon dc)) -> Just $ ConEntry m       (shw $ GHC.getName dc)+#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+      (shw $ GHC.dataConWrapperType dc)+#else       (shw $ GHC.dataConUserType dc)+#endif     (GHC.AConLike (GHC.PatSynCon ps)) -> Just $ PatSynEntry m       (shw $ GHC.getName ps)-      (T.pack . showSDoc dflags $ GHC.pprPatSynType ps )+      (T.pack . GHC.showSDoc dflags $ GHC.pprPatSynType ps )     (GHC.ATyCon tc) -> Just $ TyConEntry m       (shw $ GHC.tyConName tc)       (shw $ GHC.tyConFlavour tc)     _ -> Nothing-tyrender _ _ _ _ = Nothing+tyrender _ _ _ = Nothing  data Entry = IdEntry (Maybe Exported) Text Text -- ^ name type            | ConEntry (Maybe Exported) Text Text -- ^ name type@@ -190,7 +317,7 @@   toSexp (TyConEntry p_1_1 p_1_2 p_1_3) = alist $ ("class", "tycon") : [("export", toSexp p_1_1), ("type", toSexp p_1_2), ("flavour", toSexp p_1_3)] {- BOILERPLATE END -} -data ModuleEntries = ModuleEntries GHC.ModuleName [Entry]+data ModuleEntries = ModuleEntries ModuleName [Entry]   deriving (Eq, Ord) {- BOILERPLATE ModuleEntries ToSexp field=[module,ids] -} {- BOILERPLATE START -}@@ -207,7 +334,7 @@ type Haddocks = [Text]  -- Bool indicates if this is an -inplace package-data PackageEntries = PackageEntries (Maybe SourcePackageId) Bool [ModuleEntries] Haddocks+data PackageEntries = PackageEntries (Maybe PackageId) Bool [ModuleEntries] Haddocks {- BOILERPLATE PackageEntries ToSexp field=[srcid,inplace,modules,haddocks] -} {- BOILERPLATE START -} instance ToSexp PackageEntries where@@ -215,7 +342,7 @@ {- BOILERPLATE END -}  -- srcid is Nothing if it matches the re-export location-data Exported = Exported (Maybe SourcePackageId) GHC.ModuleName+data Exported = Exported (Maybe PackageId) ModuleName   deriving (Eq, Ord)  {- BOILERPLATE Exported ToSexp field=[srcid, module] -}@@ -224,12 +351,6 @@   toSexp (Exported p_1_1 p_1_2) = alist [("srcid", toSexp p_1_1), ("module", toSexp p_1_2)] {- BOILERPLATE END -} -mkExported :: GHC.DynFlags -> UnitId -> Module -> Exported-mkExported dflags unitid m =-  let unitid' = moduleUnitId m-   in Exported-        (if unitid == unitid'-           then Nothing-           else sourcePackageId <$> lookupPackage dflags unitid')-        (moduleName m)-+-- local variants of things that exist in GHC+newtype ModuleName = ModuleName Text deriving (Eq, Ord, ToSexp)+newtype PackageId = PackageId Text deriving (Eq, Ord, ToSexp)

@@ -1,24 +1,32 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-}  module HsInspect.Json where +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+import qualified GHC.Utils.Json as GHC+import qualified GHC.Utils.Monad as GHC+import qualified GHC.Utils.Outputable as GHC+import qualified GHC.Utils.Misc as GHC+#else+import qualified Json as GHC+import qualified MonadUtils as GHC+import qualified Outputable as GHC+import qualified Util as GHC+#endif+ import qualified Data.Text as T-import qualified GHC as GHC import HsInspect.Sexp-import Json-import MonadUtils (mapSndM)-import Outputable (showSDoc)-import Util (mapFst) -encodeJson :: GHC.DynFlags -> JsonDoc -> String-encodeJson dflags j = showSDoc dflags . renderJSON $ j+encodeJson :: GHC.JsonDoc -> String+encodeJson j = GHC.showSDocUnsafe . GHC.renderJSON $ j -sexpToJson :: Sexp -> Either String JsonDoc-sexpToJson SexpNil = Right JSNull-sexpToJson (toAList -> Just kvs) = JSObject . mapFst T.unpack <$> mapSndM sexpToJson kvs-sexpToJson (toList -> Just as) = JSArray <$> traverse sexpToJson as+sexpToJson :: Sexp -> Either String GHC.JsonDoc+sexpToJson SexpNil = Right GHC.JSNull+sexpToJson (toAList -> Just kvs) = GHC.JSObject . GHC.mapFst T.unpack <$> GHC.mapSndM sexpToJson kvs+sexpToJson (toList -> Just as) = GHC.JSArray <$> traverse sexpToJson as sexpToJson (SexpCons _ _) = Left $ "cons cell has no JSON equivalent"-sexpToJson (SexpString s) = Right . JSString $ T.unpack s-sexpToJson (SexpSymbol s) = Right . JSString $ T.unpack s -- nobody said it had to roundtrip-sexpToJson (SexpInt i) = Right $ JSInt i+sexpToJson (SexpString s) = Right . GHC.JSString $ T.unpack s+sexpToJson (SexpSymbol s) = Right . GHC.JSString $ T.unpack s -- nobody said it had to roundtrip+sexpToJson (SexpInt i) = Right $ GHC.JSInt i -- TODO write our own JSON repr to avoid a ghc dep and improve perf

@@ -1,80 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module HsInspect.Packages (packages, PkgSummary) where--import Control.Monad (join, void)-import Control.Monad.IO.Class (liftIO)-import Data.List (delete, nub, nubBy, sort, (\\))-import Data.Maybe (catMaybes, mapMaybe)-import Data.Set (Set)-import qualified Data.Set as Set-import qualified DynFlags as GHC-import FastString-import Finder (findImportedModule)-import qualified GHC-import HscTypes (FindResult(..))-import HsInspect.Sexp-import HsInspect.Util-import HsInspect.Workarounds-import Module (Module(..), ModuleName)-import qualified PackageConfig as GHC-import Packages (PackageState(..), lookupPackage)-import qualified RdrName as GHC---- Similar to packunused / weeder, but more reliable (and doesn't require a--- separate -ddump-minimal-imports pass).-packages :: GHC.GhcMonad m => m PkgSummary-packages = do-  homes <- getTargetModules-  targetsImportsOnly homes--  dflags <- GHC.getSessionDynFlags-  void $ GHC.setSessionDynFlags dflags { GHC.ghcMode = GHC.CompManager }-  _ <- GHC.load $ GHC.LoadAllTargets--  imps <- nub . join <$> traverse getImports (Set.toList homes)-  pkgs <- catMaybes <$> traverse (uncurry findPackage) imps-  let home = GHC.thisPackage dflags-      used = delete home . nub . sort $ pkgs-      loaded = nub . sort . explicitPackages $ GHC.pkgState dflags-      asNames unitids = GHC.packageName <$> mapMaybe (lookupPackage dflags) unitids-  pure $ PkgSummary (asNames used) (asNames $ loaded \\ used)--targetsImportsOnly :: GHC.GhcMonad m => Set GHC.ModuleName -> m ()-targetsImportsOnly homes = do-  files <- homeSources-  trimmed <- traverse (importsOnly homes) files-  -- side effect: multiple modules with no name will be deduped-  let fstEq (n1, _) (n2, _) = n1 == n2-      targets = (snd <$>) . nubBy fstEq $ trimmed-  GHC.setTargets targets--findPackage :: GHC.GhcMonad m => ModuleName -> Maybe FastString -> m (Maybe GHC.UnitId)-findPackage m mp = do-  env <- GHC.getSession-  res <- liftIO $ findImportedModule env m mp-  pure $ case res of-    Found _ (Module u _) -> Just $ u-    _ -> Nothing--getImports :: GHC.GhcMonad m => ModuleName -> m [(ModuleName, Maybe FastString)]-getImports m = do-  rdr_env <- minf_rdr_env' m-  let imports = GHC.gre_imp =<< GHC.globalRdrEnvElts rdr_env-  pure $ qModule <$> imports---- PackageImports are not supported until ImpDeclSpec supports them (could parse--- gre_name's src span if we're desperate)-qModule :: GHC.ImportSpec -> (ModuleName, Maybe FastString)-qModule (GHC.ImpSpec (GHC.ImpDeclSpec{GHC.is_mod}) _) = (is_mod, Nothing)--data PkgSummary = PkgSummary [GHC.PackageName] [GHC.PackageName]-  deriving (Eq, Ord)--{- BOILERPLATE PkgSummary ToSexp field=[used,unused] -}-{- BOILERPLATE START -}-instance ToSexp PkgSummary where-  toSexp (PkgSummary p_1_1 p_1_2) = alist [("used", toSexp p_1_1), ("unused", toSexp p_1_2)]-{- BOILERPLATE END -}

@@ -1,8 +1,23 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ViewPatterns #-}  module HsInspect.Runner (runGhcAndJamMasterShe, ghcflags_flags) where +#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+import qualified GHC.Driver.Env.Types as GHC+import qualified GHC.Unit.Env as GHC+#endif++#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+import qualified GHC.Driver.Session as GHC+import qualified GHC.Data.EnumSet as GHC+#else+import qualified DynFlags as GHC+import qualified EnumSet as GHC+#endif+import qualified GHC as GHC+ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Except (ExceptT(..))@@ -10,10 +25,6 @@ import qualified Data.List as L import Data.Maybe (catMaybes) import qualified Data.Text as T-import DynFlags (parseDynamicFlagsCmdLine, updOptLevel)-import qualified EnumSet as EnumSet-import GHC (Ghc, GhcMonad, getSessionDynFlags)-import qualified GHC as GHC import HsInspect.Context import HsInspect.Util (homeSources) import HsInspect.Workarounds (parseModuleName')@@ -22,27 +33,40 @@  -- expects the PWD to be the same as the .cabal file and the PATH to be what the -- build tool sees.-runGhcAndJamMasterShe :: [String] -> Bool -> Ghc a -> IO a+runGhcAndJamMasterShe :: [String] -> Bool -> GHC.Ghc a -> IO a runGhcAndJamMasterShe (filterFlags -> flags) setTargets work =   let libdir = (drop 2) <$> find ("-B" `isPrefixOf`) flags       flags' = filter (not . ("-B" `isPrefixOf`)) flags    in GHC.runGhc libdir $ do   dflags <- GHC.getSessionDynFlags-  (updOptLevel 0 -> dflags', (GHC.unLoc <$>) -> _ghcargs, _) <--    liftIO $ parseDynamicFlagsCmdLine dflags (GHC.noLoc <$> flags')+  (GHC.updOptLevel 0 -> dflags', (GHC.unLoc <$>) -> _ghcargs, _) <-+    liftIO $ GHC.parseDynamicFlagsCmdLine dflags (GHC.noLoc <$> flags')   void $ GHC.setSessionDynFlags dflags'-         { GHC.hscTarget = GHC.HscInterpreted -- HscNothing compiles home modules, dunno why+         {+#if MIN_VERSION_GLASGOW_HASKELL(9,5,0,0)+           GHC.backend = GHC.interpreterBackend+#elif MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+           GHC.backend = GHC.Interpreter+#else+           GHC.hscTarget = GHC.HscInterpreted -- HscNothing compiles home modules, dunno why+#endif          , GHC.ghcLink   = GHC.LinkInMemory   -- required by HscInterpreted          , GHC.ghcMode   = GHC.MkDepend       -- prefer .hi to .hs for dependencies-         , GHC.warningFlags = EnumSet.empty-         , GHC.fatalWarningFlags = EnumSet.empty+         , GHC.warningFlags = GHC.empty+         , GHC.fatalWarningFlags = GHC.empty          }    when setTargets $ do     -- The caller may have provided a list of home modules, but we do not trust     -- them because the ghcflags plugin does not keep the flags up to date for     -- incremental compiles.+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+    sess <- GHC.getSession+    let unitid = GHC.ue_current_unit $ GHC.hsc_unit_env sess+        mkTarget m = GHC.Target (GHC.TargetModule m) True unitid Nothing+#else     let mkTarget m = GHC.Target (GHC.TargetModule m) True Nothing+#endif     homeModules <- inferHomeModules     GHC.setTargets $ mkTarget <$> homeModules 

@@ -1,16 +1,19 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-}  -- | Very minimal ADT for outputting some S-Expressions. module HsInspect.Sexp where +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+import qualified GHC.Utils.Json as GHC+#else+import qualified Json as GHC+#endif+ import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as T-import FastString (unpackFS)-import Json (escapeJsonString)-import Module (ModuleName, moduleNameString)-import PackageConfig (PackageName(..), SourcePackageId(..))  data Sexp   = SexpCons Sexp Sexp@@ -69,15 +72,6 @@   toSexp (Just a) = toSexp a   toSexp Nothing = SexpNil -instance ToSexp SourcePackageId where-  toSexp (SourcePackageId fs) = SexpString . T.pack $ unpackFS fs--instance ToSexp ModuleName where-  toSexp = SexpString . T.pack . moduleNameString--instance ToSexp PackageName where-  toSexp (PackageName fs) = SexpString . T.pack $ unpackFS fs- filterNil :: Sexp -> Sexp filterNil SexpNil = SexpNil filterNil (SexpCons (SexpCons (SexpSymbol _) SexpNil) rest) = filterNil rest@@ -90,7 +84,7 @@ render SexpNil = "nil" render (toList -> Just ss) = "(" <> (T.intercalate " " $ render <$> ss) <> ")\n" render (SexpCons a b) = "(" <> render a <> " . " <> render b <> ")\n"-render (SexpString s) = "\"" <> (T.pack . escapeJsonString $ T.unpack s) <> "\""-render (SexpSymbol a) = T.pack . escapeJsonString $ T.unpack a+render (SexpString s) = "\"" <> (T.pack . GHC.escapeJsonString $ T.unpack s) <> "\""+render (SexpSymbol a) = T.pack . GHC.escapeJsonString $ T.unpack a render (SexpInt i) = T.pack $ show i -- TODO write our own escapeString to avoid a ghc dep and improve perf

@@ -1,28 +1,47 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}  module HsInspect.Types where +#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+import qualified GHC.Utils.Error as GHC+import qualified GHC.Types.Error as GHC+#elif MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+import qualified GHC.Utils.Error as GHC+import qualified GHC.Parser.Errors.Ppr as GHC+#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+import qualified GHC.Utils.Error as GHC+#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+import qualified ErrUtils as GHC+#endif++#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+import qualified GHC.Parser.Lexer as GHC+import qualified GHC.Utils.Outputable as GHC+import qualified GHC.Driver.Session as GHC+import qualified GHC.Parser as Parser+import qualified GHC.Rename.HsType as GHC+#else+import qualified DynFlags as GHC+import qualified Lexer as GHC+import qualified Outputable as GHC+import qualified Parser as Parser+import qualified RnTypes as GHC+#endif++import qualified GHC as GHC+ import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO) import Data.List (sortOn) import Data.Maybe (mapMaybe) import Data.Text (Text) import qualified Data.Text as T-import qualified DynFlags as GHC-import GHC (HscEnv)-import qualified GHC as GHC import HsInspect.Sexp import qualified HsInspect.Util as H import HsInspect.Workarounds (mkCppState)-import qualified Lexer as GHC-import qualified Outputable as GHC-import qualified Parser-import qualified RnTypes as GHC-#if __GLASGOW_HASKELL__ >= 810-import qualified ErrUtils as GHC-#endif  data Type = ProductType Text [Text] Bool Text [(Text, [Text])]  -- ^^ type tparams newtype cons [(param types, [typarams])]           | RecordType Text [Text] Bool Text [(Text, Text, [Text])] -- ^^ type tparams newtype cons [(fieldname, param type, [typarams])]@@ -67,7 +86,7 @@   env <- GHC.getSession   liftIO $ parseTypes env file -parseTypes :: HscEnv -> FilePath -> IO ([Type], [Comment])+parseTypes :: GHC.HscEnv -> FilePath -> IO ([Type], [Comment]) parseTypes env file = do   (pstate, _) <- mkCppState env file   let showGhc :: GHC.Outputable a => a -> Text@@ -84,12 +103,18 @@                 GHC.Prefix -> showGhc tycon'                 GHC.Infix -> "(" <> showGhc tycon' <> ")"               tparams = renderTparam <$> tparams'+#if MIN_VERSION_GLASGOW_HASKELL(9,5,0,0)+              nt = case GHC.dd_cons ddn of+                GHC.NewTypeCon _ -> True+                GHC.DataTypeCons _ _ -> False+#else               nt = case GHC.dd_ND ddn of                 GHC.NewType -> True                 GHC.DataType -> False+#endif               renderTyParams :: GHC.LHsType GHC.GhcPs -> [Text]               renderTyParams tpe = showGhc <$>-#if __GLASGOW_HASKELL__ >= 810+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)                 GHC.extractHsTyRdrTyVars tpe #else                 (GHC.freeKiTyVarsTypeVars $ GHC.extractHsTyRdrTyVars tpe)@@ -98,16 +123,31 @@               renderField (GHC.L _ field) =                 let tpe = GHC.cd_fld_type field                  in (showGhc . head $ GHC.cd_fld_names field, showGhc tpe, renderTyParams tpe)-              renderArg :: GHC.LBangType GHC.GhcPs -> (Text, [Text]) -- (type, typarams)-              renderArg t@(GHC.L _ arg) = (showGhc arg, renderTyParams t)+              renderArg' :: GHC.LBangType GHC.GhcPs -> (Text, [Text]) -- (type, typarams)+              renderArg' t@(GHC.L _ arg) = (showGhc arg, renderTyParams t)+#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+              renderArg = renderArg' . GHC.hsScaledThing+#else+              renderArg = renderArg'+#endif               -- rhs is (cons, [(field name, field type, [typarams])] | [(parameter type, [typarams])])               rhs = do+#if MIN_VERSION_GLASGOW_HASKELL(9,5,0,0)+                ddl <- case GHC.dd_cons ddn of+                  GHC.NewTypeCon (GHC.unLoc -> a) -> [a]+                  GHC.DataTypeCons _ (fmap GHC.unLoc -> as) -> as+#else                 (GHC.L _ ddl) <- GHC.dd_cons ddn+#endif                 case ddl of                   -- http://hackage.haskell.org/package/ghc-8.8.3/docs/HsDecls.html#t:ConDecl                   GHC.ConDeclH98 _ cons _ _ _ (GHC.RecCon (GHC.L _ fields)) _ -> [(showGhc cons, Left $ renderField <$> fields)]                   GHC.ConDeclH98 _ cons _ _ _ (GHC.InfixCon a1 a2) _ -> [("(" <> showGhc cons <> ")", Right $ renderArg <$> [a1, a2])]+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+                  GHC.ConDeclH98 _ cons _ _ _ (GHC.PrefixCon _ args) _ -> [(showGhc cons, Right $ renderArg <$> args)]+#else                   GHC.ConDeclH98 _ cons _ _ _ (GHC.PrefixCon args) _ -> [(showGhc cons, Right $ renderArg <$> args)]+#endif                   _ -> [] -- GADTS               in case rhs of@@ -121,26 +161,67 @@            findType _ = Nothing +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+          renderTparam :: GHC.LHsTyVarBndr () GHC.GhcPs -> Text+          renderTparam (GHC.L _ (GHC.UserTyVar _ _ p)) = showGhc p+          renderTparam (GHC.L _ (GHC.KindedTyVar _ _ p _)) = showGhc p+#else           renderTparam :: GHC.GenLocated l (GHC.HsTyVarBndr GHC.GhcPs) -> Text           renderTparam (GHC.L _ (GHC.UserTyVar _ p)) = showGhc p           renderTparam (GHC.L _ (GHC.KindedTyVar _ p _)) = showGhc p           renderTparam (GHC.L _ (GHC.XTyVarBndr _)) = "<unsupported>"-+#endif+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+          extractComment (GHC.L (GHC.anchor -> pos) c) =+#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+          extractComment (GHC.L pos c) =+#else           extractComment (GHC.L (GHC.RealSrcSpan pos) c) =+#endif             let start = Pos (GHC.srcSpanStartLine pos) (GHC.srcSpanStartCol pos)                 end = Pos (GHC.srcSpanEndLine pos) (GHC.srcSpanEndCol pos)+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+             in (\str -> Comment (T.pack str) start end) <$> case GHC.ac_tok c of+            (GHC.EpaLineComment txt) -> Just txt+            (GHC.EpaBlockComment txt) -> Just txt+            _ -> Nothing+#else              in (\str -> Comment (T.pack str) start end) <$> case c of             (GHC.AnnLineComment txt) -> Just txt             (GHC.AnnBlockComment txt) -> Just txt             _ -> Nothing+#endif+#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+#else           extractComment _ = Nothing-+#endif           types = mapMaybe findType decls           comments = mapMaybe extractComment $ GHC.comment_q st        pure (types, sortOn (\(Comment _ s _) -> s) comments) -#if __GLASGOW_HASKELL__ >= 810+#if MIN_VERSION_GLASGOW_HASKELL(9,5,0,0)+    GHC.PFailed st ->+      let errs = GHC.interppSP+            . GHC.pprMsgEnvelopeBagWithLocDefault+            . GHC.getMessages+            $ GHC.getPsErrorMessages st+      in throwIO . userError $ "unable to parse " <> file <> " due to " <> GHC.showSDocUnsafe errs+#elif MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+    GHC.PFailed st ->+      let errs = GHC.interppSP+            . GHC.pprMsgEnvelopeBagWithLoc+            . GHC.getMessages+            $ GHC.getPsErrorMessages st+      in throwIO . userError $ "unable to parse " <> file <> " due to " <> GHC.showSDocUnsafe errs+#elif MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+    GHC.PFailed st ->+      let errs = GHC.interppSP+            . GHC.pprMsgEnvelopeBagWithLoc+            . fmap GHC.pprError+            $ GHC.getErrorMessages st+      in throwIO . userError $ "unable to parse " <> file <> " due to " <> GHC.showSDocUnsafe errs+#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)     GHC.PFailed st ->       let errs = GHC.interppSP             . GHC.pprErrMsgBagWithLoc

@@ -1,15 +1,24 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-}  module HsInspect.Util where +#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+import qualified GHC.Utils.Outputable as GHC+#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+import qualified GHC.Utils.Outputable as GHC+import qualified GHC.Driver.Session as GHC+#else+import qualified DynFlags as GHC+import qualified Outputable as GHC+#endif+import qualified GHC as GHC+ import Control.Monad.IO.Class import Data.List (find, isSuffixOf, nub) import Data.Maybe (catMaybes) import Data.Set (Set) import qualified Data.Set as Set-import DynFlags (unsafeGlobalDynFlags)-import qualified GHC as GHC-import Outputable (Outputable, showPpr) import System.Directory (doesDirectoryExist, listDirectory, makeAbsolute) import System.FilePath (takeDirectory, takeFileName, (</>)) @@ -20,8 +29,12 @@   let infer dir = liftIO $ walkSuffix ".hs" dir   nub . concat <$> traverse infer paths -showGhc :: (Outputable a) => a -> String-showGhc = showPpr unsafeGlobalDynFlags+showGhc :: (GHC.Outputable a) => a -> String+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+showGhc = GHC.showPprUnsafe+#else+showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags+#endif  getTargetModules :: GHC.GhcMonad m => m (Set GHC.ModuleName) getTargetModules = do

@@ -5,74 +5,121 @@  module HsInspect.Workarounds where -import Control.Monad-import Control.Monad.IO.Class-import Data.List (delete, intercalate, isSuffixOf)-import Data.Set (Set)-import qualified Data.Set as Set-import DriverPipeline (preprocess)-import DynFlags (parseDynamicFilePragma)-import FastString-import qualified GHC as GHC-import HeaderInfo (getOptions)-import HscTypes (HscEnv, Target(..), TargetId(..))+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+import qualified GHC.Driver.Config.Parser as GHC+import qualified GHC.Driver.Env.Types as GHC+import qualified GHC.Driver.Ppr as GHC+import qualified GHC.Types.Target as GHC+import qualified GHC.Unit.Env as GHC+#elif MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+import qualified GHC.Types.Target as GHC+import qualified GHC.Driver.Config as GHC+import qualified GHC.Driver.Ppr as GHC+#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+import qualified GHC.Utils.Outputable as GHC+#endif++#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+import qualified GHC.Driver.Pipeline as Pipeline+import qualified GHC.Driver.Session as GHC+import qualified GHC.Data.FastString as GHC+import qualified GHC.Parser.Header as GHC+import qualified GHC.Parser.Lexer as GHC+import qualified GHC.Parser as GHC+import qualified GHC.Types.SrcLoc as GHC+import qualified GHC.Types.Name.Reader as GHC+import qualified GHC.Data.StringBuffer as GHC+#else+import qualified DriverPipeline as Pipeline+import qualified DynFlags as GHC+import qualified FastString as GHC+import qualified HeaderInfo as GHC+import qualified HscTypes as GHC+import qualified Lexer as GHC+import qualified Outputable as GHC+import qualified Parser as GHC+import qualified RdrName as GHC+import qualified SrcLoc as GHC+import qualified StringBuffer as GHC+#endif #if MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)-import GHC.Hs.ImpExp (ImportDecl(..))+import qualified GHC.Hs.ImpExp as GHC #else-import HsImpExp (ImportDecl(..))+import qualified HsImpExp as GHC #endif-import Lexer-import Outputable (showPpr)-import Parser (parseHeader)-import RdrName (GlobalRdrEnv)-import SrcLoc-import StringBuffer-import System.Directory (getModificationTime, removeFile)+#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+import qualified GHC.Types.Name.Occurrence as GHC+#elif MIN_VERSION_GLASGOW_HASKELL(8,8,2,0)+import qualified OccName as GHC+#else+import qualified TcRnTypes as GHC+#endif+import qualified GHC as GHC  #if MIN_VERSION_GLASGOW_HASKELL(8,8,2,0) import Data.Maybe (fromJust, fromMaybe)-import OccName (emptyOccEnv)-#else-import TcRnTypes (tcg_rdr_env) #endif+import Control.Monad+import Control.Monad.IO.Class+import Data.List (delete, intercalate, isSuffixOf)+import Data.Set (Set)+import qualified Data.Set as Set+import System.Directory (getModificationTime, removeFile)  -- applies CPP rules to the input file and extracts the pragmas,--- a more portable alternative to GHC.hGetStringBuffer-mkCppState :: HscEnv -> FilePath -> IO (PState, [Located String])+-- a more reliable alternative to GHC.hGetStringBuffer+mkCppState :: GHC.HscEnv -> FilePath -> IO (GHC.PState, [GHC.Located String]) mkCppState sess file = do #if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)-  pp <- preprocess sess file Nothing Nothing+  pp <- Pipeline.preprocess sess file Nothing Nothing   let (dflags, tmp) = case pp of         Left _ -> error $ "preprocessing failed " <> show file         Right success -> success #else   (dflags, tmp) <- preprocess sess (file, Nothing) #endif-  full <- hGetStringBuffer tmp+  full <- GHC.hGetStringBuffer tmp   when (".hscpp" `isSuffixOf` tmp) $     liftIO . removeFile $ tmp-  let pragmas = getOptions dflags full file-      loc  = mkRealSrcLoc (mkFastString file) 1 1-  (dflags', _, _) <- parseDynamicFilePragma dflags pragmas-  pure $ (mkPState dflags' full loc, pragmas)+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+  let (_, pragmas) = GHC.getOptions (GHC.initParserOpts dflags) full file+#else+  let pragmas = GHC.getOptions dflags full file+#endif+      loc  = GHC.mkRealSrcLoc (GHC.mkFastString file) 1 1+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+      mkPState' = GHC.initParserState . GHC.initParserOpts+#else+      mkPState' = GHC.mkPState+#endif+  (dflags', _, _) <- GHC.parseDynamicFilePragma dflags pragmas+  pure $ (mkPState' dflags' full loc, pragmas) +#if MIN_VERSION_GLASGOW_HASKELL(9,5,0,0) parseHeader' :: GHC.GhcMonad m => FilePath -> m ([String], GHC.HsModule GHC.GhcPs)+#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+parseHeader' :: GHC.GhcMonad m => FilePath -> m ([String], GHC.HsModule)+#else+parseHeader' :: GHC.GhcMonad m => FilePath -> m ([String], GHC.HsModule GHC.GhcPs)+#endif parseHeader' file = do   sess <- GHC.getSession   (pstate, pragmas) <- liftIO $ mkCppState sess file-  case unP parseHeader pstate of-    POk _ (L _ hsmod) -> pure (unLoc <$> pragmas, hsmod)+  case GHC.unP GHC.parseHeader pstate of+    GHC.POk _ (GHC.L _ hsmod) -> pure (GHC.unLoc <$> pragmas, hsmod)     _ -> error $ "parseHeader failed for " <> file -importsOnly :: GHC.GhcMonad m => Set GHC.ModuleName -> FilePath -> m (Maybe GHC.ModuleName, Target)+importsOnly :: GHC.GhcMonad m => Set GHC.ModuleName -> FilePath -> m (Maybe GHC.ModuleName, GHC.Target) importsOnly homes file = do   dflags <- GHC.getSessionDynFlags   (pragmas, hsmod) <- parseHeader' file-  let allowed (L _ (ImportDecl{ideclName})) = Set.notMember (unLoc ideclName) homes-#if MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)-      allowed (L _ (XImportDecl _)) = False+  let allowed :: GHC.GenLocated l (GHC.ImportDecl GHC.GhcPs) -> Bool+      allowed (GHC.L _ (GHC.ImportDecl{GHC.ideclName})) = Set.notMember (GHC.unLoc ideclName) homes+#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+#elif MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)+      allowed (GHC.L _ (GHC.XImportDecl _)) = False #endif-      modname = unLoc <$> GHC.hsmodName hsmod+      modname = GHC.unLoc <$> GHC.hsmodName hsmod       extra =         if modname == Nothing || modname == (Just $ GHC.mkModuleName "Main")         then "\nmain = return ()"@@ -83,27 +130,33 @@       pragmas' = delete "-XCPP" pragmas       contents =         "{-# OPTIONS_GHC " <> (intercalate " " pragmas') <> " #-}\n" <>-        showPpr dflags (hsmod { GHC.hsmodExports = Nothing+        GHC.showPpr dflags (hsmod { GHC.hsmodExports = Nothing                                , GHC.hsmodImports = imps }) <>         extra-      trimmed = stringToStringBuffer contents+      trimmed = GHC.stringToStringBuffer contents    ts <- liftIO $ getModificationTime file   -- since 0f9ec9d1ff can't use Phase-  pure $ (modname, Target (TargetFile file Nothing) False (Just (trimmed, ts)))+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+  sess <- GHC.getSession+  let unitid = GHC.ue_current_unit $ GHC.hsc_unit_env sess+  pure $ (modname, GHC.Target (GHC.TargetFile file Nothing) False unitid (Just (trimmed, ts)))+#else+  pure $ (modname, GHC.Target (GHC.TargetFile file Nothing) False (Just (trimmed, ts)))+#endif  parseModuleName' :: GHC.GhcMonad m => FilePath -> m (Maybe GHC.ModuleName) parseModuleName' file = do   (_, hsmod) <- parseHeader' file-  pure $ unLoc <$> GHC.hsmodName hsmod+  pure $ GHC.unLoc <$> GHC.hsmodName hsmod  -- WORKAROUND https://gitlab.haskell.org/ghc/ghc/merge_requests/1541-minf_rdr_env' :: GHC.GhcMonad m => GHC.ModuleName -> m GlobalRdrEnv+minf_rdr_env' :: GHC.GhcMonad m => GHC.ModuleName -> m GHC.GlobalRdrEnv minf_rdr_env' m = do #if MIN_VERSION_GLASGOW_HASKELL(8,8,2,0)   mo <- GHC.findModule m Nothing   (fromJust -> mi) <- GHC.getModuleInfo mo-  pure . fromMaybe emptyOccEnv $ GHC.modInfoRdrEnv mi+  pure . fromMaybe GHC.emptyOccEnv $ GHC.modInfoRdrEnv mi #else   modSum <- GHC.getModSummary m   pmod <- GHC.parseModule modSum@@ -111,5 +164,3 @@   let (tc_gbl_env, _) = GHC.tm_internals_ tmod   pure $ tcg_rdr_env tc_gbl_env #endif--