shake: Creating and using local package db

Stackage/PerformBuild.hs

@@ -10,6 +10,7 @@ module Stackage.PerformBuild
     , PerformBuild (..)
     , BuildException (..)
     , pbDocDir
+    , copyBuiltInHaddocks
     ) where
 
 import           Control.Concurrent.Async    (async)

Stackage/ShakeBuild.hs

@@ -2,25 +2,27 @@
 
 module Stackage.ShakeBuild where
 
+import           Stackage.BuildConstraints
 import           Stackage.BuildPlan
 import           Stackage.PackageDescription
-import           Stackage.BuildConstraints
+import           Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks)
-import           Stackage.PerformBuild (PerformBuild(..))
 
-import           Control.Monad
+import           Control.Monad hiding (forM_)
-import           Data.List ((\\))
 import qualified Data.Map.Strict as M
-import           Data.Text (Text)
+import qualified Data.Text as T
-import           Development.Shake
+import           Development.Shake hiding (doesDirectoryExist)
 import           Distribution.Package (PackageName)
 import           Distribution.Text (display)
+import qualified Filesystem.Path.CurrentOS as FP
+import           Stackage.Prelude (unFlagName)
 import           System.Directory
 import           System.Environment
 
 -- | Run the shake builder.
 performBuild :: PerformBuild -> IO ()
 performBuild pb = do
