Upgraded to Cabal 1.24

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/

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,40 +37,47 @@ 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
       = do
       -- 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,15 +164,15 @@ 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"
 
 -- 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