hsinspect 0.0.3 → 0.0.4

raw patch · 9 files changed

+505/−115 lines, 9 filesdep +containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: containers

API changes (from Hackage documentation)

Files

• exe/Main.hs +48/−14
• hsinspect.cabal +8/−2
• library/HsInspect/Imports.hs +49/−86
• library/HsInspect/Modules.hs +42/−0
• library/HsInspect/Packages.hs +120/−0
• library/HsInspect/Plugin.hs +73/−0
• library/HsInspect/Search.hs +77/−0
• library/HsInspect/Sexp.hs +15/−13
• library/HsInspect/Workarounds.hs +73/−0

@@ -1,15 +1,21 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-}+ module Main where  import           Control.Monad import           Control.Monad.IO.Class import           Data.Char (isUpper)-import           DynFlags (parseDynamicFlagsCmdLine)+import           Data.List (isPrefixOf)+import           DynFlags (parseDynamicFlagsCmdLine, updOptLevel) import qualified GHC as GHC import           GHC.Paths (libdir) import           HsInspect.Imports+import           HsInspect.Modules+import           HsInspect.Packages+import           HsInspect.Search import           HsInspect.Sexp as S import           Json import           Outputable (defaultUserStyle, initSDocContext, runSDoc)@@ -29,7 +35,10 @@   "  `command ARGS' can be:\n\n" ++   "  imports /path/to/file.hs - list the qualified imports for the file\n" ++   "                             along with their locally qualified (and\n" ++-  "                             unqualified) names."+  "                             unqualified) names.\n" +++  "  modules /path/to/file.hs - list all modules that could be imported by file.\n" +++  "  packages /path/to/dir    - list all packages that are imported by this dir.\n" +++  "  search  /path/to/file.hs QUERY - Hoogle query within the file's context.\n "  -- Possible backends: --@@ -37,30 +46,55 @@ -- http://hackage.haskell.org/package/cabal-helper main :: IO () main = do-  (break ("--" ==) -> (args, flags)) <- getArgs+  (break ("--" ==) -> (args, filterFlags -> flags)) <- getArgs   when (elem "--help" args) $     (putStrLn help) >> exitWith ExitSuccess   when (elem "--version" args) $     (putStrLn version) >> exitWith ExitSuccess+  -- TODO require a -B flag instead of the ghc-paths dependency   GHC.runGhc (Just libdir) $ do     dflags <- GHC.getSessionDynFlags-    (dflags', (GHC.unLoc <$>) -> ghcargs, _) <- liftIO $ parseDynamicFlagsCmdLine dflags (GHC.noLoc <$> tail flags)+    (updOptLevel 0 -> dflags', (GHC.unLoc <$>) -> ghcargs, _) <-+      liftIO $ parseDynamicFlagsCmdLine dflags (GHC.noLoc <$> flags)     void $ GHC.setSessionDynFlags dflags'-           { GHC.hscTarget = GHC.HscNothing-           , GHC.ghcLink   = GHC.NoLink+           { GHC.hscTarget = GHC.HscInterpreted -- HscNothing compiles home modules, dunno why+           , GHC.ghcLink   = GHC.LinkInMemory   -- required by HscInterpreted+           , GHC.ghcMode   = GHC.MkDepend       -- prefer .hi to .hs for dependencies            }-    let modules = GHC.mkModuleName <$> (filter (isUpper . head) ghcargs)-    GHC.setTargets $ (\m -> GHC.Target (GHC.TargetModule m) True Nothing) <$> modules+    let homeModules = (filter (isUpper . head) ghcargs)+    GHC.setTargets $+      -- TODO it would be good if ghc had a "binary only" option for Targets+      --      with fail fast if only source code (no .hi) is discovered.+      (\m -> GHC.Target (GHC.TargetModule $ GHC.mkModuleName m) True Nothing) <$> homeModules+    let respond rest as = liftIO . putStrLn $+          if (elem "--json" rest)+          then encodeJson dflags' as+          else S.encode as     case args of       "imports" : file : rest -> do         quals <- imports file-        let output = if (elem "--json" rest)-                     then encodeJson dflags' . JSArray $ (json <$> quals)-                     else S.encode quals-        liftIO . putStrLn $ output+        respond rest quals+      "modules" : rest -> do+        hits <- modules homeModules+        respond rest hits+      "packages" : dir : rest -> do+        hits <- packages dir+        respond rest hits+      "search" : query : rest -> do+        hits <- search query+        respond rest hits       _ ->         liftIO $ error "invalid parameters" -encodeJson :: GHC.DynFlags -> JsonDoc -> String-encodeJson dflags = show . flip runSDoc ctx . renderJSON+-- TODO let each component remove things that interfere+filterFlags :: [String] -> [String]+filterFlags ("--" : rest) = filter allow rest+  where allow flag = "-Wno" `isPrefixOf` flag || not ("-W" `isPrefixOf` flag)+filterFlags _ = []++encodeJson :: ToJson a => GHC.DynFlags -> a -> String+encodeJson dflags as = show . flip runSDoc ctx . renderJSON . json $ as   where ctx = initSDocContext dflags $ defaultUserStyle dflags++instance ToJson a => ToJson [a] where+  json as = JSArray $ json <$> as

