diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,22 +1,21 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} - module Main where +import qualified Config as GHC import Control.Monad import Control.Monad.IO.Class import Data.Char (isUpper) import Data.List (find, isPrefixOf) import DynFlags (parseDynamicFlagsCmdLine, updOptLevel) +import qualified EnumSet as EnumSet import qualified GHC as GHC import HsInspect.Imports import HsInspect.Index +import HsInspect.Json import HsInspect.Packages import HsInspect.Sexp as S -import Json -import Outputable (defaultUserStyle, initSDocContext, runSDoc) import System.Environment (getArgs) import System.Exit @@ -29,7 +28,7 @@ help :: String help = - "hsinspect command ARGS [--json|help|version] -- [ghcflags]\n\n" ++ + "hsinspect command ARGS [--json|help|version|ghc-version] -- [ghcflags]\n\n" ++ " `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" ++ @@ -48,25 +47,29 @@ (putStrLn help) >> exitWith ExitSuccess when (elem "--version" args) $ (putStrLn version) >> exitWith ExitSuccess + when (elem "--ghc-version" args) $ + (putStrLn GHC.cProjectVersion) >> exitWith ExitSuccess let libdir = (drop 2) <$> find ("-B" `isPrefixOf`) flags + flags' = filter (not . ("-B" `isPrefixOf`)) flags GHC.runGhc libdir $ do dflags <- GHC.getSessionDynFlags (updOptLevel 0 -> dflags', (GHC.unLoc <$>) -> ghcargs, _) <- - liftIO $ parseDynamicFlagsCmdLine dflags (GHC.noLoc <$> flags) + liftIO $ parseDynamicFlagsCmdLine dflags (GHC.noLoc <$> flags') void $ GHC.setSessionDynFlags dflags' { 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 + , GHC.warningFlags = EnumSet.empty + , GHC.fatalWarningFlags = EnumSet.empty } - 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 $ + let mkTarget m = GHC.Target (GHC.TargetModule $ GHC.mkModuleName m) True Nothing + GHC.setTargets $ mkTarget <$> filter (isUpper . head) ghcargs + let respond rest (S.filterNil . S.toSexp -> a) = liftIO . putStrLn $ if (elem "--json" rest) - then encodeJson dflags' as - else S.encode as + then case sexpToJson a of + Left err -> error err + Right j -> encodeJson dflags' j + else S.render a case args of "imports" : file : rest -> do quals <- imports file @@ -74,21 +77,16 @@ "index" : rest -> do hits <- index respond rest hits - "packages" : dir : rest -> do - hits <- packages dir + "packages" : rest -> do + hits <- packages respond rest hits _ -> liftIO $ error "invalid parameters" --- TODO let each component remove things that interfere +-- removes the "+RTS ... -RTS" sections 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 +filterFlags args = case span ("+RTS" /=) args of + (front, []) -> front + (front, _ : middle) -> case span ("-RTS" /=) middle of + (_, []) -> front -- bad input? + (_, _ : back) -> front <> back 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.7 +version: 0.0.8 synopsis: Inspect Haskell source files. license: GPL-3.0-or-later license-file: LICENSE @@ -8,7 +8,7 @@ maintainer: Tseen She copyright: 2019 Tseen She bug-reports: https://gitlab.com/tseenshe/hsinspect/merge_requests -tested-with: GHC ^>=8.4.4 || ^>=8.6.5 +tested-with: GHC ^>=8.4.4 || ^>=8.6.5 || ^>=8.8.1 category: Building description: Inspect @.hs@ files using the ghc api. @@ -44,7 +44,7 @@ hs-source-dirs: exe build-depends: hsinspect main-is: Main.hs - ghc-options: -threaded + ghc-options: -rtsopts -threaded -with-rtsopts=-N8 library import: deps @@ -54,6 +54,7 @@ exposed-modules: HsInspect.Imports HsInspect.Index + HsInspect.Json HsInspect.Packages HsInspect.Sexp HsInspect.Util diff --git a/library/HsInspect/Imports.hs b/library/HsInspect/Imports.hs --- a/library/HsInspect/Imports.hs +++ b/library/HsInspect/Imports.hs @@ -11,37 +11,28 @@ import Data.Maybe (fromJust) import DynFlags (unsafeGlobalDynFlags) import qualified GHC as GHC +import HscTypes (TargetId(..)) import HsInspect.Sexp import HsInspect.Workarounds -import HscTypes (TargetId (..)) -import Json import Outputable (Outputable, showPpr) -import RdrName - ( GlobalRdrElt (..), - ImpDeclSpec (..), - ImportSpec (..), - globalRdrEnvElts, - ) +import RdrName (GlobalRdrElt(..), ImpDeclSpec(..), ImportSpec(..), + globalRdrEnvElts) imports :: GHC.GhcMonad m => FilePath -> m [Qualified] imports file = do - gres <- imports' file - pure $ describe =<< gres - -imports' :: GHC.GhcMonad m => FilePath -> m [GlobalRdrElt] -imports' file = do - -- 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. + -- 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. _ <- GHC.load $ GHC.LoadUpTo m rdr_env <- minf_rdr_env' m - pure $ globalRdrEnvElts rdr_env + pure $ describe =<< globalRdrEnvElts rdr_env showGhc :: (Outputable a) => a -> String showGhc = showPpr unsafeGlobalDynFlags @@ -61,10 +52,6 @@ fqn = showGhc is_mod ++ "." ++ showGhc gre_name in Qualified ln lqn fqn --- Note that `nameSrcLoc gre_name` is empty --- TODO unitid (can be used to lookup source code) --- TODO "and originally defined" / ppr_defn_site - -- 1. local name -- 2. locally qualified name -- 3. fully qualified name @@ -82,14 +69,3 @@ ("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 diff --git a/library/HsInspect/Index.hs b/library/HsInspect/Index.hs --- a/library/HsInspect/Index.hs +++ b/library/HsInspect/Index.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -- | Dumps an index of all terms and their types @@ -9,99 +10,192 @@ ) where -import Avail (AvailInfo (..)) -import BinIface - ( CheckHiWay (..), - TraceBinIFaceReading (..), - readBinIface, - ) +import Avail (AvailInfo(..)) +import BinIface (CheckHiWay(..), TraceBinIFaceReading(..), readBinIface) +import qualified ConLike as GHC import Control.Monad import Control.Monad.IO.Class -import Data.List (isSuffixOf) -import Data.Maybe (catMaybes, maybeToList) +import Data.Maybe (catMaybes, mapMaybe, maybeToList) import Data.Set (Set) import qualified Data.Set as Set +import qualified DataCon as GHC +import qualified DynFlags as GHC import qualified GHC import GHC.PackageDb +import qualified GHC.PackageDb as GHC +import HscTypes (ModIface(..)) +import HsInspect.Json () import HsInspect.Sexp import HsInspect.Util -import HscTypes (ModIface (..)) import qualified Id as GHC -import Json -import Module (Module (..), moduleNameString, unitIdString) +import Module (Module(..), moduleNameString) +import qualified Name as GHC import Outputable (showPpr) +import qualified Outputable as GHC import PackageConfig ---import System.IO (hPutStrLn, stderr) -import PackageConfig (packageConfigId) +import qualified PackageConfig as GHC import Packages (explicitPackages, lookupPackage) +--import System.IO (hPutStrLn, stderr) import TcEnv (tcLookup) import TcRnMonad (initTcInteractive) import qualified TcRnTypes as GHC +import qualified TyCon as GHC index :: GHC.GhcMonad m => m [PackageEntries] index = do - -- TODO the home package dflags <- GHC.getSessionDynFlags + let explicit = explicitPackages $ GHC.pkgState dflags pkgcfgs = maybeToList . lookupPackage dflags =<< explicit - traverse getSymbols pkgcfgs + deps <- traverse getPkgSymbols pkgcfgs --- TODO Maybe haddock-html --- TODO Maybe source definition (or should we leave source resolution to downstream?) -getSymbols :: GHC.GhcMonad m => PackageConfig -> m PackageEntries -getSymbols pkg = do - let findHis dir = filter (".hi" `isSuffixOf`) <$> liftIO (walk dir) - exposed = Set.fromList $ fst <$> exposedModules pkg - unitid = packageConfigId pkg - his <- join <$> traverse findHis (importDirs pkg) - PackageEntries unitid . catMaybes <$> traverse (hiToSymbols exposed) his + loadCompiledModules + let unitid = GHC.thisPackage dflags + dirs = maybeToList $ GHC.hiDir dflags + home_mods <- getTargetModules + home_entries <- getSymbols unitid [] home_mods dirs -hiToSymbols :: GHC.GhcMonad m => Set GHC.ModuleName -> FilePath -> m (Maybe ModuleEntries) -hiToSymbols exposed hi = do - env <- GHC.getSession + pure $ home_entries : deps + +-- finds the module names of all the .hi files in the output directory and then +-- tells ghc to load them as the only targets. Compared to loading all the home +-- modules provided by the ghcflags, this means that ghc can only see the +-- contents of compiled files and will not attempt to compile any source code. +-- Obviously comes with caveats but will be much faster if the preferred +-- behaviour is to fail fast with partial data instead of trying (futilely) to +-- compile all home modules with the interactive compiler. +loadCompiledModules :: GHC.GhcMonad m => m () +loadCompiledModules = do dflags <- GHC.getSessionDynFlags - (_, hits) <- - -- TODO use initTc instead of initTcInteractive - liftIO . initTcInteractive env $ do - iface <- readBinIface IgnoreHiWay QuietBinIFaceReading hi - let m = mi_module iface - modName = moduleName m - if not $ Set.member (GHC.moduleName m) exposed - then pure Nothing - else do - let thing (Avail name) = traverse tcLookup [name] - -- TODO the fields in AvailTC - thing (AvailTC name members _) = traverse tcLookup (name : members) + case GHC.hiDir dflags of + Nothing -> pure () + Just dir -> do + compiled <- getCompiledTargets dir + GHC.setTargets compiled + void . GHC.load $ GHC.LoadAllTargets - things <- join <$> traverse thing (mi_exports iface) +getCompiledTargets :: GHC.GhcMonad m => FilePath -> m [GHC.Target] +getCompiledTargets dir = do + provided <- getTargetModules + his <- liftIO $ walkSuffix ".hi" dir + modules <- catMaybes <$> traverse (flip withHi (pure . mi_module)) his + let toTarget m = + if Set.member m provided + then Just $ GHC.Target (GHC.TargetModule m) True Nothing + else Nothing + pure $ mapMaybe (toTarget . moduleName) modules - -- TODO refactor this code to return the Module and TcTyThing and - -- do the conversion to Entry in the caller. - pure . Just . ModuleEntries modName . catMaybes $ (tyrender dflags) <$> things - pure $ join hits +-- 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 + pure res -tyrender :: GHC.DynFlags -> GHC.TcTyThing -> Maybe Entry -tyrender dflags (GHC.AGlobal (GHC.AnId var)) = - Just - $ Entry (showPpr dflags $ GHC.idName var) - (showPpr dflags $ GHC.idType var) --- TODO investigate what we're skipping -tyrender _ _ = Nothing +getPkgSymbols :: GHC.GhcMonad m => PackageConfig -> m PackageEntries +getPkgSymbols pkg = + let unitid = GHC.packageConfigId pkg + exposed = Set.fromList $ fst <$> exposedModules pkg + dirs = (importDirs pkg) + haddocks = GHC.haddockHTMLs pkg + in if Set.null exposed || null dirs + then pure $ PackageEntries unitid [] haddocks + else getSymbols unitid haddocks exposed dirs --- TODO normalise the type string to make it easier for downstream tools to perform searches --- TODO note if this is the original definition point (vs a re-export) -data Entry = Entry String String +getSymbols :: GHC.GhcMonad m => GHC.UnitId -> [FilePath] -> Set GHC.ModuleName -> [FilePath] -> m PackageEntries +getSymbols unitid haddocks exposed dirs = do + let findHis dir = liftIO $ walkSuffix ".hi" dir + his <- join <$> traverse findHis dirs + dflags <- GHC.getSessionDynFlags + symbols <- catMaybes <$> traverse (hiToSymbols exposed) his + let entries = uncurry mkEntries <$> symbols + mkEntries m things = ModuleEntries (moduleName m) (renderThings things) + renderThings things = catMaybes $ (uncurry $ tyrender dflags) <$> things + pure $ PackageEntries unitid entries 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 + :: GHC.GhcMonad m + => Set GHC.ModuleName + -> FilePath + -> m (Maybe (GHC.Module, [(Maybe GHC.Module, GHC.TcTyThing)])) +hiToSymbols exposed hi = (join <$>) <$> withHi hi $ \iface -> do + let m = mi_module iface + if not $ Set.member (GHC.moduleName m) exposed + then pure Nothing + else do + let thing (Avail name) = traverse tcLookup' [name] + -- TODO the fields in AvailTC + thing (AvailTC _ members _) = traverse tcLookup' members + reexport name = do + modl <- GHC.nameModule_maybe name + if m == modl then Nothing else Just modl + tcLookup' name = (reexport name,) <$> tcLookup name + things <- join <$> traverse thing (mi_exports iface) + pure . Just $ (m, things) + +tyrender :: GHC.DynFlags -> Maybe GHC.Module -> GHC.TcTyThing -> Maybe Entry +tyrender dflags ((Mod <$>) -> m) (GHC.AGlobal thing) = + let + shw :: GHC.Outputable m => m -> String + shw = showPpr dflags + in case thing of + (GHC.AnId var) -> Just $ IdEntry m + (shw $ GHC.idName var) + (shw $ GHC.idType var) -- TODO fully qualify + (GHC.AConLike (GHC.RealDataCon dc)) -> Just $ ConEntry m + (shw $ GHC.getName dc) + (shw $ GHC.dataConUserType dc) -- TODO fully qualify + -- TODO PatSynCon + (GHC.ATyCon tc) -> Just $ TyConEntry m + (shw $ GHC.tyConName tc) + (shw $ GHC.tyConFlavour tc) + _ -> Nothing +tyrender _ _ _ = Nothing + +data Entry = IdEntry (Maybe Mod) String String -- ^ name type + | ConEntry (Maybe Mod) String String -- ^ name type + | TyConEntry (Maybe Mod) String String -- ^ type flavour + data ModuleEntries = ModuleEntries GHC.ModuleName [Entry] -data PackageEntries = PackageEntries GHC.UnitId [ModuleEntries] +-- The haddocks serve a dual purpose: not only do they point to where haddocks +-- might be, they give a hint to the text editor where the sources for this +-- package are (e.g. with the ghc distribution, build tool store or local). +-- +-- Users should type `cabal haddock --enable-documentation` to populate the docs +-- of their dependencies and local projects. +type Haddocks = [FilePath] +data PackageEntries = PackageEntries GHC.UnitId [ModuleEntries] Haddocks + +newtype Mod = Mod GHC.Module + +instance ToSexp Mod where + toSexp (Mod m) = alist + [ ("unitid", SexpString . normaliseUnitId . moduleUnitId $ m), + ("module", SexpString . moduleNameString . moduleName $ m) ] + instance ToSexp Entry where - toSexp (Entry term typ) = - alist - [ ("name", SexpString term), - ("type", SexpString typ) - ] + toSexp (IdEntry m name typ) = alist + [ ("name", SexpString name), + ("type", SexpString typ), + ("class", "id"), + ("export", toSexp m)] + toSexp (ConEntry m name typ) = alist + [ ("name", SexpString name), + ("type", SexpString typ), + ("class", "con"), + ("export", toSexp m) ] + toSexp (TyConEntry m typ flavour) = alist + [ ("type", SexpString typ), + ("class", "tycon"), + ("flavour", SexpString flavour), + ("export", toSexp m) ] instance ToSexp ModuleEntries where toSexp (ModuleEntries modl entries) = @@ -111,29 +205,8 @@ ] instance ToSexp PackageEntries where - toSexp (PackageEntries pkg modules) = + toSexp (PackageEntries unitid modules haddocks) = alist - [ ("unitid", SexpString . unitIdString $ pkg), - ("modules", toSexp modules) - ] - -instance ToJson Entry where - json (Entry term typ) = - JSObject - [ ("name", JSString term), - ("type", JSString typ) - ] - -instance ToJson ModuleEntries where - json (ModuleEntries modl entries) = - JSObject - [ ("module", JSString . moduleNameString $ modl), - ("ids", JSArray $ json <$> entries) - ] - -instance ToJson PackageEntries where - json (PackageEntries pkg modules) = - JSObject - [ ("unitid", JSString . unitIdString $ pkg), - ("modules", JSArray $ json <$> modules) - ] + [ ("unitid", SexpString . normaliseUnitId $ unitid), + ("modules", toSexp modules), + ("haddocks", toSexp haddocks) ] diff --git a/library/HsInspect/Json.hs b/library/HsInspect/Json.hs new file mode 100644 --- /dev/null +++ b/library/HsInspect/Json.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE ViewPatterns #-} + +module HsInspect.Json where + +import qualified GHC as GHC +import HsInspect.Sexp +import Json +import MonadUtils (mapSndM) +import Outputable (defaultUserStyle, initSDocContext, runSDoc) + +encodeJson :: GHC.DynFlags -> JsonDoc -> String +encodeJson dflags j = show . flip runSDoc ctx . renderJSON $ j + where ctx = initSDocContext dflags $ defaultUserStyle dflags + +sexpToJson :: Sexp -> Either String JsonDoc +sexpToJson SexpNil = Right JSNull +sexpToJson (toAList -> Just kvs) = JSObject <$> mapSndM sexpToJson kvs +sexpToJson (toList -> Just as) = JSArray <$> traverse sexpToJson as +sexpToJson (SexpCons _ _) = Left $ "cons cell has no JSON equivalent" +sexpToJson (SexpString s) = Right $ JSString s +sexpToJson (SexpSymbol s) = Right $ JSString s -- nobody said it had to roundtrip diff --git a/library/HsInspect/Packages.hs b/library/HsInspect/Packages.hs --- a/library/HsInspect/Packages.hs +++ b/library/HsInspect/Packages.hs @@ -1,16 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} module HsInspect.Packages (packages, PkgSummary) where -import BasicTypes (StringLiteral(..)) import Control.Monad (join, void) import Control.Monad.IO.Class (liftIO) -import Data.List (isSuffixOf, nub, sort, (\\)) +import Data.List (delete, nub, sort, (\\)) import Data.Maybe (catMaybes) import qualified Data.Set as Set +import qualified DynFlags as GHC import FastString import Finder (findImportedModule) import qualified GHC @@ -18,28 +17,15 @@ import HsInspect.Sexp import HsInspect.Util import HsInspect.Workarounds -import Json -import Module (Module(..), ModuleName, moduleNameString, unitIdString) +import Module (Module(..), ModuleName) import Packages (PackageState(..)) +import qualified RdrName as GHC -- Similar to packunused / weeder, but more reliable (and doesn't require a -- separate -ddump-minimal-imports pass). --- --- TODO get the dirs from the dynflags not the user -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 +packages :: GHC.GhcMonad m => m PkgSummary +packages = do + mods <- Set.toList <$> getTargetModules dflags <- GHC.getSessionDynFlags void $ GHC.setSessionDynFlags dflags { GHC.ghcMode = GHC.CompManager } @@ -47,15 +33,11 @@ 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 + let home = GHC.thisPackage dflags + used = delete home . nub . sort $ pkgs + 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 @@ -66,21 +48,14 @@ 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 + rdr_env <- minf_rdr_env' m + let imports = GHC.gre_imp =<< GHC.globalRdrEnvElts rdr_env + pure $ 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 +-- 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.UnitId] [GHC.UnitId] deriving (Eq, Ord) @@ -89,10 +64,4 @@ 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 + where toS ids = toSexp $ normaliseUnitId <$> ids diff --git a/library/HsInspect/Sexp.hs b/library/HsInspect/Sexp.hs --- a/library/HsInspect/Sexp.hs +++ b/library/HsInspect/Sexp.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} +-- | Very minimal ADT for outputting some S-Expressions. module HsInspect.Sexp where import Data.List (intercalate) @@ -31,14 +32,17 @@ where mkEl (k, v) = [SexpCons k v] -attrs :: [(String, Sexp)] -> Sexp -attrs els = list $ mkEl =<< els - where - mkEl (k, v) = [SexpSymbol k, v] +toAList :: Sexp -> Maybe [(String, Sexp)] +toAList SexpNil = Just [] +toAList (SexpCons (SexpCons (SexpSymbol k) v) rest) = ((k, v) :) <$> toAList rest +toAList _ = Nothing class ToSexp a where toSexp :: a -> Sexp +instance ToSexp Sexp where + toSexp = id + instance ToSexp String where toSexp s = SexpString s @@ -49,12 +53,16 @@ toSexp (Just a) = toSexp a toSexp Nothing = SexpNil +filterNil :: Sexp -> Sexp +filterNil SexpNil = SexpNil +filterNil (SexpCons (SexpCons (SexpSymbol _) SexpNil) rest) = filterNil rest +filterNil (SexpCons car cdr) = (SexpCons (filterNil car) (filterNil cdr)) +filterNil (SexpString s) = SexpString s +filterNil (SexpSymbol s) = SexpSymbol s + render :: Sexp -> String render SexpNil = "nil" 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 - -encode :: ToSexp a => a -> String -encode = render . toSexp diff --git a/library/HsInspect/Util.hs b/library/HsInspect/Util.hs --- a/library/HsInspect/Util.hs +++ b/library/HsInspect/Util.hs @@ -1,7 +1,41 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} + module HsInspect.Util where +import Data.List (intercalate) +import Data.List (isSuffixOf) +import Data.Maybe (catMaybes) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified GHC as GHC +import qualified Module as GHC import System.Directory (doesDirectoryExist, listDirectory) +-- removes the cabal nix-style hashcode +normaliseUnitId :: GHC.UnitId -> String +normaliseUnitId (GHC.unitIdString -> unitid) = + case reverse $ split ('-' ==) unitid of + "inplace" : _ -> unitid + _ : version : pkg -> + if any ('.' ==) version + then intercalate "-" (pkg <> [version]) + else unitid -- versioned but without a hashcode + _ -> unitid -- unversioned, e.g. base + +getTargetModules :: GHC.GhcMonad m => m (Set GHC.ModuleName) +getTargetModules = do + args <- GHC.getTargets + pure . Set.fromList . catMaybes $ getModule <$> args + where + getModule :: GHC.Target -> Maybe GHC.ModuleName + getModule GHC.Target{GHC.targetId} = case targetId of + GHC.TargetModule m -> Just m + GHC.TargetFile _ _ -> Nothing + +walkSuffix :: String -> FilePath -> IO [FilePath] +walkSuffix suffix dir = filter (suffix `isSuffixOf`) <$> walk dir + walk :: FilePath -> IO [FilePath] walk dir = do isDir <- doesDirectoryExist dir @@ -24,3 +58,10 @@ else do xs' <- xs pure $ x' ++ xs' + +-- from extra +split :: (a -> Bool) -> [a] -> [[a]] +split _ [] = [[]] +split f (x : xs) | f x = [] : split f xs + | y : ys <- split f xs = (x : y) : ys + | otherwise = [[]] -- never happens diff --git a/library/HsInspect/Workarounds.hs b/library/HsInspect/Workarounds.hs --- a/library/HsInspect/Workarounds.hs +++ b/library/HsInspect/Workarounds.hs @@ -26,11 +26,22 @@ import System.Directory (getModificationTime, removeFile) import TcRnTypes (tcg_rdr_env) +-- TODO avoid this codepath in 8.8.2+ -- 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 + -- NOTE: the behaviour of preprocess changed in 8.8.1 and it no longer reads + -- and sets LANGUAGE pragamas from in header of the file. Since this function + -- is no longer needed in 8.8.2 we don't bother fixing this. +#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) + pp <- liftIO $ preprocess sess file Nothing Nothing + let (dflags, tmp) = case pp of + Left _ -> error $ "preprocessing failed " <> show file + Right success -> success +#else (dflags, tmp) <- liftIO $ preprocess sess (file, Nothing) +#endif full <- liftIO $ hGetStringBuffer tmp when (".hscpp" `isSuffixOf` tmp) $ liftIO . removeFile $ tmp @@ -46,7 +57,7 @@ let modname = unLoc <$> GHC.hsmodName hsmod extra = if modname == Nothing || modname == (Just $ GHC.mkModuleName "Main") - then "\nmain = return ()" -- TODO check that return is imported + then "\nmain = return ()" else "" imps = filter allowed $ GHC.hsmodImports hsmod -- WORKAROUND https://gitlab.haskell.org/ghc/ghc/issues/17066