Factor sandbox stuff out into a seperate module

So we can use the sandbox discovery for Setup.hs components

3 files changed, 58 insertions, 0 deletions

diff --git a/CabalHelper/Data.hs b/CabalHelper/Data.hs
index 97e9988..6f86ff9 100644
--- a/CabalHelper/Data.hs
+++ b/CabalHelper/Data.hs
@@ -40,5 +40,6 @@ sourceFiles :: [(FilePath, String)]
 sourceFiles =
   [ ("Main.hs",   $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Main.hs")))
   , ("Common.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Common.hs")))
+  , ("Sandbox.hs",  $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Sandbox.hs")))
   , ("Types.hs",  $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Types.hs")))
   ]
diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs
index 4c64f42..754f356 100644
--- a/CabalHelper/Main.hs
+++ b/CabalHelper/Main.hs
@@ -79,6 +79,7 @@ import System.IO
 import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO)
 import Text.Printf
 
+import CabalHelper.Sandbox
 import CabalHelper.Common
 import CabalHelper.Types
 
diff --git a/CabalHelper/Sandbox.hs b/CabalHelper/Sandbox.hs
new file mode 100644
index 0000000..f379eeb
--- /dev/null
+++ b/CabalHelper/Sandbox.hs
@@ -0,0 +1,56 @@
+module CabalHelper.Sandbox where
+
+
+import Control.Applicative
+import Data.Char
+import Data.Maybe
+import Data.List
+import Data.Version
+import System.FilePath
+import System.Directory
+
+import qualified Data.Traversable as T
+
+-- | Get the path to the sandbox package-db in a project
+getSandboxPkgDb :: FilePath
+             -- ^ Path to the cabal package root directory (containing the
+             -- @cabal.sandbox.config@ file)
+             -> String
+             -- ^ Cabal build platform, i.e. @buildPlatform@
+             -> Version
+             -- ^ GHC version (@cProjectVersion@ is your friend)
+             -> IO (Maybe FilePath)
+getSandboxPkgDb d platform ghcVer = do
+  mConf <- T.traverse readFile =<< mightExist (d </> "cabal.sandbox.config")
+  return $ fixPkgDbVer <$> (extractSandboxDbDir =<< mConf)
+
+ where
+   fixPkgDbVer dir =
+       case takeFileName dir == ghcSandboxPkgDbDir platform ghcVer of
+         True -> dir
+         False -> takeDirectory dir </> ghcSandboxPkgDbDir platform ghcVer
+
+ghcSandboxPkgDbDir :: String -> Version -> String
+ghcSandboxPkgDbDir platform ghcVer =
+   platform ++ "-ghc-" ++ showVersion ghcVer ++ "-packages.conf.d"
+
+-- | Extract the sandbox package db directory from the cabal.sandbox.config
+-- file. Exception is thrown if the sandbox config file is broken.
+extractSandboxDbDir :: String -> Maybe FilePath
+extractSandboxDbDir conf = extractValue <$> parse conf
+  where
+    key = "package-db:"
+    keyLen = length key
+
+    parse = listToMaybe . filter (key `isPrefixOf`) . lines
+    extractValue = CabalHelper.Sandbox.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
+
+
+mightExist :: FilePath -> IO (Maybe FilePath)
+mightExist f = do
+  exists <- doesFileExist f
+  return $ if exists then (Just f) else (Nothing)
+
+-- dropWhileEnd is not provided prior to base 4.5.0.0.
+dropWhileEnd :: (a -> Bool) -> [a] -> [a]
+dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []