leksah-0.1: src/IDE/Metainfo/Info.hs
{-# OPTIONS_GHC -fglasgow-exts #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Metainfo.Info
-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)
-- License : GNU-GPL
--
-- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>
-- Stability : experimental
-- Portability : portable
--
-- | This module provides the infos collected by the extractor before
-- and an info pane to present some of them to the user
--
---------------------------------------------------------------------------------
module IDE.Metainfo.Info (
InfoAction(..)
) where
import System.IO
import qualified Data.Map as Map
import Config
import Control.Monad
import Control.Monad.Trans
import System.FilePath
import System.Directory
import qualified Data.Map as Map
import System.IO
import Data.List
import qualified PackageConfig as DP
import Data.Maybe
import Data.Binary
import qualified Data.ByteString.Lazy as BS
import Distribution.Package
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import Data.ByteString.Char8 (ByteString)
import System.Process(ProcessHandle,getProcessExitCode)
import System.Glib.MainLoop(timeoutAddFull,priorityDefaultIdle)
import Control.Monad.Reader(runReaderT,ask)
import Distribution.Version
import IDE.Utils.DeepSeq
import IDE.Utils.File
import IDE.Core.State
import IDE.Metainfo.InterfaceCollector
class InfoAction alpha where
-- | Initialize metadata for the world
initInfo :: alpha
-- | Update world metadata
updateAccessibleInfo :: alpha
-- | Builds the current info for a package
-- Called when a package gets active or after a reconfigure
infoForActivePackage :: alpha
-- | Builds the current info for the activePackage in the background.
-- If a process handle is given, it waits for this process to finish before building
-- and only rebuilds if build was successful
-- Called after a build
mayRebuildInBackground :: Maybe ProcessHandle -> alpha
-- | Rebuild current info
rebuildActiveInfo :: alpha
instance InfoAction IDEAction where
initInfo = initInfo'
updateAccessibleInfo = updateAccessibleInfo'
infoForActivePackage = infoForActivePackage'
mayRebuildInBackground = mayRebuildInBackground'
rebuildActiveInfo = setInfo buildActiveInfo
--
-- | Update and initialize metadata for the world
--
initInfo' :: IDEAction
initInfo' = do
session' <- readIDE session
ideMessage Normal "Now updating metadata ..."
lift $ collectInstalled session' False
ideMessage Normal "Now loading metadata ..."
loadAccessibleInfo
ideMessage Normal "Finished loading ..."
--
-- | Load all infos for all installed and exposed packages
-- (see shell command: ghc-pkg list)
--
loadAccessibleInfo :: IDEAction
loadAccessibleInfo =
let version = cProjectVersion in do
session' <- readIDE session
collectorPath <- lift $ getCollectorPath version
packageInfos <- lift $ getInstalledPackageInfos session'
packageList <- lift $ mapM (loadInfosForPackage collectorPath)
(map (fromDPid . DP.package) packageInfos)
let scope = foldr buildScope (Map.empty,Map.empty)
$ map fromJust
$ filter isJust packageList
modifyIDE_ (\ide -> return (ide{accessibleInfo = (Just scope)}))
--
-- | Clears the current info, not the world infos
--
clearCurrentInfo :: IDEAction
clearCurrentInfo = do
modifyIDE_ (\ide -> return (ide{currentInfo = Nothing}))
ideR <- ask
triggerEvent ideR CurrentInfo
return ()
--
-- | Set info for package
--
infoForActivePackage' :: IDEAction
infoForActivePackage' = do
activePack <- readIDE activePack
case activePack of
Nothing -> do
modifyIDE_ (\ide -> return (ide{currentInfo = Nothing}))
Just pack -> do
let depends' = depends pack
session' <- readIDE session
fp <- lift $findFittingPackages session' depends'
mbActive <- loadOrBuildActiveInfo
case mbActive of
Nothing -> do
-- no meta info available
modifyIDE_ (\ide -> return (ide{currentInfo = Nothing}))
Just active -> do
accessibleInfo' <- readIDE accessibleInfo
case accessibleInfo' of
Nothing -> modifyIDE_ (\ide -> return (ide{currentInfo = Nothing}))
Just (pdmap,_) -> do
let packageList = map (\ pin -> pin `Map.lookup` pdmap) fp
let scope = foldr buildScope (Map.empty,Map.empty)
$ map fromJust
$ filter isJust packageList
modifyIDE_ (\ide -> return (ide{currentInfo = Just (active, scope)}))
ideR <- ask
triggerEvent ideR CurrentInfo
return ()
--
-- | Builds the current info for the activePackage in the background
-- If a process handle is given, it waits for this process to finish before building
--
mayRebuildInBackground' :: Maybe ProcessHandle -> IDEAction
mayRebuildInBackground' mbHandle = do
ideR <- ask
lift $ do
timeoutAddFull (myRebuild ideR) priorityDefaultIdle 500
return ()
where
myRebuild :: IDERef -> IO Bool
myRebuild ideR =
case mbHandle of
Just hdl -> do
mbExitCode <- getProcessExitCode hdl
case mbExitCode of
--process not finished, wait for next call
Nothing -> return True
Just _ -> doIt ideR
Nothing -> doIt ideR
doIt :: IDERef -> IO Bool
doIt ideR = do
runReaderT (do
errs <- readIDE errors
when (length (filter isError errs) == 0) $ do
ideMessage Normal "Update meta info for active package"
setInfo buildActiveInfo) ideR
return False
--
-- | Builds the current info for the activePackage
--
setInfo :: IDEM (Maybe PackageScope) -> IDEAction
setInfo f = do
currentInfo <- readIDE currentInfo
case currentInfo of
Nothing -> return ()
Just (active, scope) -> do
newActive <- f
case newActive of
Nothing -> return ()
Just newActive -> do
modifyIDE_ (\ide -> return (ide{currentInfo = Just (newActive, scope)}))
ideR <- ask
triggerEvent ideR CurrentInfo
return ()
--
-- | Loads the current info for the activePackage, or builds it if not available
--
loadOrBuildActiveInfo :: IDEM (Maybe PackageScope)
loadOrBuildActiveInfo = do
mbActiveInfo <- loadActiveInfo
case mbActiveInfo of
Just ai -> return (Just ai)
Nothing -> buildActiveInfo
--
-- | Loads the current info for the activePackage
--
loadActiveInfo :: IDEM (Maybe PackageScope)
loadActiveInfo =
let version = cProjectVersion in do
activePack <- readIDE activePack
session <- readIDE session
case activePack of
Nothing -> return Nothing
Just idePackage -> do
collectorPath <- lift $ getCollectorPath cProjectVersion
packageDescr <- lift $ loadInfosForPackage collectorPath
(packageId idePackage)
case packageDescr of
Nothing -> return Nothing
Just pd -> do
let scope = buildScope pd (Map.empty,Map.empty)
return (Just scope)
--
-- | Builds the current info for the activePackage
--
buildActiveInfo :: IDEM (Maybe PackageScope)
buildActiveInfo =
let version = cProjectVersion in do
activePack <- readIDE activePack
session <- readIDE session
case activePack of
Nothing -> return Nothing
Just idePackage -> do
lift $ collectUninstalled False session cProjectVersion (cabalFile idePackage)
-- ideMessage Normal "uninstalled collected"
collectorPath <- lift $ getCollectorPath cProjectVersion
packageDescr <- lift $ loadInfosForPackage collectorPath
(packageId idePackage)
case packageDescr of
Nothing -> return Nothing
Just pd -> do
let scope = buildScope pd (Map.empty,Map.empty)
return (Just scope)
--
-- | Updates the world info (it is the responsibility of the caller to rebuild
-- the current info)
--
updateAccessibleInfo' :: IDEAction
updateAccessibleInfo' = do
wi <- readIDE accessibleInfo
session <- readIDE session
let version = cProjectVersion
case wi of
Nothing -> loadAccessibleInfo
Just (psmap,psst) -> do
packageInfos <- lift $ getInstalledPackageInfos session
let packageIds = map (fromDPid . DP.package) packageInfos
let newPackages = filter (\ pi -> Map.member pi psmap) packageIds
let trashPackages = filter (\ e -> not (elem e packageIds))(Map.keys psmap)
if null newPackages && null trashPackages
then return ()
else do
collectorPath <- lift $ getCollectorPath version
newPackageInfos <- lift $ mapM (\pid -> loadInfosForPackage collectorPath pid)
newPackages
let psamp2 = foldr (\e m -> Map.insert (packagePD e) e m)
psmap
(map fromJust
$ filter isJust newPackageInfos)
let psamp3 = foldr (\e m -> Map.delete e m) psmap trashPackages
let scope = foldr buildScope (Map.empty,Map.empty)
(Map.elems psamp3)
modifyIDE_ (\ide -> return (ide{accessibleInfo = Just scope}))
--
-- | Loads the infos for the given packages
--
loadInfosForPackage :: FilePath -> PackageIdentifier -> IO (Maybe PackageDescr)
loadInfosForPackage dirPath pid = do
let filePath = dirPath </> showPackageId pid ++ ".pack"
exists <- doesFileExist filePath
if exists
then catch (do
file <- openBinaryFile filePath ReadMode
bs <- BS.hGetContents file
let packageInfo = decode bs
packageInfo `deepSeq` (hClose file)
return (Just packageInfo))
(\e -> do sysMessage Normal (show e); return Nothing)
else do
sysMessage Normal $"packageInfo not found for " ++ showPackageId pid
return Nothing
--
-- | Loads the infos for the given packages (has an collecting argument)
--
buildScope :: PackageDescr -> PackageScope -> PackageScope
buildScope packageD (packageMap, symbolTable) =
let pid = packagePD packageD
in if pid `Map.member` packageMap
then (packageMap, symbolTable)
else (Map.insert pid packageD packageMap,
buildSymbolTable packageD symbolTable)
buildSymbolTable :: PackageDescr -> SymbolTable -> SymbolTable
buildSymbolTable pDescr symbolTable =
foldl (\ st idDescr -> let allIds = identifierID idDescr : (allConstructorsID idDescr
++ allFieldsID idDescr ++ allClassOpsID idDescr)
in foldl (\ st2 id -> Map.insertWith (++) id [idDescr] st2) st allIds)
symbolTable (idDescriptionsPD pDescr)
-- ---------------------------------------------------------------------
-- DeepSeq instances for forcing evaluation
--
instance DeepSeq Location where
deepSeq pd = deepSeq (locationSLine pd)
$ deepSeq (locationSCol pd)
$ deepSeq (locationELine pd)
$ deepSeq (locationECol pd)
instance DeepSeq PackageDescr where
deepSeq pd = deepSeq (packagePD pd)
$ deepSeq (mbSourcePathPD pd)
$ deepSeq (exposedModulesPD pd)
$ deepSeq (buildDependsPD pd)
$ deepSeq (idDescriptionsPD pd)
instance DeepSeq ModuleDescr where
deepSeq pd = deepSeq (moduleIdMD pd)
$ deepSeq (mbSourcePathMD pd)
$ deepSeq (exportedNamesMD pd)
$ deepSeq (usagesMD pd)
instance DeepSeq IdentifierDescr where
deepSeq (SimpleDescr identifierID' identifierTypeID' typeInfoID' moduleIdID'
mbLocation' mbComment') = deepSeq identifierID'
$ deepSeq identifierTypeID'
$ deepSeq typeInfoID'
$ deepSeq moduleIdID'
$ deepSeq mbLocation'
$ deepSeq mbComment'
deepSeq (DataDescr identifierID' typeInfoID' moduleIdID' constructorsID' fieldsID'
mbLocation' mbComment') = deepSeq identifierID'
$ deepSeq typeInfoID'
$ deepSeq moduleIdID'
$ deepSeq constructorsID'
$ deepSeq fieldsID'
$ deepSeq mbLocation'
$ deepSeq mbComment'
deepSeq (ClassDescr identifierID' typeInfoID' classOpsID' moduleIdID'
mbLocation' mbComment') = deepSeq identifierID'
$ deepSeq typeInfoID'
$ deepSeq moduleIdID'
$ deepSeq classOpsID'
$ deepSeq mbLocation'
$ deepSeq mbComment'
deepSeq (InstanceDescr identifierID' classID' moduleIdID'
mbLocation' mbComment') = deepSeq identifierID'
$ deepSeq classID'
$ deepSeq moduleIdID'
$ deepSeq mbLocation'
$ deepSeq mbComment'
instance DeepSeq PackageIdentifier where
deepSeq pd = deepSeq (pkgName pd)
$ deepSeq (pkgVersion pd)
instance DeepSeq alpha => DeepSeq (Set alpha) where
deepSeq s = deepSeq (Set.elems s)
instance (DeepSeq alpha, DeepSeq beta) => DeepSeq (Map alpha beta) where
deepSeq s = deepSeq (Map.toList s)
instance DeepSeq IdType where deepSeq = seq
instance DeepSeq IdTypeS where deepSeq = seq
instance DeepSeq ByteString where deepSeq = seq
instance DeepSeq Version where deepSeq = seq
instance DeepSeq PackModule where
deepSeq pd = deepSeq (pack pd)
$ deepSeq (modu pd)