module IDE.Metainfo.Provider (
getIdentifierDescr
, getIdentifiersStartingWith
, getCompletionOptions
, getDescription
, getActivePackageDescr
, searchMeta
, initInfo
, updateSystemInfo
, rebuildSystemInfo
, updateWorkspaceInfo
, rebuildWorkspaceInfo
, getPackageInfo
, getWorkspaceInfo
, getSystemInfo
, getPackageImportInfo
) where
import System.IO (hClose, openBinaryFile, IOMode(..))
import System.IO.Strict (readFile)
import qualified Data.Map as Map
import Control.Monad
import System.FilePath
import System.Directory
import Data.List
import Data.Maybe
import Distribution.Package hiding (depends,packageId)
import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BSL
import Distribution.Version
import Distribution.ModuleName
import Control.DeepSeq
import IDE.Utils.FileUtils
import IDE.Core.State
import Data.Char (toLower,isUpper,toUpper,isLower)
import Text.Regex.TDFA
import qualified Text.Regex.TDFA as Regex
import System.IO.Unsafe (unsafePerformIO)
import Text.Regex.TDFA.Text (execute,compile)
import Data.Binary.Shared (decodeSer)
import Language.Haskell.Extension (KnownExtension)
import Distribution.Text (display)
import IDE.Core.Serializable ()
import Data.Map (Map(..))
import Control.Exception (SomeException(..), catch)
import Prelude hiding(catch, readFile)
import IDE.Utils.ServerConnection(doServerCommand)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Distribution.PackageDescription (hsSourceDirs)
import System.Log.Logger (infoM)
import Data.Text (Text)
import qualified Data.Text as T (null, isPrefixOf, unpack, pack)
import Data.Monoid ((<>))
import qualified Control.Arrow as A (Arrow(..))
import Data.Function (on)
initInfo :: IDEAction -> IDEAction
initInfo continuation = do
prefs <- readIDE prefs
if collectAtStart prefs
then do
ideMessage Normal "Now updating system metadata ..."
callCollector False True True $ \ _ -> do
ideMessage Normal "Now loading metadata ..."
loadSystemInfo
updateWorkspaceInfo' False $ \ _ -> do
void (triggerEventIDE (InfoChanged True))
liftIO $ infoM "leksah" "initInfo continuing"
continuation
else do
ideMessage Normal "Now loading metadata ..."
loadSystemInfo
updateWorkspaceInfo' False $ \ _ -> do
ideMessage Normal "Finished"
void (triggerEventIDE (InfoChanged True))
continuation
updateSystemInfo :: IDEAction
updateSystemInfo = do
liftIO $ infoM "leksah" "update sys info called"
updateSystemInfo' False $ \ _ ->
updateWorkspaceInfo' False $ \ _ -> void (triggerEventIDE (InfoChanged False))
rebuildSystemInfo :: IDEAction
rebuildSystemInfo = do
liftIO $ infoM "leksah" "rebuild sys info called"
updateSystemInfo' True $ \ _ ->
updateWorkspaceInfo' True $ \ _ ->
void (triggerEventIDE (InfoChanged False))
updateWorkspaceInfo :: IDEAction
updateWorkspaceInfo = do
liftIO $ infoM "leksah" "update workspace info called"
currentState' <- readIDE currentState
case currentState' of
IsStartingUp -> return ()
_ ->
updateWorkspaceInfo' False $ \ _ ->
void (triggerEventIDE (InfoChanged False))
rebuildWorkspaceInfo :: IDEAction
rebuildWorkspaceInfo = do
liftIO $ infoM "leksah" "rebuild workspace info called"
updateWorkspaceInfo' True $ \ _ ->
void (triggerEventIDE (InfoChanged False))
loadSystemInfo :: IDEAction
loadSystemInfo = do
collectorPath <- liftIO getCollectorPath
mbPackageIds <- liftIO getInstalledPackageIds'
case mbPackageIds of
Left e -> logMessage ("Please check that ghc-pkg is in your PATH and restart leksah:\n " <> e) ErrorTag
Right packageIds -> do
packageList <- liftIO $ mapM (loadInfosForPackage collectorPath)
(nub packageIds)
let scope = foldr buildScope (PackScope Map.empty getEmptyDefaultScope)
$ catMaybes packageList
modifyIDE_ (\ide -> ide{systemInfo = Just (GenScopeC (addOtherToScope scope False))})
return ()
updateSystemInfo' :: Bool -> (Bool -> IDEAction) -> IDEAction
updateSystemInfo' rebuild continuation = do
ideMessage Normal "Now updating system metadata ..."
wi <- getSystemInfo
case wi of
Nothing -> loadSystemInfo
Just (GenScopeC (PackScope psmap psst)) -> do
mbPackageIds <- liftIO getInstalledPackageIds'
case mbPackageIds of
Left e -> logMessage ("Please check that ghc-pkg is in your PATH and restart leksah:\n " <> e) ErrorTag
Right packageIds -> do
let newPackages = filter (`Map.member` psmap) packageIds
let trashPackages = filter (`notElem` packageIds) (Map.keys psmap)
if null newPackages && null trashPackages
then continuation True
else
callCollector rebuild True True $ \ _ -> do
collectorPath <- lift getCollectorPath
newPackageInfos <- liftIO $ mapM (loadInfosForPackage collectorPath)
newPackages
let psmap2 = foldr ((\ e m -> Map.insert (pdPackage e) e m) . fromJust) psmap
(filter isJust newPackageInfos)
let psmap3 = foldr Map.delete psmap2 trashPackages
let scope :: PackScope (Map Text [Descr])
= foldr buildScope (PackScope Map.empty symEmpty)
(Map.elems psmap3)
modifyIDE_ (\ide -> ide{systemInfo = Just (GenScopeC (addOtherToScope scope False))})
continuation True
ideMessage Normal "Finished updating system metadata"
getEmptyDefaultScope :: Map Text [Descr]
getEmptyDefaultScope = symEmpty
rebuildSystemInfo' :: (Bool -> IDEAction) -> IDEAction
rebuildSystemInfo' continuation =
callCollector True True True $ \ _ -> do
loadSystemInfo
continuation True
updateWorkspaceInfo' :: Bool -> (Bool -> IDEAction) -> IDEAction
updateWorkspaceInfo' rebuild continuation = do
postAsyncIDE $ ideMessage Normal "Now updating workspace metadata ..."
mbWorkspace <- readIDE workspace
systemInfo' <- getSystemInfo
case mbWorkspace of
Nothing -> do
liftIO $ infoM "leksah" "updateWorkspaceInfo' no workspace"
modifyIDE_ (\ide -> ide{workspaceInfo = Nothing, packageInfo = Nothing})
continuation False
Just ws ->
updatePackageInfos rebuild (wsAllPackages ws) $ \ _ packDescrs -> do
let dependPackIds = nub (concatMap pdBuildDepends packDescrs) \\
map pdPackage packDescrs
let packDescrsI = case systemInfo' of
Nothing -> []
Just (GenScopeC (PackScope pdmap _)) ->
mapMaybe (`Map.lookup` pdmap) dependPackIds
let scope1 :: PackScope (Map Text [Descr])
= foldr buildScope (PackScope Map.empty symEmpty) packDescrs
let scope2 :: PackScope (Map Text [Descr])
= foldr buildScope (PackScope Map.empty symEmpty) packDescrsI
modifyIDE_ (\ide -> ide{workspaceInfo = Just
(GenScopeC (addOtherToScope scope1 True), GenScopeC(addOtherToScope scope2 False))})
activePack <- readIDE activePack
case activePack of
Nothing -> modifyIDE_ (\ ide -> ide{packageInfo = Nothing})
Just pack ->
case filter (\pd -> pdPackage pd == ipdPackageId pack) packDescrs of
[pd] -> let impPackDescrs =
case systemInfo' of
Nothing -> []
Just (GenScopeC (PackScope pdmap _)) ->
mapMaybe (`Map.lookup` pdmap) (pdBuildDepends pd)
workspacePackageIds = map ipdPackageId (wsAllPackages ws)
impPackDescrs' = filter (\pd -> pdPackage pd `notElem` workspacePackageIds) impPackDescrs
impPackDescrs'' = mapMaybe
(\ pd -> if pdPackage pd `elem` workspacePackageIds
then find (\ pd' -> pdPackage pd == pdPackage pd') packDescrs
else Nothing)
impPackDescrs
scope1 :: PackScope (Map Text [Descr])
= buildScope pd (PackScope Map.empty symEmpty)
scope2 :: PackScope (Map Text [Descr])
= foldr buildScope (PackScope Map.empty symEmpty)
(impPackDescrs' ++ impPackDescrs'')
in modifyIDE_ (\ide -> ide{packageInfo = Just
(GenScopeC (addOtherToScope scope1 False),
GenScopeC(addOtherToScope scope2 False))})
_ -> modifyIDE_ (\ide -> ide{packageInfo = Nothing})
continuation True
postAsyncIDE $ ideMessage Normal "Finished updating workspace metadata"
updatePackageInfos :: Bool -> [IDEPackage] -> (Bool -> [PackageDescr] -> IDEAction) -> IDEAction
updatePackageInfos = updatePackageInfos' []
where
updatePackageInfos' collector _ [] continuation = continuation True collector
updatePackageInfos' collector rebuild (hd:tail) continuation =
updatePackageInfo rebuild hd $ \ _ packDescr ->
updatePackageInfos' (packDescr : collector) rebuild tail continuation
updatePackageInfo :: Bool -> IDEPackage -> (Bool -> PackageDescr -> IDEAction) -> IDEAction
updatePackageInfo rebuild idePack continuation = do
liftIO $ infoM "leksah" ("updatePackageInfo " ++ show rebuild ++ " " ++ show (ipdPackageId idePack))
workspInfoCache' <- readIDE workspInfoCache
let (packageMap, ic) = case pi `Map.lookup` workspInfoCache' of
Nothing -> (Map.empty,True)
Just m -> (m,False)
modPairsMb <- liftIO $ mapM (\(modName, bi) -> do
sf <- case modName `Map.lookup` packageMap of
Nothing -> findSourceFile (srcDirs' bi) haskellSrcExts modName
Just (_,Nothing,_) -> findSourceFile (srcDirs' bi) haskellSrcExts modName
Just (_,Just fp,_) -> return (Just fp)
return (modName, sf))
$ Map.toList $ ipdModules idePack
mainModules <- liftIO $ mapM (\(fn, bi, isTest) -> do
mbFn <- findSourceFile' (srcDirs' bi) fn
return (main,mbFn))
(ipdMain idePack)
let modPairsMb' = case mainModules of
[] -> modPairsMb
hd:_ -> hd : modPairsMb
let (modWith,modWithout) = partition (\(x,y) -> isJust y) modPairsMb'
let modWithSources = map (A.second fromJust) modWith
let modWithoutSources = map fst modWithout
modToUpdate <- if rebuild
then return modWithSources
else liftIO $ figureOutRealSources idePack modWithSources
liftIO . infoM "leksah" $ "updatePackageInfo modToUpdate " ++ show (map (display.fst) modToUpdate)
callCollectorWorkspace
rebuild
(dropFileName (ipdCabalFile idePack))
(ipdPackageId idePack)
(map (\(x,y) -> (T.pack $ display x,y)) modToUpdate)
(\ b -> do
buildDepends <- liftIO $ findFittingPackages (ipdDepends idePack)
collectorPath <- liftIO getCollectorPath
let packageCollectorPath = collectorPath </> T.unpack (packageIdentifierToString pi)
(moduleDescrs,packageMap, changed, modWithout)
<- liftIO $ foldM
(getModuleDescr packageCollectorPath)
([],packageMap,False,modWithoutSources)
modPairsMb'
when changed $ modifyIDE_ (\ide -> ide{workspInfoCache =
Map.insert pi packageMap workspInfoCache'})
continuation True PackageDescr {
pdPackage = pi,
pdMbSourcePath = Just $ ipdCabalFile idePack,
pdModules = moduleDescrs,
pdBuildDepends = buildDepends})
where
basePath = normalise $ takeDirectory (ipdCabalFile idePack)
srcDirs' bi = map (basePath </>) ("dist/build":hsSourceDirs bi)
pi = ipdPackageId idePack
figureOutRealSources :: IDEPackage -> [(ModuleName,FilePath)] -> IO [(ModuleName,FilePath)]
figureOutRealSources idePack modWithSources = do
collectorPath <- getCollectorPath
let packageCollectorPath = collectorPath </> T.unpack (packageIdentifierToString $ ipdPackageId idePack)
filterM (ff packageCollectorPath) modWithSources
where
ff packageCollectorPath (md ,fp) = do
let modId = display md
let collectorModulePath = packageCollectorPath </> modId <.> leksahMetadataWorkspaceFileExtension
existCollectorFile <- doesFileExist collectorModulePath
existSourceFile <- doesFileExist fp
if not existSourceFile || not existCollectorFile
then return True
else do
sourceModTime <- getModificationTime fp
collModTime <- getModificationTime collectorModulePath
return (sourceModTime > collModTime)
getModuleDescr :: FilePath
-> ([ModuleDescr],ModuleDescrCache,Bool,[ModuleName])
-> (ModuleName, Maybe FilePath)
-> IO ([ModuleDescr],ModuleDescrCache,Bool,[ModuleName])
getModuleDescr packageCollectorPath (modDescrs,packageMap,changed,problemMods) (modName,mbFilePath) =
case modName `Map.lookup` packageMap of
Just (eTime,mbFp,mdescr) -> do
existMetadataFile <- doesFileExist moduleCollectorPath
if existMetadataFile
then do
modificationTime <- liftIO $ getModificationTime moduleCollectorPath
if modificationTime == eTime
then return (mdescr:modDescrs,packageMap,changed,problemMods)
else do
liftIO . infoM "leksah" $ "getModuleDescr loadInfo: " ++ display modName
mbNewDescr <- loadInfosForModule moduleCollectorPath
case mbNewDescr of
Just newDescr -> return (newDescr:modDescrs,
Map.insert modName (modificationTime,mbFilePath,newDescr) packageMap,
True, problemMods)
Nothing -> return (mdescr:modDescrs,packageMap,changed,
modName : problemMods)
else return (mdescr:modDescrs,packageMap,changed, modName : problemMods)
Nothing -> do
existMetadataFile <- doesFileExist moduleCollectorPath
if existMetadataFile
then do
modificationTime <- liftIO $ getModificationTime moduleCollectorPath
mbNewDescr <- loadInfosForModule moduleCollectorPath
case mbNewDescr of
Just newDescr -> return (newDescr:modDescrs,
Map.insert modName (modificationTime,mbFilePath,newDescr) packageMap,
True, problemMods)
Nothing -> return (modDescrs,packageMap,changed,
modName : problemMods)
else return (modDescrs,packageMap,changed, modName : problemMods)
where
moduleCollectorPath = packageCollectorPath </> display modName <.> leksahMetadataWorkspaceFileExtension
loadInfosForPackage :: FilePath -> PackageIdentifier -> IO (Maybe PackageDescr)
loadInfosForPackage dirPath pid = do
let filePath = dirPath </> T.unpack (packageIdentifierToString pid) ++ leksahMetadataSystemFileExtension
let filePath2 = dirPath </> T.unpack (packageIdentifierToString pid) ++ leksahMetadataPathFileExtension
exists <- doesFileExist filePath
if exists
then catch (do
file <- openBinaryFile filePath ReadMode
liftIO . infoM "leksah" . T.unpack $ "now loading metadata for package " <> packageIdentifierToString pid
bs <- BSL.hGetContents file
let (metadataVersion'::Integer, packageInfo::PackageDescr) = decodeSer bs
if metadataVersion /= metadataVersion'
then do
hClose file
throwIDE ("Metadata has a wrong version."
<> " Consider rebuilding metadata with: leksah-server -osb +RTS -N2 -RTS")
else do
packageInfo `deepseq` hClose file
exists' <- doesFileExist filePath2
sourcePath <- if exists'
then liftM Just (readFile filePath2)
else return Nothing
let packageInfo' = injectSourceInPack sourcePath packageInfo
return (Just packageInfo'))
(\ (e :: SomeException) -> do
sysMessage Normal
("loadInfosForPackage: " <> packageIdentifierToString pid <> " Exception: " <> T.pack (show e))
return Nothing)
else do
sysMessage Normal $"packageInfo not found for " <> packageIdentifierToString pid
return Nothing
injectSourceInPack :: Maybe FilePath -> PackageDescr -> PackageDescr
injectSourceInPack Nothing pd = pd{
pdMbSourcePath = Nothing,
pdModules = map (injectSourceInMod Nothing) (pdModules pd)}
injectSourceInPack (Just pp) pd = pd{
pdMbSourcePath = Just pp,
pdModules = map (injectSourceInMod (Just (dropFileName pp))) (pdModules pd)}
injectSourceInMod :: Maybe FilePath -> ModuleDescr -> ModuleDescr
injectSourceInMod Nothing md = md{mdMbSourcePath = Nothing}
injectSourceInMod (Just bp) md =
case mdMbSourcePath md of
Just sp -> md{mdMbSourcePath = Just (bp </> sp)}
Nothing -> md
loadInfosForModule :: FilePath -> IO (Maybe ModuleDescr)
loadInfosForModule filePath = do
exists <- doesFileExist filePath
if exists
then catch (do
file <- openBinaryFile filePath ReadMode
bs <- BSL.hGetContents file
let (metadataVersion'::Integer, moduleInfo::ModuleDescr) = decodeSer bs
if metadataVersion /= metadataVersion'
then do
hClose file
throwIDE ("Metadata has a wrong version."
<> " Consider rebuilding metadata with -r option")
else do
moduleInfo `deepseq` hClose file
return (Just moduleInfo))
(\ (e :: SomeException) -> do sysMessage Normal (T.pack $ "loadInfosForModule: " ++ show e); return Nothing)
else do
sysMessage Normal $ "moduleInfo not found for " <> T.pack filePath
return Nothing
findFittingPackages :: [Dependency] -> IO [PackageIdentifier]
findFittingPackages dependencyList = do
knownPackages <- getInstalledPackageIds
return (concatMap (fittingKnown knownPackages) dependencyList)
where
fittingKnown packages (Dependency dname versionRange) =
let filtered = filter (\ (PackageIdentifier name version) ->
name == dname && withinRange version versionRange)
packages
in if length filtered > 1
then [maximumBy (compare `on` pkgVersion) filtered]
else filtered
getActivePackageDescr :: IDEM (Maybe PackageDescr)
getActivePackageDescr = do
mbActive <- readIDE activePack
case mbActive of
Nothing -> return Nothing
Just pack -> do
packageInfo' <- getPackageInfo
case packageInfo' of
Nothing -> return Nothing
Just (GenScopeC (PackScope map _), GenScopeC (PackScope _ _)) ->
return (ipdPackageId pack `Map.lookup` map)
getIdentifierDescr :: (SymbolTable alpha, SymbolTable beta) => Text -> alpha -> beta -> [Descr]
getIdentifierDescr str st1 st2 =
let r1 = str `symLookup` st1
r2 = str `symLookup` st2
in r1 ++ r2
getIdentifiersStartingWith :: (SymbolTable alpha , SymbolTable beta) => Text -> alpha -> beta -> [Text]
getIdentifiersStartingWith prefix st1 st2 =
takeWhile (T.isPrefixOf prefix) $
if memberLocal || memberGlobal then
prefix : Set.toAscList names
else
Set.toAscList names
where
(_, memberLocal, localNames) = Set.splitMember prefix (symbols st1)
(_, memberGlobal, globalNames) = Set.splitMember prefix (symbols st2)
names = Set.union globalNames localNames
getCompletionOptions :: Text -> IDEM [Text]
getCompletionOptions prefix = do
workspaceInfo' <- getWorkspaceInfo
case workspaceInfo' of
Nothing -> return []
Just (GenScopeC (PackScope _ symbolTable1), GenScopeC (PackScope _ symbolTable2)) ->
return $ getIdentifiersStartingWith prefix symbolTable1 symbolTable2
getDescription :: Text -> IDEM Text
getDescription name = do
workspaceInfo' <- getWorkspaceInfo
case workspaceInfo' of
Nothing -> return ""
Just (GenScopeC (PackScope _ symbolTable1), GenScopeC (PackScope _ symbolTable2)) ->
return $ T.pack (foldr (\d f -> shows (Present d) . showChar '\n' . f) id
(getIdentifierDescr name symbolTable1 symbolTable2) "")
getPackageInfo :: IDEM (Maybe (GenScope, GenScope))
getPackageInfo = readIDE packageInfo
getWorkspaceInfo :: IDEM (Maybe (GenScope, GenScope))
getWorkspaceInfo = readIDE workspaceInfo
getSystemInfo :: IDEM (Maybe GenScope)
getSystemInfo = readIDE systemInfo
getPackageImportInfo :: IDEPackage -> IDEM (Maybe (GenScope,GenScope))
getPackageImportInfo idePack = do
mbActivePack <- readIDE activePack
systemInfo' <- getSystemInfo
if isJust mbActivePack && ipdPackageId (fromJust mbActivePack) == ipdPackageId idePack
then do
packageInfo' <- getPackageInfo
case packageInfo' of
Nothing -> do
liftIO $ infoM "leksah" "getPackageImportInfo: no package info"
return Nothing
Just (GenScopeC (PackScope pdmap _), _) ->
case Map.lookup (ipdPackageId idePack) pdmap of
Nothing -> do
liftIO $ infoM "leksah" "getPackageImportInfo: package not found in package"
return Nothing
Just pd -> buildIt pd systemInfo'
else do
workspaceInfo <- getWorkspaceInfo
case workspaceInfo of
Nothing -> do
liftIO $ infoM "leksah" "getPackageImportInfo: no workspace info"
return Nothing
Just (GenScopeC (PackScope pdmap _), _) ->
case Map.lookup (ipdPackageId idePack) pdmap of
Nothing -> do
liftIO $ infoM "leksah" "getPackageImportInfo: package not found in workspace"
return Nothing
Just pd -> buildIt pd systemInfo'
where
filterPrivate :: ModuleDescr -> ModuleDescr
filterPrivate md = md{mdIdDescriptions = filter dscExported (mdIdDescriptions md)}
buildIt pd systemInfo' =
case systemInfo' of
Nothing -> do
liftIO $ infoM "leksah" "getPackageImportInfo: no system info"
return Nothing
Just (GenScopeC (PackScope pdmap' _)) ->
let impPackDescrs = mapMaybe (`Map.lookup` pdmap') (pdBuildDepends pd)
pd' = pd{pdModules = map filterPrivate (pdModules pd)}
scope1 :: PackScope (Map Text [Descr])
= buildScope pd (PackScope Map.empty symEmpty)
scope2 :: PackScope (Map Text [Descr])
= foldr buildScope (PackScope Map.empty symEmpty) impPackDescrs
in return (Just (GenScopeC scope1, GenScopeC scope2))
searchMeta :: Scope -> Text -> SearchMode -> IDEM [Descr]
searchMeta _ "" _ = return []
searchMeta (PackageScope False) searchString searchType = do
packageInfo' <- getPackageInfo
case packageInfo' of
Nothing -> return []
Just (GenScopeC (PackScope _ rl), _) -> return (searchInScope searchType searchString rl)
searchMeta (PackageScope True) searchString searchType = do
packageInfo' <- getPackageInfo
case packageInfo' of
Nothing -> return []
Just (GenScopeC (PackScope _ rl), GenScopeC (PackScope _ rr)) ->
return (searchInScope searchType searchString rl
++ searchInScope searchType searchString rr)
searchMeta (WorkspaceScope False) searchString searchType = do
workspaceInfo' <- getWorkspaceInfo
case workspaceInfo' of
Nothing -> return []
Just (GenScopeC (PackScope _ rl), _) -> return (searchInScope searchType searchString rl)
searchMeta (WorkspaceScope True) searchString searchType = do
workspaceInfo' <- getWorkspaceInfo
case workspaceInfo' of
Nothing -> return []
Just (GenScopeC (PackScope _ rl), GenScopeC (PackScope _ rr)) ->
return (searchInScope searchType searchString rl
++ searchInScope searchType searchString rr)
searchMeta SystemScope searchString searchType = do
systemInfo' <- getSystemInfo
packageInfo' <- getPackageInfo
case systemInfo' of
Nothing ->
case packageInfo' of
Nothing -> return []
Just (GenScopeC (PackScope _ rl), _) ->
return (searchInScope searchType searchString rl)
Just (GenScopeC (PackScope _ s)) ->
case packageInfo' of
Nothing -> return (searchInScope searchType searchString s)
Just (GenScopeC (PackScope _ rl), _) -> return (searchInScope searchType searchString rl
++ searchInScope searchType searchString s)
searchInScope :: SymbolTable alpha => SearchMode -> Text -> alpha -> [Descr]
searchInScope (Exact _) l st = searchInScopeExact l st
searchInScope (Prefix True) l st = (concat . symElems) (searchInScopePrefix l st)
searchInScope (Prefix False) l _ | T.null l = []
searchInScope (Prefix False) l st = (concat . symElems) (searchInScopeCaseIns l st "")
searchInScope (Regex b) l st = searchRegex l st b
searchInScopeExact :: SymbolTable alpha => Text -> alpha -> [Descr]
searchInScopeExact = symLookup
searchInScopePrefix :: SymbolTable alpha => Text -> alpha -> alpha
searchInScopePrefix searchString symbolTable =
let (_, exact, mapR) = symSplitLookup searchString symbolTable
(mbL, _, _) = symSplitLookup (searchString <> "{") mapR
in case exact of
Nothing -> mbL
Just e -> symInsert searchString e mbL
searchInScopeCaseIns :: SymbolTable alpha => Text -> alpha -> Text -> alpha
searchInScopeCaseIns a symbolTable b = searchInScopeCaseIns' (T.unpack a) symbolTable (T.unpack b)
where
searchInScopeCaseIns' [] st _ = st
searchInScopeCaseIns' (a:l) st pre | isLower a =
let s1 = pre ++ [a]
s2 = pre ++ [toUpper a]
in symUnion (searchInScopeCaseIns' l (searchInScopePrefix (T.pack s1) st) s1)
(searchInScopeCaseIns' l (searchInScopePrefix (T.pack s2) st) s2)
| isUpper a =
let s1 = pre ++ [a]
s2 = pre ++ [toLower a]
in symUnion (searchInScopeCaseIns' l (searchInScopePrefix (T.pack s1) st) s1)
(searchInScopeCaseIns' l (searchInScopePrefix (T.pack s2) st) s2)
| otherwise =
let s = pre ++ [a]
in searchInScopeCaseIns' l (searchInScopePrefix (T.pack s) st) s
searchRegex :: SymbolTable alpha => Text -> alpha -> Bool -> [Descr]
searchRegex searchString st caseSense =
case compileRegex caseSense searchString of
Left err ->
unsafePerformIO $ sysMessage Normal (T.pack $ show err) >> return []
Right regex ->
filter (\e ->
case execute regex (dscName e) of
Left e -> False
Right Nothing -> False
_ -> True)
(concat (symElems st))
compileRegex :: Bool -> Text -> Either String Regex
compileRegex caseSense searchString =
let compOption = defaultCompOpt {
Regex.caseSensitive = caseSense
, multiline = True } in
compile compOption defaultExecOpt searchString
buildScope :: SymbolTable alpha => PackageDescr -> PackScope alpha -> PackScope alpha
buildScope packageD (PackScope packageMap symbolTable) =
let pid = pdPackage packageD
in if pid `Map.member` packageMap
then PackScope packageMap symbolTable
else PackScope (Map.insert pid packageD packageMap)
(buildSymbolTable packageD symbolTable)
buildSymbolTable :: SymbolTable alpha => PackageDescr -> alpha -> alpha
buildSymbolTable pDescr symbolTable =
foldl' buildScope'
symbolTable allDescriptions
where
allDescriptions = concatMap mdIdDescriptions (pdModules pDescr)
buildScope' st idDescr =
let allDescrs = allDescrsFrom idDescr
in foldl' (\ map descr -> symInsert (dscName descr) [descr] map)
st allDescrs
allDescrsFrom descr | isReexported descr = [descr]
| otherwise =
case dscTypeHint descr of
DataDescr constructors fields ->
descr : map (\(SimpleDescr fn ty loc comm exp) ->
Real RealDescr{dscName' = fn, dscMbTypeStr' = ty,
dscMbModu' = dscMbModu descr, dscMbLocation' = loc,
dscMbComment' = comm, dscTypeHint' = FieldDescr descr, dscExported' = exp})
fields
++ map (\(SimpleDescr fn ty loc comm exp) ->
Real RealDescr{dscName' = fn, dscMbTypeStr' = ty,
dscMbModu' = dscMbModu descr, dscMbLocation' = loc,
dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr, dscExported' = exp})
constructors
ClassDescr _ methods ->
descr : map (\(SimpleDescr fn ty loc comm exp) ->
Real RealDescr{dscName' = fn, dscMbTypeStr' = ty,
dscMbModu' = dscMbModu descr, dscMbLocation' = loc,
dscMbComment' = comm, dscTypeHint' = MethodDescr descr, dscExported' = exp})
methods
NewtypeDescr (SimpleDescr fn ty loc comm exp) mbField ->
descr : Real RealDescr{dscName' = fn, dscMbTypeStr' = ty,
dscMbModu' = dscMbModu descr, dscMbLocation' = loc,
dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr, dscExported' = exp}
: case mbField of
Just (SimpleDescr fn ty loc comm exp) ->
[Real RealDescr{dscName' = fn, dscMbTypeStr' = ty,
dscMbModu' = dscMbModu descr, dscMbLocation' = loc,
dscMbComment' = comm, dscTypeHint' = FieldDescr descr, dscExported' = exp}]
Nothing -> []
InstanceDescr _ -> []
_ -> [descr]
callCollector :: Bool -> Bool -> Bool -> (Bool -> IDEAction) -> IDEAction
callCollector rebuild sources extract cont = do
liftIO $ infoM "leksah" "callCollector"
doServerCommand command $ \ res ->
case res of
ServerOK -> do
liftIO $ infoM "leksah" "callCollector finished"
cont True
ServerFailed str -> do
liftIO $ infoM "leksah" (T.unpack str)
cont False
_ -> do
liftIO $ infoM "leksah" "impossible server answer"
cont False
where command = SystemCommand {
scRebuild = rebuild,
scSources = sources,
scExtract = extract}
callCollectorWorkspace :: Bool -> FilePath -> PackageIdentifier -> [(Text,FilePath)] ->
(Bool -> IDEAction) -> IDEAction
callCollectorWorkspace rebuild fp pi modList cont = do
liftIO $ infoM "leksah" "callCollectorWorkspace"
if null modList
then do
liftIO $ infoM "leksah" "callCollectorWorkspace: Nothing to do"
cont True
else
doServerCommand command $ \ res ->
case res of
ServerOK -> do
liftIO $ infoM "leksah" "callCollectorWorkspace finished"
cont True
ServerFailed str -> do
liftIO $ infoM "leksah" (T.unpack str)
cont False
_ -> do
liftIO $ infoM "leksah" "impossible server answer"
cont False
where command = WorkspaceCommand {
wcRebuild = rebuild,
wcPackage = pi,
wcPath = fp,
wcModList = modList}
keywords :: [Text]
keywords = [
"as"
, "case"
, "of"
, "class"
, "data"
, "default"
, "deriving"
, "do"
, "forall"
, "foreign"
, "hiding"
, "if"
, "then"
, "else"
, "import"
, "infix"
, "infixl"
, "infixr"
, "instance"
, "let"
, "in"
, "mdo"
, "module"
, "newtype"
, "qualified"
, "type"
, "where"]
keywordDescrs :: [Descr]
keywordDescrs = map (\s -> Real $ RealDescr
s
Nothing
Nothing
Nothing
(Just (BS.pack " Haskell keyword"))
KeywordDescr
True) keywords
extensionDescrs :: [Descr]
extensionDescrs = map (\ext -> Real $ RealDescr
(T.pack $ "X" ++ show ext)
Nothing
Nothing
Nothing
(Just (BS.pack " Haskell language extension"))
ExtensionDescr
True)
([minBound..maxBound]::[KnownExtension])
moduleNameDescrs :: PackageDescr -> [Descr]
moduleNameDescrs pd = map (\md -> Real $ RealDescr
(T.pack . display . modu $ mdModuleId md)
Nothing
(Just (mdModuleId md))
Nothing
(Just (BS.pack " Module name"))
ModNameDescr
True) (pdModules pd)
addOtherToScope :: SymbolTable alpha => PackScope alpha -> Bool -> PackScope alpha
addOtherToScope (PackScope packageMap symbolTable) addAll = PackScope packageMap newSymbolTable
where newSymbolTable = foldl' (\ map descr -> symInsert (dscName descr) [descr] map)
symbolTable (if addAll
then keywordDescrs ++ extensionDescrs ++ modNameDescrs
else modNameDescrs)
modNameDescrs = concatMap moduleNameDescrs (Map.elems packageMap)