module HsDev.Scan.Browse (
browsePackages, browsePackagesDeps,
listModules, browseModules, browse, browseDb,
withPackages, withPackages_,
readPackage, readPackageConfig, ghcPackageDb, ghcModuleLocation,
packageDbCandidate, packageDbCandidate_,
packageConfigs, packageDbModules, lookupModule_,
module Control.Monad.Except
) where
import Control.Arrow
import Control.Lens (view, preview, _Just)
import Control.Monad.Except
import Data.List (isPrefixOf)
import Data.Maybe
import Data.String (fromString)
import Data.Version
import System.Directory
import System.FilePath
import Data.Deps
import HsDev.PackageDb
import HsDev.Symbols
import HsDev.Tools.Base (inspect)
import HsDev.Util (liftIOErrors, ordNub)
import qualified ConLike as GHC
import qualified DataCon as GHC
import qualified DynFlags as GHC
import qualified GHC
import qualified GHC.PackageDb as GHC
import qualified GhcMonad as GHC (liftIO)
import qualified GHC.Paths as GHC
import qualified Name as GHC
import qualified Outputable as GHC
import qualified Packages as GHC
import qualified PatSyn as GHC
import qualified TyCon as GHC
import qualified Type as GHC
import qualified Var as GHC
import Pretty
browsePackages :: [String] -> PackageDbStack -> ExceptT String IO [PackageConfig]
browsePackages opts dbs = liftIOErrors $ withPackages_ (packageDbStackOpts dbs ++ opts) $
liftM (map readPackageConfig) $ lift packageConfigs
browsePackagesDeps :: [String] -> PackageDbStack -> ExceptT String IO (Deps PackageConfig)
browsePackagesDeps opts dbs = liftIOErrors $ withPackages (packageDbStackOpts dbs ++ opts) $ \df -> do
cfgs <- lift packageConfigs
return $ mapDeps (toPkg df) $ mconcat $ map (uncurry deps) $
map (GHC.installedPackageId &&& GHC.depends) cfgs
where
toPkg df' = readPackageConfig . GHC.getPackageDetails df' . GHC.resolveInstalledPackageId df'
listModules :: [String] -> PackageDbStack -> ExceptT String IO [ModuleLocation]
listModules opts dbs = liftIOErrors $ withPackages_ (packageDbStackOpts dbs ++ opts) $ do
ms <- lift packageDbModules
pdbs <- mapM (liftIO . ghcPackageDb . fst) ms
return [ghcModuleLocation pdb p m | (pdb, (p, m)) <- zip pdbs ms]
browseModules :: [String] -> PackageDbStack -> [ModuleLocation] -> ExceptT String IO [InspectedModule]
browseModules opts dbs mlocs = liftIOErrors $ withPackages_ (packageDbStackOpts dbs ++ opts) $ do
ms <- lift packageDbModules
pdbs <- mapM (liftIO . ghcPackageDb . fst) ms
liftM catMaybes $ sequence [browseModule' pdb p m | (pdb, (p, m)) <- zip pdbs ms, ghcModuleLocation pdb p m `elem` mlocs]
where
browseModule' :: PackageDb -> GHC.PackageConfig -> GHC.Module -> ExceptT String GHC.Ghc (Maybe InspectedModule)
browseModule' pdb p m = tryT $ inspect (ghcModuleLocation pdb p m) (return $ InspectionAt 0 opts) (browseModule pdb p m)
browse :: [String] -> PackageDbStack -> ExceptT String IO [InspectedModule]
browse opts dbs = listModules opts dbs >>= browseModules opts dbs
browseDb :: [String] -> PackageDbStack -> ExceptT String IO [InspectedModule]
browseDb opts dbs = listModules opts dbs >>= browseModules opts dbs . filter inTop where
inTop = (== Just (topPackageDb dbs)) . preview modulePackageDb
browseModule :: PackageDb -> GHC.PackageConfig -> GHC.Module -> ExceptT String GHC.Ghc Module
browseModule pdb package' m = do
mi <- lift (GHC.getModuleInfo m) >>= maybe (throwError "Can't find module info") return
ds <- mapM (toDecl mi) (GHC.modInfoExports mi)
let
thisModule = GHC.moduleNameString (GHC.moduleName m)
return Module {
_moduleName = fromString thisModule,
_moduleDocs = Nothing,
_moduleLocation = thisLoc,
_moduleExports = Just [ExportName Nothing (view declarationName d) ThingNothing | d <- ds],
_moduleImports = [import_ iname | iname <- ordNub (mapMaybe (preview definedModule) ds), iname /= fromString thisModule],
_moduleDeclarations = sortDeclarations ds }
where
thisLoc = view moduleIdLocation $ mloc m
mloc m' = ModuleId (fromString mname') $
ghcModuleLocation pdb package' m'
where
mname' = GHC.moduleNameString $ GHC.moduleName m'
toDecl minfo n = do
tyInfo <- lift $ GHC.modInfoLookupName minfo n
tyResult <- lift $ maybe (inModuleSource n) (return . Just) tyInfo
dflag <- lift GHC.getSessionDynFlags
let
decl' = decl (fromString $ GHC.getOccString n) $ fromMaybe
(Function Nothing [] Nothing)
(tyResult >>= showResult dflag)
return $ decl' `definedIn` mloc (GHC.nameModule n)
definedModule = declarationDefined . _Just . moduleIdName
showResult :: GHC.DynFlags -> GHC.TyThing -> Maybe DeclarationInfo
showResult dflags (GHC.AnId i) = Just $ Function (Just $ fromString $ formatType dflags GHC.varType i) [] Nothing
showResult dflags (GHC.AConLike c) = case c of
GHC.RealDataCon d -> Just $ Function (Just $ fromString $ formatType dflags GHC.dataConRepType d) [] Nothing
GHC.PatSynCon p -> Just $ Function (Just $ fromString $ formatType dflags GHC.patSynType p) [] Nothing
showResult _ (GHC.ATyCon t) = Just $ tcon $ TypeInfo Nothing (map (fromString . GHC.getOccString) $ GHC.tyConTyVars t) Nothing [] where
tcon
| GHC.isAlgTyCon t && not (GHC.isNewTyCon t) && not (GHC.isClassTyCon t) = Data
| GHC.isNewTyCon t = NewType
| GHC.isClassTyCon t = Class
| GHC.isTypeSynonymTyCon t = Type
| otherwise = Type
showResult _ _ = Nothing
withInitializedPackages :: [String] -> (GHC.DynFlags -> GHC.Ghc a) -> IO a
withInitializedPackages ghcOpts cont = GHC.runGhc (Just GHC.libdir) $ do
fs <- GHC.getSessionDynFlags
GHC.defaultCleanupHandler fs $ do
(fs', _, _) <- GHC.parseDynamicFlags fs (map GHC.noLoc ghcOpts)
_ <- GHC.setSessionDynFlags fs'
(result, _) <- GHC.liftIO $ GHC.initPackages fs'
cont result
withPackages :: [String] -> (GHC.DynFlags -> ExceptT String GHC.Ghc a) -> ExceptT String IO a
withPackages ghcOpts cont = ExceptT $ withInitializedPackages ghcOpts (runExceptT . cont)
withPackages_ :: [String] -> ExceptT String GHC.Ghc a -> ExceptT String IO a
withPackages_ ghcOpts act = withPackages ghcOpts (const act)
inModuleSource :: GHC.Name -> GHC.Ghc (Maybe GHC.TyThing)
inModuleSource nm = GHC.getModuleInfo (GHC.nameModule nm) >> GHC.lookupGlobalName nm
formatType :: GHC.NamedThing a => GHC.DynFlags -> (a -> GHC.Type) -> a -> String
formatType dflag f x = showOutputable dflag (removeForAlls $ f x)
removeForAlls :: GHC.Type -> GHC.Type
removeForAlls ty = removeForAlls' ty' tty' where
ty' = GHC.dropForAlls ty
tty' = GHC.splitFunTy_maybe ty'
removeForAlls' :: GHC.Type -> Maybe (GHC.Type, GHC.Type) -> GHC.Type
removeForAlls' ty Nothing = ty
removeForAlls' ty (Just (pre, ftype))
| GHC.isPredTy pre = GHC.mkFunTy pre (GHC.dropForAlls ftype)
| otherwise = ty
showOutputable :: GHC.Outputable a => GHC.DynFlags -> a -> String
showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . GHC.ppr
showUnqualifiedPage :: GHC.DynFlags -> GHC.SDoc -> String
showUnqualifiedPage dflag = Pretty.showDoc Pretty.LeftMode 0 . GHC.withPprStyleDoc dflag styleUnqualified
styleUnqualified :: GHC.PprStyle
styleUnqualified = GHC.mkUserStyle GHC.neverQualify GHC.AllTheWay
tryT :: Monad m => ExceptT e m a -> ExceptT e m (Maybe a)
tryT act = catchError (liftM Just act) (const $ return Nothing)
readPackage :: GHC.PackageConfig -> ModulePackage
readPackage pc = ModulePackage (GHC.packageNameString pc) (showVersion (GHC.packageVersion pc))
readPackageConfig :: GHC.PackageConfig -> PackageConfig
readPackageConfig pc = PackageConfig
(readPackage pc)
(map (fromString . GHC.moduleNameString . GHC.exposedName) $ GHC.exposedModules pc)
(GHC.exposed pc)
ghcModuleLocation :: PackageDb -> GHC.PackageConfig -> GHC.Module -> ModuleLocation
ghcModuleLocation pdb p m = InstalledModule pdb (Just $ readPackage p) (GHC.moduleNameString $ GHC.moduleName m)
ghcPackageDb :: GHC.PackageConfig -> IO PackageDb
ghcPackageDb = maybe (return GlobalDb) packageDbCandidate_ . listToMaybe . GHC.libraryDirs
packageDbCandidate :: FilePath -> IO (Maybe PackageDb)
packageDbCandidate fpath = liftM Just (msum [global', user', sandbox', stack']) `mplus` return Nothing where
global' = do
guard (takeFileName (takeDirectory fpath') == "lib")
guardExist (takeDirectory fpath' </> "package.conf.d")
return GlobalDb
user' = do
cabalDir <- getAppUserDataDirectory "cabal"
guard (splitDirectories cabalDir `isPrefixOf` splitDirectories fpath')
return UserDb
sandbox' = do
guard (".cabal-sandbox" `elem` splitDirectories fpath')
let
sandboxPath = joinPath $ reverse $ dropWhile (/= ".cabal-sandbox") $ reverse $ splitDirectories fpath'
platform = takeFileName (takeDirectory fpath')
dbPath = sandboxPath </> (platform ++ "-packages.conf.d")
guardExist dbPath
return $ PackageDb dbPath
stack' = do
guard (takeFileName (takeDirectory (takeDirectory fpath')) == "lib")
let
pkgDb = takeDirectory (takeDirectory $ takeDirectory fpath') </> "pkgdb"
guardExist pkgDb
return $ PackageDb pkgDb
guardExist = doesDirectoryExist >=> guard
fpath' = normalise fpath
packageDbCandidate_ :: FilePath -> IO PackageDb
packageDbCandidate_ = packageDbCandidate >=> maybe (return GlobalDb) return
packageConfigs :: GHC.GhcMonad m => m [GHC.PackageConfig]
packageConfigs = liftM (fromMaybe [] . GHC.pkgDatabase) GHC.getSessionDynFlags
packageDbModules :: GHC.GhcMonad m => m [(GHC.PackageConfig, GHC.Module)]
packageDbModules = do
pkgs <- packageConfigs
dflags <- GHC.getSessionDynFlags
return [(p, m) |
p <- pkgs,
mn <- map GHC.exposedName (GHC.exposedModules p),
m <- lookupModule_ dflags mn]
lookupModule_ :: GHC.DynFlags -> GHC.ModuleName -> [GHC.Module]
lookupModule_ d mn = case GHC.lookupModuleWithSuggestions d mn Nothing of
GHC.LookupFound m' _ -> [m']
GHC.LookupMultiple ms -> map fst ms
GHC.LookupHidden ls rs -> map fst $ ls ++ rs
GHC.LookupNotFound _ -> []