From 49e80b8371c9bd4facd9385512389e03a916ce29 Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Thu, 5 Jan 2017 15:20:30 +0100 Subject: [PATCH 01/10] Upgraded to Cabal 1.24 --- sandfix.cabal | 2 +- src/SandFix.hs | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/sandfix.cabal b/sandfix.cabal index 3224e8b..205d060 100644 --- a/sandfix.cabal +++ b/sandfix.cabal @@ -21,7 +21,7 @@ executable sandfix -- other-modules: -- other-extensions: build-depends: base < 5 - , Cabal >=1.18 && < 1.23 + , Cabal >= 1.24 , containers == 0.5.* , directory == 1.2.* hs-source-dirs: src/ diff --git a/src/SandFix.hs b/src/SandFix.hs index b554c86..a0267c4 100644 --- a/src/SandFix.hs +++ b/src/SandFix.hs @@ -34,7 +34,7 @@ getReadPackageDB = do type Fix = Either String -packageIdFromInstalledPackageId (InstalledPackageId str) = case simpleParse $ take (length str - 33) str of +packageIdFromInstalledPackageId (SimpleUnitId (ComponentId str)) = case simpleParse $ take (length str - 33) str of Nothing -> Left $ "Failed to parse installed package id " ++ str Just pid -> return pid @@ -48,10 +48,10 @@ fixPackageIndex globalPkgIndices sandboxRPT brokenPackageIndex -- 1. Fix dependencies dependencies <- forM (I.depends info) $ \ipkgid -> do pkgid <- packageIdFromInstalledPackageId ipkgid - case lookupInstalledPackageId brokenPackageIndex ipkgid `mplus` + case lookupUnitId brokenPackageIndex ipkgid `mplus` (listToMaybe $ concatMap ((flip lookupSourcePackageId) pkgid) globalPkgIndices) of - Just fInfo -> return . Right $ I.installedPackageId fInfo + Just fInfo -> return . Right $ I.installedUnitId fInfo Nothing -> return . Left $ pkgid let fixedDependencies = rights dependencies @@ -148,7 +148,7 @@ main = do putStrLn "done" putStr "Overwriting broken package DB(s)... " forM_ (zip brokenDBPaths fixedPackageDBs) $ \(path, db) -> forM_ (allPackages db) $ \info -> do - let filename = path <> "/" <> display (I.installedPackageId info) <> ".conf" + let filename = path <> "/" <> display (I.installedUnitId info) <> ".conf" writeFile filename $ I.showInstalledPackageInfo info putStrLn "done" putStrLn "Please run 'cabal sandbox hc-pkg recache' in the sandbox to update the package cache" From 7e15e995d14c89c6a81262b2f1e1ed0e00481981 Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Thu, 5 Jan 2017 16:28:33 +0100 Subject: [PATCH 02/10] Fixed Cabal 1.24 port --- src/SandFix.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/SandFix.hs b/src/SandFix.hs index a0267c4..4657097 100644 --- a/src/SandFix.hs +++ b/src/SandFix.hs @@ -34,9 +34,7 @@ getReadPackageDB = do type Fix = Either String -packageIdFromInstalledPackageId (SimpleUnitId (ComponentId str)) = case simpleParse $ take (length str - 33) str of - Nothing -> Left $ "Failed to parse installed package id " ++ str - Just pid -> return pid +packageIdFromInstalledPackageId (SimpleUnitId (ComponentId pid)) = pid fixPackageIndex globalPkgIndices sandboxRPT brokenPackageIndex = fromPackageIdsPackageInfoPairs . unzip <$> mapM fixInstalledPackage (allPackages brokenPackageIndex) From 9d5ef4e6953eef928e8df7a9ff43449debebfe5f Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Thu, 5 Jan 2017 16:34:52 +0100 Subject: [PATCH 03/10] I'm stupid --- src/SandFix.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/SandFix.hs b/src/SandFix.hs index 4657097..9396ec3 100644 --- a/src/SandFix.hs +++ b/src/SandFix.hs @@ -34,7 +34,9 @@ getReadPackageDB = do type Fix = Either String -packageIdFromInstalledPackageId (SimpleUnitId (ComponentId pid)) = pid +packageIdFromInstalledPackageId (SimpleUnitId (ComponentId pid)) = case simpleParse pid of + Nothing -> Left $ "Failed to parse installed package id " ++ pid + Just pid -> return pid fixPackageIndex globalPkgIndices sandboxRPT brokenPackageIndex = fromPackageIdsPackageInfoPairs . unzip <$> mapM fixInstalledPackage (allPackages brokenPackageIndex) From 726a40888a8bc0d40c1ff189903de221ca1e8ad7 Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Thu, 5 Jan 2017 17:20:43 +0100 Subject: [PATCH 04/10] Really fixing the package ID parsing --- src/SandFix.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/SandFix.hs b/src/SandFix.hs index 9396ec3..3e4238d 100644 --- a/src/SandFix.hs +++ b/src/SandFix.hs @@ -34,9 +34,10 @@ getReadPackageDB = do type Fix = Either String -packageIdFromInstalledPackageId (SimpleUnitId (ComponentId pid)) = case simpleParse pid of - Nothing -> Left $ "Failed to parse installed package id " ++ pid - Just pid -> return pid +packageIdFromInstalledPackageId (SimpleUnitId (ComponentId str)) = + case simpleParse $ take (length str - 21) str of + Nothing -> Left $ "Failed to parse installed package id " ++ str + Just pid -> return pid fixPackageIndex globalPkgIndices sandboxRPT brokenPackageIndex = fromPackageIdsPackageInfoPairs . unzip <$> mapM fixInstalledPackage (allPackages brokenPackageIndex) @@ -48,6 +49,7 @@ fixPackageIndex globalPkgIndices sandboxRPT brokenPackageIndex -- 1. Fix dependencies dependencies <- forM (I.depends info) $ \ipkgid -> do pkgid <- packageIdFromInstalledPackageId ipkgid + case lookupUnitId brokenPackageIndex ipkgid `mplus` (listToMaybe $ concatMap ((flip lookupSourcePackageId) pkgid) globalPkgIndices) of From d51022eeae061e1178be83f58e79a2600f72c361 Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Thu, 5 Jan 2017 18:05:20 +0100 Subject: [PATCH 05/10] Now really --- src/SandFix.hs | 75 +++++++++++++++++++++++++++----------------------- 1 file changed, 41 insertions(+), 34 deletions(-) diff --git a/src/SandFix.hs b/src/SandFix.hs index 3e4238d..05fabaa 100644 --- a/src/SandFix.hs +++ b/src/SandFix.hs @@ -1,23 +1,26 @@ -import Control.Applicative ((<$>)) -import Control.Monad (filterM, forM, mplus, when, unless, forM_) -import Data.List (isSuffixOf, isPrefixOf, intercalate) -import qualified Data.Map as Map -import Data.Maybe (isNothing, listToMaybe, maybeToList) -import Data.Either (lefts, rights) -import Data.Monoid -import qualified Data.Set as Set +import Control.Applicative ((<$>)) +import Control.Monad (filterM, forM, forM_, mplus, + unless, when) +import Data.Either (lefts, rights) +import Data.List (intercalate, isPrefixOf, + isSuffixOf, find) +import qualified Data.Map as Map +import Data.Maybe (isNothing, listToMaybe, + maybeToList) +import Data.Monoid +import qualified Data.Set as Set import qualified Distribution.InstalledPackageInfo as I -import Distribution.Package -import Distribution.Simple.Compiler -import Distribution.Simple.GHC -import Distribution.Simple.PackageIndex -import Distribution.Simple.Program -import Distribution.Text -import Distribution.Verbosity -import System.Directory -import System.Environment -import System.Exit -import System.IO +import Distribution.Package +import Distribution.Simple.Compiler +import Distribution.Simple.GHC +import Distribution.Simple.PackageIndex +import Distribution.Simple.Program +import Distribution.Text +import Distribution.Verbosity +import System.Directory +import System.Environment +import System.Exit +import System.IO _VERBOSITY :: Verbosity _VERBOSITY = normal @@ -34,14 +37,18 @@ getReadPackageDB = do type Fix = Either String -packageIdFromInstalledPackageId (SimpleUnitId (ComponentId str)) = - case simpleParse $ take (length str - 21) str of - Nothing -> Left $ "Failed to parse installed package id " ++ str - Just pid -> return pid - +fixPackageIndex :: [InstalledPackageIndex] -> RPT -> InstalledPackageIndex -> Either String ([PackageId], PackageIndex I.InstalledPackageInfo) fixPackageIndex globalPkgIndices sandboxRPT brokenPackageIndex = fromPackageIdsPackageInfoPairs . unzip <$> mapM fixInstalledPackage (allPackages brokenPackageIndex) where + allKnownPackages :: Map.Map String I.InstalledPackageInfo + allKnownPackages = Map.fromList $ map (\pkg -> (I.compatPackageKey pkg, pkg)) $ concatMap allPackages $ (brokenPackageIndex : globalPkgIndices) + + packageIdFromInstalledPackageId (SimpleUnitId (ComponentId str)) = + case Map.lookup str allKnownPackages of + Just pkg -> Right $ I.sourcePackageId pkg + Nothing -> Left $ "Could not find package in brokenPackageIndex: " ++ str + fromPackageIdsPackageInfoPairs = \(brokenPkgIds, infos) -> (concat brokenPkgIds, fromList infos) fixInstalledPackage info @@ -54,19 +61,19 @@ fixPackageIndex globalPkgIndices sandboxRPT brokenPackageIndex (listToMaybe $ concatMap ((flip lookupSourcePackageId) pkgid) globalPkgIndices) of Just fInfo -> return . Right $ I.installedUnitId fInfo - Nothing -> return . Left $ pkgid + Nothing -> return . Left $ pkgid let fixedDependencies = rights dependencies brokenDependencies = lefts dependencies -- 2. Fix the global paths - let + let findOneOrFail path = case findPartialPathMatches path sandboxRPT of [] -> Left $ "Could not find sandbox path of " ++ path [a] -> return a ps -> Left $ "Multiple possible sandbox paths of " ++ path ++ ": " ++ show ps findFirstOrRoot path = case findPartialPathMatches path sandboxRPT of - [] -> "/" + [] -> "/" (a : _) -> a fixedImportDirs <- mapM findOneOrFail $ I.importDirs info fixedLibDirs <- mapM findOneOrFail $ I.libraryDirs info @@ -101,14 +108,14 @@ pkgDbStack args = map (parseDb . argValue) (pkgArgs args) argPrefix = "--package-db=" argValue = drop (length argPrefix) parseDb "global" = GlobalPackageDB - parseDb "user" = UserPackageDB - parseDb p = SpecificPackageDB p + parseDb "user" = UserPackageDB + parseDb p = SpecificPackageDB p pkgArgs = filter (isPrefixOf argPrefix) pkgDbStackWithDefault :: [String] -> PackageDBStack pkgDbStackWithDefault args = case pkgDbStack args of - [] -> [GlobalPackageDB] -- default + [] -> [GlobalPackageDB] -- default pkgs -> pkgs main :: IO () @@ -158,7 +165,7 @@ main = do -- Reverse Path Tree data RPT = RPT - { rptPath :: Maybe FilePath + { rptPath :: Maybe FilePath , rptChildren :: Map.Map String RPT } deriving Show @@ -188,9 +195,9 @@ fromDirRecursively = fromDirRecursively' Set.empty fromDirRecursively'' visited path | path `Set.member` visited = return mempty | otherwise = do - let isSub "." = False + let isSub "." = False isSub ".." = False - isSub _ = True + isSub _ = True allSubs <- map (\p -> path <> "/" <> p) . filter isSub <$> getDirectoryContents path subDirs <- filterM doesDirectoryExist allSubs subRPT <- mconcat <$> mapM (fromDirRecursively' $ Set.insert path visited) subDirs @@ -202,7 +209,7 @@ reverseSplitFilePath filepath = reverseSplitFilePath' filepath [] reverseSplitFilePath' "" ps = ps reverseSplitFilePath' path ps = case span (/= '/') path of ("", '/' : rest) -> reverseSplitFilePath' rest ps - (p, rest) -> reverseSplitFilePath' rest (p : ps) + (p, rest) -> reverseSplitFilePath' rest (p : ps) findPartialPathMatches :: FilePath -> RPT -> [FilePath] findPartialPathMatches filepath r From 24fe4d6e7e85d3541fccd5d85cad2d63f03b0020 Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Thu, 5 Jan 2017 18:21:06 +0100 Subject: [PATCH 06/10] Or now --- src/SandFix.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/SandFix.hs b/src/SandFix.hs index 05fabaa..333e0e4 100644 --- a/src/SandFix.hs +++ b/src/SandFix.hs @@ -42,12 +42,12 @@ fixPackageIndex globalPkgIndices sandboxRPT brokenPackageIndex = fromPackageIdsPackageInfoPairs . unzip <$> mapM fixInstalledPackage (allPackages brokenPackageIndex) where allKnownPackages :: Map.Map String I.InstalledPackageInfo - allKnownPackages = Map.fromList $ map (\pkg -> (I.compatPackageKey pkg, pkg)) $ concatMap allPackages $ (brokenPackageIndex : globalPkgIndices) + allKnownPackages = Map.fromList $ map (\pkg -> (show $ disp $ I.sourcePackageId pkg, pkg)) $ concatMap allPackages $ (brokenPackageIndex : globalPkgIndices) packageIdFromInstalledPackageId (SimpleUnitId (ComponentId str)) = - case Map.lookup str allKnownPackages of - Just pkg -> Right $ I.sourcePackageId pkg - Nothing -> Left $ "Could not find package in brokenPackageIndex: " ++ str + case find (\(k, v) -> isPrefixOf k str) (Map.toList allKnownPackages) of + Just (_, pkg) -> Right $ I.sourcePackageId pkg + Nothing -> Left $ "Could not find package: " ++ str ++ "Keys:" ++ intercalate " " (Map.keys allKnownPackages) fromPackageIdsPackageInfoPairs = \(brokenPkgIds, infos) -> (concat brokenPkgIds, fromList infos) From 99114ed569dcb571aa8e9a8ef516afaf9aba7974 Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Thu, 12 Jan 2017 20:23:43 +0100 Subject: [PATCH 07/10] Fixing libraryDynDirs and dataDir --- src/SandFix.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/SandFix.hs b/src/SandFix.hs index 333e0e4..4836bb4 100644 --- a/src/SandFix.hs +++ b/src/SandFix.hs @@ -77,7 +77,9 @@ fixPackageIndex globalPkgIndices sandboxRPT brokenPackageIndex (a : _) -> a fixedImportDirs <- mapM findOneOrFail $ I.importDirs info fixedLibDirs <- mapM findOneOrFail $ I.libraryDirs info + fixedLibDynDirs <- mapM findOneOrFail $ I.libraryDynDirs info fixedIncludeDirs <- mapM findOneOrFail $ I.includeDirs info + fixedDataDir <- findOneOrFail $ I.dataDir info let fixedFrameworkDirs = findFirstOrRoot <$> I.frameworkDirs info fixedHaddockIfaces = findFirstOrRoot <$> I.haddockInterfaces info fixedHaddockHTMLs = findFirstOrRoot <$> I.haddockHTMLs info @@ -87,10 +89,12 @@ fixPackageIndex globalPkgIndices sandboxRPT brokenPackageIndex { I.depends = fixedDependencies , I.importDirs = fixedImportDirs , I.libraryDirs = fixedLibDirs + , I.libraryDynDirs = fixedLibDynDirs , I.includeDirs = fixedIncludeDirs , I.frameworkDirs = fixedFrameworkDirs , I.haddockInterfaces = fixedHaddockIfaces , I.haddockHTMLs = fixedHaddockHTMLs + , I.dataDir = fixedDataDir }) findDBs :: FilePath -> Maybe String -> IO [FilePath] From 7cc4ecbcb993e709e6c5b40dca9c825e7389006e Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Fri, 13 Jan 2017 09:21:20 +0100 Subject: [PATCH 08/10] Fixed dynlib path --- src/SandFix.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/SandFix.hs b/src/SandFix.hs index 4836bb4..02ce8c0 100644 --- a/src/SandFix.hs +++ b/src/SandFix.hs @@ -3,10 +3,10 @@ import Control.Monad (filterM, forM, forM_, mplus, unless, when) import Data.Either (lefts, rights) import Data.List (intercalate, isPrefixOf, - isSuffixOf, find) + isSuffixOf, find, findIndex, findIndex) import qualified Data.Map as Map import Data.Maybe (isNothing, listToMaybe, - maybeToList) + maybeToList, fromJust) import Data.Monoid import qualified Data.Set as Set import qualified Distribution.InstalledPackageInfo as I @@ -77,9 +77,8 @@ fixPackageIndex globalPkgIndices sandboxRPT brokenPackageIndex (a : _) -> a fixedImportDirs <- mapM findOneOrFail $ I.importDirs info fixedLibDirs <- mapM findOneOrFail $ I.libraryDirs info - fixedLibDynDirs <- mapM findOneOrFail $ I.libraryDynDirs info + fixedLibDynDirs <- mapM parent fixedLibDirs fixedIncludeDirs <- mapM findOneOrFail $ I.includeDirs info - fixedDataDir <- findOneOrFail $ I.dataDir info let fixedFrameworkDirs = findFirstOrRoot <$> I.frameworkDirs info fixedHaddockIfaces = findFirstOrRoot <$> I.haddockInterfaces info fixedHaddockHTMLs = findFirstOrRoot <$> I.haddockHTMLs info @@ -94,9 +93,13 @@ fixPackageIndex globalPkgIndices sandboxRPT brokenPackageIndex , I.frameworkDirs = fixedFrameworkDirs , I.haddockInterfaces = fixedHaddockIfaces , I.haddockHTMLs = fixedHaddockHTMLs - , I.dataDir = fixedDataDir }) +parent :: FilePath -> Either String FilePath +parent filePath = do + lastSlashIdx <- maybe (Left $ "Cannot find parent of " ++ filePath) (\idx -> Right $ (length filePath) - 1 - idx) (findIndex (== '/') (reverse filePath)) + return $ take lastSlashIdx filePath + findDBs :: FilePath -> Maybe String -> IO [FilePath] findDBs sandboxPath pkgDir = case pkgDir of From 3dec366f7e1dd7b7c801f5b8b3092a3e8e145c5a Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Mon, 16 Jan 2017 13:23:09 +0100 Subject: [PATCH 09/10] Temporarily back to < GHC 802 --- src/SandFix.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SandFix.hs b/src/SandFix.hs index 02ce8c0..a2b1458 100644 --- a/src/SandFix.hs +++ b/src/SandFix.hs @@ -88,7 +88,7 @@ fixPackageIndex globalPkgIndices sandboxRPT brokenPackageIndex { I.depends = fixedDependencies , I.importDirs = fixedImportDirs , I.libraryDirs = fixedLibDirs - , I.libraryDynDirs = fixedLibDynDirs +-- , I.libraryDynDirs = fixedLibDynDirs , I.includeDirs = fixedIncludeDirs , I.frameworkDirs = fixedFrameworkDirs , I.haddockInterfaces = fixedHaddockIfaces From 8b770cb44b1f9acd4d1bf55cdb85705d5b4353a5 Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Mon, 16 Jan 2017 13:26:17 +0100 Subject: [PATCH 10/10] Revert revert --- src/SandFix.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SandFix.hs b/src/SandFix.hs index a2b1458..02ce8c0 100644 --- a/src/SandFix.hs +++ b/src/SandFix.hs @@ -88,7 +88,7 @@ fixPackageIndex globalPkgIndices sandboxRPT brokenPackageIndex { I.depends = fixedDependencies , I.importDirs = fixedImportDirs , I.libraryDirs = fixedLibDirs --- , I.libraryDynDirs = fixedLibDynDirs + , I.libraryDynDirs = fixedLibDynDirs , I.includeDirs = fixedIncludeDirs , I.frameworkDirs = fixedFrameworkDirs , I.haddockInterfaces = fixedHaddockIfaces