diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -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 diff --git a/hsinspect.cabal b/hsinspect.cabal --- a/hsinspect.cabal +++ b/hsinspect.cabal @@ -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 diff --git a/library/HsInspect/Imports.hs b/library/HsInspect/Imports.hs --- a/library/HsInspect/Imports.hs +++ b/library/HsInspect/Imports.hs @@ -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 diff --git a/library/HsInspect/Modules.hs b/library/HsInspect/Modules.hs new file mode 100644 --- /dev/null +++ b/library/HsInspect/Modules.hs @@ -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 diff --git a/library/HsInspect/Packages.hs b/library/HsInspect/Packages.hs new file mode 100644 --- /dev/null +++ b/library/HsInspect/Packages.hs @@ -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 + diff --git a/library/HsInspect/Plugin.hs b/library/HsInspect/Plugin.hs new file mode 100644 --- /dev/null +++ b/library/HsInspect/Plugin.hs @@ -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 ()) diff --git a/library/HsInspect/Search.hs b/library/HsInspect/Search.hs new file mode 100644 --- /dev/null +++ b/library/HsInspect/Search.hs @@ -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" diff --git a/library/HsInspect/Sexp.hs b/library/HsInspect/Sexp.hs --- a/library/HsInspect/Sexp.hs +++ b/library/HsInspect/Sexp.hs @@ -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 - diff --git a/library/HsInspect/Workarounds.hs b/library/HsInspect/Workarounds.hs new file mode 100644 --- /dev/null +++ b/library/HsInspect/Workarounds.hs @@ -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