Custom cradle support

Language/Haskell/GhcMod/CabalHelper.hs

@@ -95,20 +95,26 @@ cabalHelperCache = Cached {
                 , a == a'
                 ]
 
-
 withCabal :: (MonadIO m, GmEnv m) => m a -> m a
 withCabal action = do
     crdl <- cradle
     opts <- options
     liftIO $ whenM (isSetupConfigOutOfDate <$> getCurrentWorld crdl) $
         withDirectory_ (cradleRootDir crdl) $ do
-            let progOpts =
+            let pkgDbArgs = "--package-db=clear" : map pkgDbArg (cradlePkgDbStack crdl)
+                progOpts =
                     [ "--with-ghc=" ++ T.ghcProgram opts ]
                     -- Only pass ghc-pkg if it was actually set otherwise we
                     -- might break cabal's guessing logic
                     ++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions
                          then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]
                          else []
+                    ++ pkgDbArgs
             void $ readProcess (T.cabalProgram opts) ("configure":progOpts) ""
             writeAutogenFiles $ cradleRootDir crdl </> "dist"
     action
+
+pkgDbArg :: GhcPkgDb -> String
+pkgDbArg GlobalDb      = "--package-db=global"
+pkgDbArg UserDb        = "--package-db=user"
+pkgDbArg (PackageDb p) = "--package-db=" ++ p

Language/Haskell/GhcMod/Cradle.hs

@@ -28,7 +28,7 @@ findCradle = findCradle' =<< getCurrentDirectory
 
 findCradle' :: FilePath -> IO Cradle
 findCradle' dir = run $ do
-    (cabalCradle dir `mplus`  sandboxCradle dir `mplus` plainCradle dir)
+    (customCradle dir `mplus` cabalCradle dir `mplus`  sandboxCradle dir `mplus` plainCradle dir)
  where run a = fillTempDir =<< (fromJust <$> runMaybeT a)
 
 findSpecCradle :: FilePath -> IO Cradle
@@ -52,6 +52,21 @@ fillTempDir crdl = do
   tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
   return crdl { cradleTempDir = tmpDir }
 
+customCradle :: FilePath -> MaybeT IO Cradle
+customCradle wdir = do
+    cabalFile <- MaybeT $ findCabalFile wdir
+    let cabalDir = takeDirectory cabalFile
+    cradleFile <- MaybeT $ findCradleFile cabalDir
+    tmpDir <- liftIO $ newTempDir cabalDir
+    pkgDbStack <- liftIO $ parseCradle cradleFile
+    return Cradle {
+        cradleCurrentDir = wdir
+      , cradleRootDir    = cabalDir
+      , cradleTempDir    = tmpDir
+      , cradleCabalFile  = Just cabalFile
+      , cradlePkgDbStack = pkgDbStack
+      }
+
 cabalCradle :: FilePath -> MaybeT IO Cradle
 cabalCradle wdir = do
     cabalFile <- MaybeT $ findCabalFile wdir
@@ -95,3 +110,21 @@ getPackageDbStack :: FilePath -- ^ Project Directory (where the
                   -> IO [GhcPkgDb]
 getPackageDbStack cdir =
     ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir
+
+-- Just for testing
+findCradleWithoutSandbox :: IO Cradle
+findCradleWithoutSandbox = do
+    cradle <- findCradle
+    return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME
+
+
+parseCradle :: FilePath -> IO [GhcPkgDb]
+parseCradle path = do
+    source <- readFile path
+    return $ parseCradle' source
+  where
+    parseCradle' source = map parsePkgDb $ filter (not . null) $ lines source
+
+    parsePkgDb "global" = GlobalDb
+    parsePkgDb "user" = UserDb
+    parsePkgDb s = PackageDb s

Language/Haskell/GhcMod/PathsAndFiles.hs

@@ -193,7 +193,6 @@ cabalBuildPlatform = unsafePerformIO $ buildPlatform
 packageCache :: String
 packageCache = "package.cache"
 
-
 -- | Filename of the symbol table cache file.
 symbolCache :: Cradle -> FilePath
 symbolCache crdl = cradleTempDir crdl </> symbolCacheFile
@@ -206,3 +205,13 @@ resolvedComponentsCacheFile = setupConfigPath <.> "ghc-mod.resolved-components"
 
 cabalHelperCacheFile :: String
 cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-helper"
+
+-- | @findCradleFile dir@. Searches for a @.ghc-mod.cradle@ file in @dir@.
+-- If it exists in the given directory it is returned otherwise @findCradleFile@ returns @Nothing@
+findCradleFile :: FilePath -> IO (Maybe FilePath)
+findCradleFile directory = do
+    let path = directory </> "ghc-mod.cradle"
+    exists <- doesFileExist $ path
+    case exists of
+        True  -> return $ Just path
+        False -> return Nothing

Language/Haskell/GhcMod/Types.hs

@@ -272,7 +272,7 @@ data GhcModError
 
     | GMECabalStateFile GMConfigStateFileError
       -- ^ Reading Cabal's state configuration file falied somehow.
-      deriving (Eq,Show,Typeable)
+    deriving (Eq,Show,Typeable)
 
 instance Error GhcModError where
     noMsg = GMENoMsg

README.md

@@ -44,6 +44,19 @@ Make sure you're not using the MELPA version of `ghc.el` otherwise you might get
 all sorts of nasty conflicts.
 
 
+## Custom ghc-mod cradle
+
+To customize the package databases used by `ghc-mod`, put a file called `.ghc-mod.cradle` beside the `.cabal` file with the following syntax:
+
+```
+temp directory root
+package db 1
+...
+package db n
+```
+
+each package database line is either a *path* to a package database, or `global` or `user`.
+
 ## IRC
 
 If you have any problems, suggestions, comments swing by

test/CradleSpec.hs

@@ -71,4 +71,11 @@ spec = do
                 cradleCabalFile  res `shouldBe`
                   Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
 
+        it "uses the custom cradle file if present" $ do
+            withDirectory "test/data/custom-cradle" $ \dir -> do
+                res <- relativeCradle dir <$> findCradle
+                cradleCurrentDir res `shouldBe` "test" </> "data" </> "custom-cradle"
+                cradleRootDir res    `shouldBe` "test" </> "data" </> "custom-cradle"
+                cradleCabalFile res  `shouldBe` Just ("test" </> "data" </> "custom-cradle" </> "dummy.cabal")
+                cradlePkgDbStack res `shouldBe` [PackageDb "a/packages", GlobalDb, PackageDb "b/packages", UserDb, PackageDb "c/packages"]
                 cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb]

test/data/custom-cradle/.ghc-mod.cradle

@@ -0,0 +1,5 @@
+a/packages
+global
+b/packages
+user
+c/packages

test/data/custom-cradle/dummy.cabal

@@ -0,0 +1 @@
+dummy