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..02ce8c0 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, findIndex, findIndex) +import qualified Data.Map as Map +import Data.Maybe (isNothing, listToMaybe, + maybeToList, fromJust) +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,13 +37,18 @@ getReadPackageDB = do type Fix = Either String -packageIdFromInstalledPackageId (InstalledPackageId str) = case simpleParse $ take (length str - 33) 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 -> (show $ disp $ I.sourcePackageId pkg, pkg)) $ concatMap allPackages $ (brokenPackageIndex : globalPkgIndices) + + packageIdFromInstalledPackageId (SimpleUnitId (ComponentId 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) fixInstalledPackage info @@ -48,26 +56,28 @@ 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 - Nothing -> return . Left $ pkgid + Just fInfo -> return . Right $ I.installedUnitId fInfo + 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 + fixedLibDynDirs <- mapM parent fixedLibDirs fixedIncludeDirs <- mapM findOneOrFail $ I.includeDirs info let fixedFrameworkDirs = findFirstOrRoot <$> I.frameworkDirs info fixedHaddockIfaces = findFirstOrRoot <$> I.haddockInterfaces info @@ -78,12 +88,18 @@ 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 }) +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 @@ -99,14 +115,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 () @@ -148,7 +164,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" @@ -156,7 +172,7 @@ main = do -- Reverse Path Tree data RPT = RPT - { rptPath :: Maybe FilePath + { rptPath :: Maybe FilePath , rptChildren :: Map.Map String RPT } deriving Show @@ -186,9 +202,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 @@ -200,7 +216,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