Factor sandbox stuff out into a seperate module

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

5 files changed, 67 insertions, 51 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) []
diff --git a/Distribution/Helper.hs b/Distribution/Helper.hs
index 304bba9..f591b28 100644
--- a/Distribution/Helper.hs
+++ b/Distribution/Helper.hs
@@ -46,7 +46,7 @@ module Distribution.Helper (
   , buildPlatform
 
   -- * Stuff that cabal-install really should export
-  , getSandboxPkgDb
+  , Distribution.Helper.getSandboxPkgDb
 
   -- * Managing @dist/@
   , reconfigure
@@ -58,15 +58,12 @@ module Distribution.Helper (
   ) where
 
 import Control.Applicative
-import Control.Arrow
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.State.Strict
 import Control.Monad.Reader
 import Control.Exception as E
 import Data.Char
-import Data.Monoid
-import Data.Maybe
 import Data.List
 import Data.Default
 import Data.Version
@@ -80,10 +77,9 @@ import System.IO.Unsafe
 import Text.Printf
 import GHC.Generics
 
-import qualified Data.Traversable as T
-
 import Paths_cabal_helper (getLibexecDir)
 import CabalHelper.Types
+import CabalHelper.Sandbox
 
 -- | Paths or names of various programs we need.
 data Programs = Programs {
@@ -117,6 +113,8 @@ type MonadQuery m = ( MonadIO m
                     , MonadState (Maybe SomeLocalBuildInfo) m
                     , MonadReader (Programs, FilePath) m)
 
+run :: Monad m
+  => (Programs, FilePath) -> Maybe SomeLocalBuildInfo -> Query m a -> m a
 run r s action = flip runReaderT r (flip evalStateT s (unQuery action))
 
 -- | @runQuery query distdir@. Run a 'Query'. @distdir@ is where Cabal's
@@ -243,51 +241,19 @@ writeAutogenFiles distdir = liftIO $ do
   exe  <- findLibexecExe "cabal-helper-wrapper"
   void $ readProcess exe [distdir, "write-autogen-files"] ""
 
-
 -- | 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)
+             -- ^ Cabal build platform, i.e. @buildPlatform@
              -> Version
              -- ^ GHC version (@cProjectVersion@ is your friend)
              -> IO (Maybe FilePath)
-getSandboxPkgDb d ghcVer = do
-  mConf <- T.traverse readFile =<< mightExist (d </> "cabal.sandbox.config")
-  return $ fixPkgDbVer <$> (extractSandboxDbDir =<< mConf)
-
- where
-   fixPkgDbVer dir =
-       case takeFileName dir == ghcSandboxPkgDbDir ghcVer of
-         True -> dir
-         False -> takeDirectory dir </> ghcSandboxPkgDbDir ghcVer
-
-ghcSandboxPkgDbDir :: Version -> String
-ghcSandboxPkgDbDir ghcVer =
-   cabalBuildPlatform ++ "-ghc-" ++ showVersion ghcVer ++ "-packages.conf.d"
-
-cabalBuildPlatform :: String
--- The build platform isn't going to change at runtime, is it? ;)
-cabalBuildPlatform = unsafePerformIO $ buildPlatform
-
--- | 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 = Distribution.Helper.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
+getSandboxPkgDb =
+    CabalHelper.Sandbox.getSandboxPkgDb $ unsafePerformIO buildPlatform
 
 buildPlatform :: IO String
 buildPlatform = do
   exe  <- findLibexecExe "cabal-helper-wrapper"
-  dropWhileEnd isSpace <$> readProcess exe ["print-build-platform"] ""
- where
-   -- 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) []
+  CabalHelper.Sandbox.dropWhileEnd isSpace <$> readProcess exe ["print-build-platform"] ""
 
 -- | This exception is thrown by all 'runQuery' functions if the internal
 -- wrapper executable cannot be found. You may catch this and present the user
@@ -361,12 +327,3 @@ getExecutablePath' =
 #else
     getProgName
 #endif
-
-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) []
diff --git a/cabal-helper.cabal b/cabal-helper.cabal
index 15710e3..0cbee55 100644
--- a/cabal-helper.cabal
+++ b/cabal-helper.cabal
@@ -43,6 +43,7 @@ library
   Other-Modules:       Paths_cabal_helper
                      , CabalHelper.Types
   default-language:    Haskell2010
+  GHC-Options:         -Wall
   Build-Depends:       base >= 4.5 && < 5
                      , Cabal >= 1.14 && < 1.23
                      , data-default