@@ -1,6 +1,6 @@ cabal-version: 2.2 name:          hsinspect-version:       0.0.3+version:       0.0.4 synopsis:      Inspect Haskell source files. license:       GPL-3.0-or-later license-file:  LICENSE@@ -20,7 +20,8 @@  common deps   build-depends:-    , base       >=4.11 && <5+    , base        >=4.11 && <5+    , containers     , directory     , ghc     , ghc-boot@@ -46,4 +47,9 @@   -- cabal-fmt: expand library   exposed-modules:     HsInspect.Imports+    HsInspect.Modules+    HsInspect.Packages+    HsInspect.Plugin+    HsInspect.Search     HsInspect.Sexp+    HsInspect.Workarounds

@@ -4,27 +4,20 @@  module HsInspect.Imports where -import           Control.Monad-import           Control.Monad.IO.Class-import           Data.List (delete, intercalate, isSuffixOf)-import           DriverPhases (HscSource(..), Phase(..))-import           DriverPipeline (preprocess)-import           DynFlags (parseDynamicFilePragma, unsafeGlobalDynFlags)-import           FastString+import Data.Maybe (fromJust)+import DynFlags (unsafeGlobalDynFlags) import qualified GHC as GHC-import           HeaderInfo (getOptions)-import           HscTypes (Target(..), TargetId(..))-import           HsInspect.Sexp-import           Json-import           Lexer-import           Outputable (Outputable, showPpr)-import           Parser (parseHeader)-import           RdrName (GlobalRdrElt(..), GlobalRdrEnv, ImpDeclSpec(..),-                          ImportSpec(..), globalRdrEnvElts)-import           SrcLoc-import           StringBuffer-import           System.Directory (getModificationTime, removeFile)-import           TcRnTypes (tcg_rdr_env)+import HsInspect.Sexp+import HsInspect.Workarounds+import HscTypes (TargetId (..))+import Json+import Outputable (Outputable, showPpr)+import RdrName+  ( GlobalRdrElt (..),+    ImpDeclSpec (..),+    ImportSpec (..),+    globalRdrEnvElts,+  )  imports :: GHC.GhcMonad m => FilePath -> m [Qualified] imports file = do@@ -33,11 +26,14 @@  imports' :: GHC.GhcMonad m => FilePath -> m [GlobalRdrElt] imports' file = do-  (m, target) <- workaroundGhc file+  -- TODO no need for this in 8.8.2++  (fromJust -> m, target) <- importsOnly mempty file    GHC.removeTarget $ TargetModule m   GHC.addTarget target +  -- TODO performance can be very bad here. It is possible that ghc is compiling+  -- modules in the home module that have .hi files that would be much faster.   _ <- GHC.load $ GHC.LoadUpTo m    rdr_env <- minf_rdr_env' m@@ -46,79 +42,46 @@ showGhc :: (Outputable a) => a -> String showGhc = showPpr unsafeGlobalDynFlags --- TODO CPP should use the trivial impl in ghc 8.8---- WORKAROUND https://gitlab.haskell.org/ghc/ghc/merge_requests/1541-workaroundGhc :: GHC.GhcMonad m => FilePath -> m (GHC.ModuleName, Target)-workaroundGhc file = do-  sess <- GHC.getSession-  (dflags, tmp) <- liftIO $ preprocess sess (file, Nothing)-  full <- liftIO $ 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-  (modname, trimmed) <- case unP parseHeader (mkPState dflags' full loc) of-    POk _ (L _ hsmod@(GHC.hsmodName -> (Just (L _ modname)))) -> do-      let extra =-            if modname == (GHC.mkModuleName "Main")-            then "\nmain = return ()" -- TODO check that return is imported-            else ""-          -- WORKAROUND https://gitlab.haskell.org/ghc/ghc/issues/17066-          --            cannot use CPP in combination with targetContents-          pragmas' = delete "-XCPP" (unLoc <$> pragmas)-          contents =-            "{-# OPTIONS_GHC " <> (intercalate " " pragmas') <> " #-}\n" <>-            showPpr dflags' (hsmod { GHC.hsmodExports = Nothing }) <>-            extra-      pure (modname, stringToStringBuffer contents)-    _ -> error "parseHeader failed"--  ts <- liftIO $ getModificationTime file-  pure $ (modname, Target (TargetFile file (Just $ Hsc HsSrcFile)) False (Just (trimmed, ts)))---- WORKAROUND https://gitlab.haskell.org/ghc/ghc/merge_requests/1541-minf_rdr_env' :: GHC.GhcMonad m => GHC.ModuleName -> m GlobalRdrEnv-minf_rdr_env' m = do-  modSum <- GHC.getModSummary m-  pmod <- GHC.parseModule modSum-  tmod <- GHC.typecheckModule pmod-  let (tc_gbl_env, _) = GHC.tm_internals_ tmod-  pure $ tcg_rdr_env tc_gbl_env- describe :: GlobalRdrElt -> [Qualified]-describe GRE{gre_name, gre_imp} = describe' <$> gre_imp+describe GRE {gre_name, gre_imp} = describe' <$> gre_imp   where-    describe' ImpSpec{is_decl=ImpDeclSpec{is_mod, is_as, is_qual}} =-      let ln  = if is_qual-                then Nothing-                else Just $ showGhc gre_name-          lqn = if is_mod == is_as-                then Nothing-                else Just $ showGhc is_as ++ "." ++ showGhc gre_name+    describe' ImpSpec {is_decl = ImpDeclSpec {is_mod, is_as, is_qual}} =+      let ln =+            if is_qual+              then Nothing+              else Just $ showGhc gre_name+          lqn =+            if is_mod == is_as+              then Nothing+              else Just $ showGhc is_as ++ "." ++ showGhc gre_name           fqn = showGhc is_mod ++ "." ++ showGhc gre_name-      in Qualified ln lqn fqn-      -- Note that `nameSrcLoc gre_name` is empty-      -- TODO what other information is available?-      -- TODO "and originally defined" / ppr_defn_site+       in Qualified ln lqn fqn -data Qualified = Qualified-                   (Maybe String) -- ^^ local name-                   (Maybe String) -- ^^ locally qualifed name-                   String         -- ^^ fully qualified name+-- Note that `nameSrcLoc gre_name` is empty+-- TODO what other information is available?+-- TODO "and originally defined" / ppr_defn_site+data Qualified+  = Qualified+      (Maybe String) -- ^^ local name+      (Maybe String) -- ^^ locally qualifed name+      String -- ^^ fully qualified name   deriving (Eq, Show)  instance ToSexp Qualified where   toSexp (Qualified ln lqn fqn) =-    alist [ ("local", toSexp ln)-          , ("qual", toSexp lqn)-          , ("full", toSexp fqn)]+    alist+      [ ("local", toSexp ln),+        ("qual", toSexp lqn),+        ("full", toSexp fqn)+      ]  instance ToJson Qualified where   json (Qualified ln lqn fqn) =-    JSObject [ ("local", json' ln)-             , ("qual" , json' lqn)-             , ("full" , JSString fqn)]-    where json' Nothing = JSNull-          json' (Just a) = JSString a+    JSObject+      [ ("local", json' ln),+        ("qual", json' lqn),+        ("full", JSString fqn)+      ]+    where+      json' Nothing = JSNull+      json' (Just a) = JSString a

@@ -0,0 +1,42 @@+{-# LANGUAGE NamedFieldPuns #-}++-- | Calculate all exposed modules that could be imported.+module HsInspect.Modules+  ( modules,+  )+where++import Data.List (sort)+import Data.Set (Set)+import qualified Data.Set as Set+import qualified GHC+import GHC.PackageDb+import HsInspect.Sexp+import Json+import Module (UnitId)+import PackageConfig+import Packages (explicitPackages)++modules :: GHC.GhcMonad m => [String] -> m [Hit]+modules homeModules = do+  dflags <- GHC.getSessionDynFlags+  let Just dbs = GHC.pkgDatabase dflags+      loaded = Set.fromList . explicitPackages $ GHC.pkgState dflags+      home = Hit <$> homeModules+      away = (mods loaded =<<) =<< (snd <$> dbs)+  pure . sort $ home <> away++mods :: Set UnitId -> PackageConfig -> [Hit]+mods allowed p =+  if Set.notMember (packageConfigId p) allowed+    then []+    else Hit . GHC.moduleNameString . fst <$> exposedModules p++data Hit = Hit String+  deriving (Eq, Ord)++instance ToSexp Hit where+  toSexp (Hit txt) = toSexp txt++instance ToJson Hit where+  json (Hit txt) = JSString txt

@@ -0,0 +1,120 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module HsInspect.Packages (packages) where++import           BasicTypes (StringLiteral(..))+import           Control.Monad (join, void)+import           Control.Monad.IO.Class (liftIO)+import           Data.List (isSuffixOf, nub, sort, (\\))+import           Data.Maybe (catMaybes)+import qualified Data.Set as Set+import           FastString+import           Finder (findImportedModule)+import qualified GHC+import           HscTypes (FindResult(..))+import           HsInspect.Sexp+import           HsInspect.Workarounds+import           Json+import           Module (Module(..), ModuleName, moduleNameString, unitIdString)+import           Packages (PackageState(..))+import           System.Directory (doesDirectoryExist, listDirectory)++-- Similar to packunused / weeder, but more reliable (and doesn't require a+-- separate -ddump-minimal-imports pass).+--+-- TODO support list of dirs not just one+packages :: GHC.GhcMonad m => FilePath -> m PkgSummary+packages dir = do+  -- We load all .hs files in dir, assuming they are the sources of the home+  -- module, but with a twist: we only parse the imports from external packages.+  -- To do this we have to unload the home modules as provided by parameters and+  -- filter then when parsing the imports section.+  args <- GHC.getTargets+  let homes = Set.fromList . catMaybes $ getModule <$> args++  srcs <- liftIO $ (filter (".hs" `isSuffixOf`)) <$> walk dir++  -- mods == homes. We could do two passes (ignore provided targets)+  (catMaybes -> mods, targets) <- unzip <$> traverse (importsOnly homes) srcs+  _ <- GHC.setTargets targets++  dflags <- GHC.getSessionDynFlags+  void $ GHC.setSessionDynFlags dflags { GHC.ghcMode = GHC.CompManager }+  _ <- GHC.load $ GHC.LoadAllTargets++  imps <- nub . join <$> traverse getImports mods+  pkgs <- catMaybes <$> traverse (uncurry findPackage) imps+  let used = nub . sort $ pkgs+  let loaded = nub . sort . explicitPackages $ GHC.pkgState dflags+  pure $ PkgSummary used (loaded \\ used)++getModule :: GHC.Target -> Maybe ModuleName+getModule GHC.Target{GHC.targetId} = case targetId of+  GHC.TargetModule m -> Just m+  GHC.TargetFile _ _ -> Nothing++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+  modSum <- GHC.getModSummary m+  pmod <- GHC.parseModule modSum+  tmod <- GHC.typecheckModule pmod+  case GHC.tm_renamed_source tmod of+    Nothing -> error $ "bad module: " ++ moduleNameString m+    Just (_, (GHC.unLoc <$>) -> imports, _, _) ->+      pure . catMaybes $ qModule <$> imports++qModule :: GHC.ImportDecl p -> Maybe (ModuleName, Maybe FastString)+qModule GHC.ImportDecl{GHC.ideclName, GHC.ideclPkgQual} = Just $+  (GHC.unLoc ideclName, qual)+  where qual = sl_fs <$> ideclPkgQual+#if MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)+qModule (GHC.XImportDecl _) = Nothing+#endif++walk :: FilePath -> IO [FilePath]+walk dir = do+  isDir <- doesDirectoryExist dir+  if isDir+  then do fs <- listDirectory dir+          let base = dir <> "/"+              qfs = (base <>) <$> fs+          concatMapM walk qfs+  else pure [dir]++-- from extra+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM op = foldr f (pure [])+    where f x xs = do+            x' <- op x+            if null x'+            then xs+            else do+              xs' <- xs+              pure $ x' ++ xs'++data PkgSummary = PkgSummary [GHC.UnitId] [GHC.UnitId]+  deriving (Eq, Ord)++instance ToSexp PkgSummary where+  toSexp (PkgSummary used unused) =+    alist [ ("used", toS used)+          , ("unused", toS unused) ]+    where toS ids = toSexp $ unitIdString <$> ids++instance ToJson PkgSummary where+  json (PkgSummary used unused) =+    JSObject [ ("used", toJ used)+             , ("unused", toJ unused) ]+    where toJ ids = JSArray $ JSString . unitIdString <$> ids+

@@ -0,0 +1,73 @@+-- | A ghc plugin that creates a .ghc.flags file populated with the flags that+--   were last used to invoke ghc for some modules, for consumption by+--   hsinspect.+--+--   https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/extending_ghc.html#compiler-plugins+module HsInspect.Plugin+  ( plugin,+  )+where++import qualified Config as GHC+import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Data.Foldable (traverse_)+import Data.List (stripPrefix)+import qualified GHC+import qualified GhcPlugins as GHC+import System.Directory (doesDirectoryExist)+import System.Environment+import System.IO.Error (catchIOError)++plugin :: GHC.Plugin+plugin =+  GHC.defaultPlugin+    { GHC.installCoreToDos = install+    }++install :: [GHC.CommandLineOption] -> [GHC.CoreToDo] -> GHC.CoreM [GHC.CoreToDo]+install _ core = do+  dflags <- GHC.getDynFlags+  args <- liftIO $ getArgs++  -- downstream tools shouldn't use this plugin, or all hell will break loose+  let ghcFlags = unwords $ replace ["-fplugin", "HsInspect.Plugin"] [] args++      -- TODO this currently only supports ghc being called with directories and+      -- home modules, we should also support calling with explicit file names.+      paths = GHC.importPaths dflags++      -- TODO we might want to filter out some include directories, e.g. build tool+      -- autogen folders.+      writeGhcFlags path =+        whenM (doesDirectoryExist path)+          $ writeFile (path <> "/.ghc.flags") ghcFlags++      enable = case GHC.hscTarget dflags of+        GHC.HscInterpreted -> False+        GHC.HscNothing -> False+        _ -> True++  when enable $ liftIO . ignoreIOExceptions $ do+    traverse_ writeGhcFlags paths+    writeFile ".ghc.version" GHC.cProjectVersion++  pure core++-- from Data.List.Extra+replace :: Eq a => [a] -> [a] -> [a] -> [a]+replace [] _ _ = error "Extra.replace, first argument cannot be empty"+replace from to xs | Just xs' <- stripPrefix from xs = to ++ replace from to xs'+replace from to (x : xs) = x : replace from to xs+replace _ _ [] = []++-- from Control.Monad.Extra+whenM :: Monad m => m Bool -> m () -> m ()+whenM b t = ifM b t (return ())++ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM b t f = do b' <- b; if b' then t else f++-- from System.Directory.Internal+ignoreIOExceptions :: IO () -> IO ()+ignoreIOExceptions io = io `catchIOError` (\_ -> pure ())

@@ -0,0 +1,77 @@+{-# LANGUAGE NamedFieldPuns #-}++module HsInspect.Search where++import BinIface+  ( CheckHiWay (..),+    TraceBinIFaceReading (..),+    readBinIface,+  )+import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import Finder (findExposedPackageModule)+import qualified GHC+import GHC.PackageDb+import HsInspect.Sexp+import HscTypes (FindResult (..), ModIface (..))+import Json+import Module (ModLocation (..), Module (..), unitIdFS)+import PackageConfig+import Packages (LookupResult (..))+import TcRnMonad (initTcRnIf)++search :: GHC.GhcMonad m => String -> m [Hit]+search _query = do+  dflags <- GHC.getSessionDynFlags+  let Just dbs = GHC.pkgDatabase dflags+      pkgs = join (snd <$> dbs)+  join <$> traverse getHits pkgs++-- TODO Maybe haddock-html+getHits :: GHC.GhcMonad m => PackageConfig -> m [Hit]+getHits pkg = do+  results <- traverse finder (lookups pkg)+  join <$> traverse toHit results++-- FIXME finder doesn't work. It probably needs everything to be loaded. Just+-- traverse the library directories looking for .hi files and filter the modules+-- based on the exported list. That should avoid the risk of compiling anything.+toHit :: GHC.GhcMonad m => FindResult -> m [Hit]+toHit (Found (ModLocation _ hi _) _) = do+  env <- GHC.getSession+  iface <-+    liftIO $ initTcRnIf 'z' env () ()+      $ readBinIface IgnoreHiWay QuietBinIFaceReading hi+  pure [Hit . show . length $ mi_exports iface]+toHit _ = pure []++-- LookupFound Module PackageConfig+-- findLookupResult+-- findExposedPackageModule+-- lookupIfaceByModule+-- showIface+-- readBinIface+finder :: GHC.GhcMonad m => LookupResult -> m FindResult+finder lup = do+  env <- GHC.getSession+  liftIO $ findLookupResult env lup++-- TODO ghc should export Finder.findLookupResult+findLookupResult :: GHC.HscEnv -> LookupResult -> IO FindResult+findLookupResult env (LookupFound (Module mid name) _) =+  findExposedPackageModule env name (Just $ unitIdFS mid)+findLookupResult _ _ = error "not supported"++lookups :: PackageConfig -> [LookupResult]+lookups c@InstalledPackageInfo {exposedModules} =+  let modules = catMaybes $ snd <$> exposedModules+   in flip LookupFound c <$> modules++data Hit = Hit String++instance ToSexp Hit where+  toSexp (Hit txt) = toSexp txt++instance ToJson Hit where+  json (Hit _) = error "not implemented yet"

@@ -5,14 +5,15 @@  module HsInspect.Sexp where -import           Data.List (intercalate)-import           Data.String-import           Json (escapeJsonString)+import Data.List (intercalate)+import Data.String+import Json (escapeJsonString) -data Sexp = SexpCons Sexp Sexp-          | SexpNil-          | SexpString String-          | SexpSymbol String+data Sexp+  = SexpCons Sexp Sexp+  | SexpNil+  | SexpString String+  | SexpSymbol String  list :: [Sexp] -> Sexp list = foldr SexpCons SexpNil@@ -27,11 +28,13 @@  alist :: [(Sexp, Sexp)] -> Sexp alist els = list $ mkEl =<< els-  where mkEl (k, v) = [SexpCons k v]+  where+    mkEl (k, v) = [SexpCons k v]  attrs :: [(String, Sexp)] -> Sexp attrs els = list $ mkEl =<< els-  where mkEl (k, v) = [SexpSymbol k, v]+  where+    mkEl (k, v) = [SexpSymbol k, v]  class ToSexp a where   toSexp :: a -> Sexp@@ -44,15 +47,14 @@  instance ToSexp a => ToSexp (Maybe a) where   toSexp (Just a) = toSexp a-  toSexp Nothing  = SexpNil+  toSexp Nothing = SexpNil  render :: Sexp -> String render SexpNil = "nil"-render (toList -> Just ss)  = "(" ++ (intercalate " " $ render <$> ss) ++ ")\n"+render (toList -> Just ss) = "(" ++ (intercalate " " $ render <$> ss) ++ ")\n" render (SexpCons a b) = "(" ++ render a ++ " . " ++ render b ++ ")\n" render (SexpString s) = "\"" ++ escapeJsonString s ++ "\""-render (SexpSymbol a)   = escapeJsonString a+render (SexpSymbol a) = escapeJsonString a  encode :: ToSexp a => a -> String encode = render . toSexp-

@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++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           DriverPhases (HscSource(..), Phase(..))+import           DriverPipeline (preprocess)+import           DynFlags (parseDynamicFilePragma)+import           FastString+import qualified GHC as GHC+import           HeaderInfo (getOptions)+import           HscTypes (Target(..), TargetId(..))+import           HsImpExp (ImportDecl(..))+import           Lexer+import           Outputable (showPpr)+import           Parser (parseHeader)+import           RdrName (GlobalRdrEnv)+import           SrcLoc+import           StringBuffer+import           System.Directory (getModificationTime, removeFile)+import           TcRnTypes (tcg_rdr_env)++-- WORKAROUND https://gitlab.haskell.org/ghc/ghc/merge_requests/1541+importsOnly :: GHC.GhcMonad m => Set GHC.ModuleName -> FilePath -> m (Maybe GHC.ModuleName, Target)+importsOnly homes file = do+  sess <- GHC.getSession+  (dflags, tmp) <- liftIO $ preprocess sess (file, Nothing)+  full <- liftIO $ hGetStringBuffer tmp+  when (".hscpp" `isSuffixOf` tmp) $+    liftIO . removeFile $ tmp+  let pragmas = getOptions dflags full file+      loc  = mkRealSrcLoc (mkFastString file) 1 1+      allowed (L _ (ImportDecl{ideclName})) = Set.notMember (unLoc ideclName) homes+#if MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)+      allowed (L _ (XImportDecl _)) = False+#endif+  (dflags', _, _) <- parseDynamicFilePragma dflags pragmas+  (modname, trimmed) <- case unP parseHeader (mkPState dflags' full loc) of+    POk _ (L _ hsmod) -> do+      let modname = unLoc <$> GHC.hsmodName hsmod+          extra =+            if modname == Nothing || modname == (Just $ GHC.mkModuleName "Main")+            then "\nmain = return ()" -- TODO check that return is imported+            else ""+          imps = filter allowed $ GHC.hsmodImports hsmod+          -- WORKAROUND https://gitlab.haskell.org/ghc/ghc/issues/17066+          --            cannot use CPP in combination with targetContents+          pragmas' = delete "-XCPP" (unLoc <$> pragmas)+          contents =+            "{-# OPTIONS_GHC " <> (intercalate " " pragmas') <> " #-}\n" <>+            showPpr dflags' (hsmod { GHC.hsmodExports = Nothing+                                   , GHC.hsmodImports = imps }) <>+            extra+      pure (modname, stringToStringBuffer contents)+    _ -> error  $ "parseHeader failed for " <> file++  ts <- liftIO $ getModificationTime file+  pure $ (modname, Target (TargetFile file (Just $ Hsc HsSrcFile)) False (Just (trimmed, ts)))++-- WORKAROUND https://gitlab.haskell.org/ghc/ghc/merge_requests/1541+minf_rdr_env' :: GHC.GhcMonad m => GHC.ModuleName -> m GlobalRdrEnv+minf_rdr_env' m = do+  modSum <- GHC.getModSummary m+  pmod <- GHC.parseModule modSum+  tmod <- GHC.typecheckModule pmod+  let (tc_gbl_env, _) = GHC.tm_internals_ tmod+  pure $ tcg_rdr_env tc_gbl_env