From 9071875e677d6c58b88bf38237330dec41f50cc5 Mon Sep 17 00:00:00 2001
From: Luite Stegeman <stegeman@gmail.com>
Date: Fri, 30 Mar 2012 08:50:25 +0200
Subject: [PATCH] properly hide other packages when running yesod --dev devel

---
 yesod/Devel.hs                  | 34 ++++++++++++++++++++-------------
 yesod/scaffold/project.cabal.cg |  2 ++
 2 files changed, 23 insertions(+), 13 deletions(-)

diff --git a/yesod/Devel.hs b/yesod/Devel.hs
index bad10170..729494ef 100644
--- a/yesod/Devel.hs
+++ b/yesod/Devel.hs
@@ -43,7 +43,6 @@ writeLock = do
 
 removeLock :: IO ()
 removeLock = try_ (removeFile lockFile)
-
 devel :: Bool -> [String] -> IO ()
 devel isCabalDev passThroughArgs = do
 
@@ -82,6 +81,9 @@ devel isCabalDev passThroughArgs = do
     mainLoop :: IO ()
     mainLoop = do
        ghcVer <- ghcVersion
+       when isCabalDev (rawSystem cmd ["build"] >> return ())  -- cabal-dev fails with strange errors sometimes if we cabal-dev buildinfo before cabal-dev build
+       pkgArgs <- ghcPackageArgs isCabalDev ghcVer
+       let devArgs = pkgArgs ++ ["devel.hs"] ++ passThroughArgs
        forever $ do
            putStrLn "Rebuilding application..."
 
@@ -94,10 +96,8 @@ devel isCabalDev passThroughArgs = do
              ExitFailure _ -> putStrLn "Build failure, pausing..."
              _ -> do
                    removeLock
-                   let pkg = pkgConfigs isCabalDev ghcVer
-                   let dev_args = pkg ++ ["devel.hs"] ++ passThroughArgs
-                   putStrLn $ "Starting development server: runghc " ++ L.intercalate " " dev_args
-                   (_,_,_,ph) <- createProcess $ proc "runghc" dev_args
+                   putStrLn $ "Starting development server: runghc " ++ L.intercalate " " devArgs
+                   (_,_,_,ph) <- createProcess $ proc "runghc" devArgs
                    watchTid <- forkIO . try_ $ do
                          watchForChanges list
                          putStrLn "Stopping development server..."
@@ -113,14 +113,6 @@ devel isCabalDev passThroughArgs = do
 try_ :: forall a. IO a -> IO ()
 try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return ()
 
-pkgConfigs :: Bool -> String -> [String]
-pkgConfigs isCabalDev ghcVer
-  | isCabalDev = ["-package-confcabal-dev/packages-" ++ ghcVer ++ ".conf", inplacePkg]
-  | otherwise  = [inplacePkg]
-  where
-    inplacePkg = "-package-confdist/package.conf.inplace"
-
-
 type FileList = Map.Map FilePath EpochTime
 
 getFileList :: IO FileList
@@ -192,6 +184,22 @@ ghcVersion = fmap getNumber $ readProcess "runghc" ["--numeric-version", "0"] []
     where
       getNumber = filter (\x -> isNumber x || x == '.')
 
+ghcPackageArgs :: Bool -> String -> IO [String]
+ghcPackageArgs isCabalDev ghcVer
+  | isCabalDev = do
+      r <- readProcess "cabal-dev" ["buildopts"] []
+      let opts = L.lines r
+      return $ "-hide-all-packages" : "-no-user-package-conf" : inplacePkg : cabaldevConf : pkgid opts : depPkgIds opts
+  | otherwise = return [inplacePkg]
+      where
+        pkgid opts      = let (_,p) = head (selectOpts ["-package-name"] opts) in "-package-id" ++ p ++ "-inplace"
+        depPkgIds opts  = map (uncurry (++)) (selectOpts ["-package-id"] opts)
+        inplacePkg   = "-package-confdist/package.conf.inplace"
+        cabaldevConf = "-package-confcabal-dev/packages-" ++ ghcVer ++ ".conf"
+        selectOpts opts (x1:x2:xs)
+           | x1 `elem` opts = (x1,x2):selectOpts opts xs
+           | otherwise      = selectOpts opts (x2:xs)
+        selectOpts _ _ = []
 
 lookupDevelLib :: D.CondTree D.ConfVar c a -> Maybe a
 lookupDevelLib ct | found     = Just (D.condTreeData ct)
diff --git a/yesod/scaffold/project.cabal.cg b/yesod/scaffold/project.cabal.cg
index 39108075..1a7f7955 100644
--- a/yesod/scaffold/project.cabal.cg
+++ b/yesod/scaffold/project.cabal.cg
@@ -97,5 +97,7 @@ executable         ~project~
                  , wai-extra                     >= 1.2        && < 1.3
                  , yaml                          >= 0.7        && < 0.8
                  , http-conduit                  >= 1.4        && < 1.5
+                 , directory                     >= 1.1        && < 1.2
+                 , warp                          >= 1.2        && < 1.3
 
                  ~testsDep~