hsdev 0.3.2.0 → 0.3.2.1

raw patch · 5 files changed

+42/−26 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• hsdev.cabal +1/−1
• src/HsDev/Database/Update.hs +8/−4
• src/HsDev/Scan/Browse.hs +19/−16
• src/HsDev/Symbols/Location.hs +4/−4
• src/System/Directory/Paths.hs +10/−1

@@ -1,5 +1,5 @@ name:                hsdev-version:             0.3.2.0+version:             0.3.2.1 synopsis:            Haskell development library description:   Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc.

@@ -344,10 +344,12 @@ 			mlocs <- liftM 				(filter (`S.member` packageDbMods)) $ 				(inSessionGhc $ listModules opts pdbs packages')-			Log.sendLog Log.Trace $ "{} modules found" ~~ length mlocs 			let+				umlocs = uniqueModuleLocations mlocs+			Log.sendLog Log.Trace $ "{} modules found, {} unique" ~~ length mlocs ~~ length umlocs+			let 				packageDbMods' = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version and ps.package_db == ?;" (SQLite.Only (topPackageDb pdbs))-			scan packageDbMods' ((,,) <$> mlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do+			scan packageDbMods' ((,,) <$> umlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do 				ms <- inSessionGhc $ browseModules opts pdbs (mlocs' ^.. each . _1) 				Log.sendLog Log.Trace $ "scanned {} modules" ~~ length ms 				sendUpdateAction $ timer "updated package-db modules" $ do@@ -375,10 +377,12 @@ 			mlocs <- liftM 				(filter (`S.member` packageDbMods)) $ 				(inSessionGhc $ listModules opts pdbs packages')-			Log.sendLog Log.Trace $ "{} modules found" ~~ length mlocs 			let+				umlocs = uniqueModuleLocations mlocs+			Log.sendLog Log.Trace $ "{} modules found, {} unique" ~~ length mlocs ~~ length umlocs+			let 				packageDbStackMods = liftM concat $ forM (packageDbs pdbs) $ \pdb -> SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version and ps.package_db == ?;" (SQLite.Only pdb)-			scan packageDbStackMods ((,,) <$> mlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do+			scan packageDbStackMods ((,,) <$> umlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do 				ms <- inSessionGhc $ browseModules opts pdbs (mlocs' ^.. each . _1) 				Log.sendLog Log.Trace $ "scanned {} modules" ~~ length ms 				sendUpdateAction $ timer "updated package-db-stack modules" $ do

@@ -5,6 +5,7 @@ 	listModules, 	browseModules, browseModules', 	-- * Helpers+	uniqueModuleLocations, 	readPackage, readPackageConfig, ghcModuleLocation, 	packageConfigs, packageDbModules, lookupModule_, 	modulesPackages, modulesPackagesGroups, withEachPackage,@@ -32,8 +33,8 @@ import HsDev.Error import HsDev.Tools.Ghc.Worker (GhcM, tmpSession, formatType) import HsDev.Tools.Ghc.Compat as Compat-import HsDev.Util (ordNub)-import System.Directory.Paths (canonicalize)+import HsDev.Util (ordNub, uniqueBy)+import System.Directory.Paths (fromFilePath, normalize)  import qualified ConLike as GHC import qualified DataCon as GHC@@ -72,7 +73,7 @@ listModules opts dbs pkgs = do 	tmpSession dbs (opts ++ packagesOpts) 	ms <- packageDbModules-	sequence [ghcModuleLocation p m e | (p, m, e) <- ms]+	return $ ordNub [ghcModuleLocation p m e | (p, m, e) <- ms] 	where 		packagesOpts = ["-package " ++ show p | p <- pkgs] @@ -82,24 +83,20 @@ browseModules :: [String] -> PackageDbStack -> [ModuleLocation] -> GhcM [InspectedModule] browseModules opts dbs mlocs = do 	tmpSession dbs opts-	liftM concat . withEachPackage (const $ browseModules' opts) $ mlocs+	liftM concat . withEachPackage (const $ browseModules' opts) $ ordNub mlocs  -- | Inspect installed modules, doesn't set session and package flags! browseModules' :: [String] -> [ModuleLocation] -> GhcM [InspectedModule] browseModules' opts mlocs = do 	ms <- packageDbModules-	mlocsDb <- sequence [ghcModuleLocation p m e | (p, m, e) <- ms] 	midTbl <- newLookupTable 	sidTbl <- newLookupTable 	let-		lookupModuleId p' m' e' = do-			mloc' <- ghcModuleLocation p' m' e'-			modId' <- ghcModuleId p' m' e'-			lookupTable mloc' modId' midTbl-	liftM catMaybes $ sequence [browseModule' mloc lookupModuleId (cacheInTableM sidTbl) p m e | ((p, m, e), mloc) <- zip ms mlocsDb, mloc `S.member` mlocs']+		lookupModuleId p' m' e' = lookupTable (ghcModuleLocation p' m' e') (ghcModuleId p' m' e') midTbl+	liftM catMaybes $ sequence [browseModule' lookupModuleId (cacheInTableM sidTbl) p m e | (p, m, e) <- ms, ghcModuleLocation p m e `S.member` mlocs'] 	where-		browseModule' :: ModuleLocation -> (GHC.PackageConfig -> GHC.Module -> Bool -> GhcM ModuleId) -> (GHC.Name -> GhcM Symbol -> GhcM Symbol) -> GHC.PackageConfig -> GHC.Module -> Bool -> GhcM (Maybe InspectedModule)-		browseModule' mloc modId' sym' p m e = tryT $ runInspect mloc $ inspect_ (return $ InspectionAt 0 (map fromString opts)) (browseModule modId' sym' p m e)+		browseModule' :: (GHC.PackageConfig -> GHC.Module -> Bool -> GhcM ModuleId) -> (GHC.Name -> GhcM Symbol -> GhcM Symbol) -> GHC.PackageConfig -> GHC.Module -> Bool -> GhcM (Maybe InspectedModule)+		browseModule' modId' sym' p m e = tryT $ runInspect (ghcModuleLocation p m e) $ inspect_ (return $ InspectionAt 0 (map fromString opts)) (browseModule modId' sym' p m e) 		mlocs' = S.fromList mlocs  browseModule :: (GHC.PackageConfig -> GHC.Module -> Bool -> GhcM ModuleId) -> (GHC.Name -> GhcM Symbol -> GhcM Symbol) -> GHC.PackageConfig -> GHC.Module -> Bool -> GhcM Module@@ -170,6 +167,12 @@ tryT :: MonadCatch m => m a -> m (Maybe a) tryT act = catch (fmap Just act) (const (return Nothing) . (id :: SomeException -> SomeException)) +-- | There can be same modules (same package name, version and module name) installed in different locations+-- Select first one of such modules+uniqueModuleLocations :: [ModuleLocation] -> [ModuleLocation]+uniqueModuleLocations = uniqueBy nameId' where+	nameId' mloc = (,) <$> (preview modulePackage mloc) <*> (preview installedModuleName mloc)+ readPackage :: GHC.PackageConfig -> ModulePackage readPackage pc = ModulePackage (fromString $ GHC.packageNameString pc) (fromString $ showVersion (GHC.packageVersion pc)) @@ -179,11 +182,11 @@ 	(map (fromString . GHC.moduleNameString . Compat.exposedModuleName) $ GHC.exposedModules pc) 	(GHC.exposed pc) -ghcModuleLocation :: MonadIO m => GHC.PackageConfig -> GHC.Module -> Bool -> m ModuleLocation-ghcModuleLocation p m = liftIO . canonicalize . InstalledModule (map fromString $ GHC.libraryDirs p) (readPackage p) (fromString $ GHC.moduleNameString $ GHC.moduleName m)+ghcModuleLocation :: GHC.PackageConfig -> GHC.Module -> Bool -> ModuleLocation+ghcModuleLocation p m = InstalledModule (map (normalize . fromFilePath) $ GHC.libraryDirs p) (readPackage p) (fromString $ GHC.moduleNameString $ GHC.moduleName m) -ghcModuleId :: MonadIO m => GHC.PackageConfig -> GHC.Module -> Bool -> m ModuleId-ghcModuleId p m e = ModuleId (fromString mname') <$> (ghcModuleLocation p m e) where+ghcModuleId :: GHC.PackageConfig -> GHC.Module -> Bool -> ModuleId+ghcModuleId p m e = ModuleId (fromString mname') (ghcModuleLocation p m e) where 	mname' = GHC.moduleNameString $ GHC.moduleName m  packageConfigs :: GhcM [GHC.PackageConfig]

@@ -119,12 +119,12 @@ instance Ord ModuleLocation where 	compare l r = compare (locType l, locNames l) (locType r, locNames r) where 		locType :: ModuleLocation -> Int-		locType (FileModule _ _) = 0-		locType (InstalledModule _ _ _ _) = 1-		locType (OtherLocation _) = 2+		locType FileModule{} = 0+		locType InstalledModule{} = 1+		locType OtherLocation{} = 2 		locType NoLocation = 3 		locNames (FileModule f _) = [f]-		locNames (InstalledModule dirs _ nm _) = nm : dirs+		locNames (InstalledModule dirs _ nm _) = nm : dirs  -- dirs already includes name of package 		locNames (OtherLocation n) = [n] 		locNames NoLocation = [] 

@@ -8,7 +8,8 @@ 	Paths(..), 	canonicalize, 	absolutise,-	relativise+	relativise,+	normalize 	) where  import Control.Lens@@ -83,3 +84,11 @@ -- | Relativise paths relativise :: Paths a => Path -> a -> a relativise parent = over paths (makeRelative (parent ^. path))++-- | Normalize paths, with workaround for Windows drives+normalize :: Paths a => a -> a+normalize = over paths normalizePath' where+	normalizePath' :: FilePath -> FilePath+	normalizePath' = fixDrive . normalise+	fixDrive :: FilePath -> FilePath+	fixDrive = uncurry joinDrive . over _1 (addTrailingPathSeparator . dropWhileEnd isPathSeparator) . splitDrive