-    shakeDir <- fmap (<//> "shake/") getCurrentDirectory
+    shakeDir <- fmap (<//> "shake/") (getCurrentDirectory >>= canonicalizePath)
+    createDirectoryIfMissing True shakeDir
     withArgs
         []
         (shakeArgs
@@ -32,6 +34,9 @@ shakePlan :: PerformBuild -> FilePath -> Rules ()
 shakePlan pb shakeDir = do
     fetched <- target (targetForFetched shakeDir) $
                fetchedTarget shakeDir pb
+    db <- target
+              (targetForDb shakeDir pb)
+              (databaseTarget shakeDir pb)
     _ <- forM corePackages $
          \name ->
               let fp =
@@ -41,8 +46,8 @@ shakePlan pb shakeDir = do
                       \(name,plan) ->
                            target
                                (targetForPackage shakeDir name)
-                               (do need [fetched]
+                               (do need [db, fetched]
-                                   packageTarget shakeDir name plan)
+                                   packageTarget pb shakeDir name plan)
     want packageTargets
     where corePackages =
               M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb
@@ -50,6 +55,18 @@ shakePlan pb shakeDir = do
               filter (not . (`elem` corePackages) . fst) $
               M.toList $ bpPackages $ pbPlan pb
 
+-- | Initialize the database if there one needs to be, and in any case
+-- create the target file.
+databaseTarget :: FilePath -> PerformBuild -> Action ()
+databaseTarget shakeDir pb =
+    if pbGlobalInstall pb
+       then liftIO (createDirectoryIfMissing True dir)
+       else do liftIO (createDirectoryIfMissing True (dir))
+               liftIO (removeDirectoryRecursive dir)
+               () <- cmd "ghc-pkg" "init" dir
+               liftIO (copyBuiltInHaddocks (FP.decodeString (pbDocDir pb)))
+  where dir = targetForDb shakeDir pb
+
 -- | Make sure all package archives have been fetched.
 fetchedTarget :: FilePath -> PerformBuild -> Action ()
 fetchedTarget shakeDir pb = do
@@ -65,40 +82,72 @@ fetchedTarget shakeDir pb = do
     makeFile (targetForFetched shakeDir)
 
 -- | Build, test and generate documentation for the package.
-packageTarget :: FilePath -> PackageName -> PackagePlan -> Action ()
+packageTarget :: PerformBuild -> FilePath -> PackageName -> PackagePlan -> Action ()
-packageTarget shakeDir name plan = do
+packageTarget pb shakeDir name plan = do
     need (map (targetForPackage shakeDir)
               (M.keys (sdPackages (ppDesc plan))))
+    pwd <- liftIO getCurrentDirectory
+    env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment)
     () <- cmd (Cwd shakeDir) "cabal" "unpack" nameVer
-    () <- cmd (Cwd pkgDir) "cabal" "configure"
+    () <- cmd cwd env "cabal" "configure" (opts pwd)
-    () <- cmd (Cwd pkgDir) "cabal" "build"
+    () <- cmd cwd env "cabal" "build"
-    () <- cmd (Cwd pkgDir) "cabal" "copy"
+    () <- cmd cwd env "cabal" "copy"
-    () <- cmd (Cwd pkgDir) "cabal" "register"
+    () <- cmd cwd env "cabal" "register"
     makeFile (targetForPackage shakeDir name)
-    where pkgDir =
+    where cwd = Cwd pkgDir
+          defaultEnv pwd = [("HASKELL_PACKAGE_SANDBOX",pwd <//> targetForDb shakeDir pb)]
+          opts pwd = ["--package-db=clear"
+                     ,"--package-db=global"
+                     ,"--libdir=" ++ pwd <//> pbLibDir pb
+                     ,"--bindir=" ++ pwd <//> pbBinDir pb
+                     ,"--datadir=" ++ pwd <//> pbDataDir pb
+                     ,"--docdir=" ++ pwd <//> pbDocDir pb
+                     ,"--flags=" ++ flags] ++
+                     ["--package-db=" ++ pwd <//> targetForDb shakeDir pb
+                     |not (pbGlobalInstall pb)]
+          pkgDir =
               shakeDir <//> nameVer
           nameVer =
               display name ++
               "-" ++
               display (ppVersion plan)
+          flags = unwords $ map go $ M.toList (pcFlagOverrides (ppConstraints plan))
+                where
+                  go (name', isOn) = concat
+                      [ if isOn then "" else "-"
+                      , T.unpack (unFlagName name')
+                      ]
 
 -- | Get the target file for confirming that all packages have been
 -- pre-fetched.
-targetForFetched :: FilePattern -> FilePattern
+targetForFetched :: FilePath -> FilePath
 targetForFetched shakeDir =
     shakeDir <//> "fetched"
 
 -- | Get the target file for a package.
-targetForPackage :: FilePattern -> PackageName -> FilePattern
+targetForPackage :: FilePath -> PackageName -> FilePath
 targetForPackage shakeDir name =
     shakeDir <//> "packages" <//> display name
 
+-- | Get a package database path.
+targetForDb :: FilePath -> PerformBuild -> FilePath
+targetForDb shakeDir pb =
+    if pbGlobalInstall pb
+       then shakeDir <//> "pkgdb-global"
+       else FP.encodeString (pbInstallDest pb) <//> "pkgdb"
+
 -- | Declare a target, returning the target name.
 target :: FilePattern -> Action () -> Rules FilePattern
-target name action = do
+target name act = do
-    name *> const action
+    name *> const act
     return name
 
 -- | Make a file of this name.
 makeFile :: FilePath -> Action ()
 makeFile fp = liftIO $ writeFile fp ""
+
+pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath
+pbBinDir pb = FP.encodeString (pbInstallDest pb) <//> "bin"
+pbLibDir pb = FP.encodeString (pbInstallDest pb) <//> "lib"
+pbDataDir pb = FP.encodeString (pbInstallDest pb) <//> "share"
+pbDocDir pb = FP.encodeString (pbInstallDest pb) <//> "doc"

test/Stackage/BuildPlanSpec.hs

@@ -82,8 +82,6 @@ basicBuild getPlans _ = do
                                                           fullBuildConstraints
                                                           getPlans
                  let pb = (getPerformBuild buildFlags settings)
-                 print (pbPlan pb)
-
                  logs <- performBuild
                              pb
                  mapM_ putStrLn logs)
@@ -112,7 +110,6 @@ shakeBuild getPlans _ = do
                                               getPlans
                  let pb =
                          (getPerformBuild buildFlags settings)
-                 print (pbPlan pb)
                  Shake.performBuild pb)
     where buildType =
               Nightly