Drop cycles

Stackage/CheckBuildPlan.hs

@@ -8,6 +8,7 @@
 -- | Confirm that a build plan has a consistent set of dependencies.
 module Stackage.CheckBuildPlan
     ( checkBuildPlan
+    , libAndExe
     , BadBuildPlan
     ) where
 
@@ -29,10 +30,13 @@ checkBuildPlan BuildPlan {..}
                   map (ppVersion &&& M.keys . M.filter libAndExe . sdPackages . ppDesc) bpPackages
     errs@(BadBuildPlan errs') =
         execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages
-    -- Only looking at libraries and executables, benchmarks and tests
-    -- are allowed to create cycles (e.g. test-framework depends on
-    -- text, which uses test-framework in its test-suite).
-    libAndExe (DepInfo cs _) = any (flip elem [CompLibrary,CompExecutable]) cs
+
+
+-- Only looking at libraries and executables, benchmarks and tests
+-- are allowed to create cycles (e.g. test-framework depends on
+-- text, which uses test-framework in its test-suite).
+libAndExe :: DepInfo -> Bool
+libAndExe (DepInfo cs _) = any (flip elem [CompLibrary,CompExecutable]) cs
 
 -- | For a given package name and plan, check that its dependencies are:
 --

Stackage/ShakeBuild.hs

@@ -4,9 +4,10 @@
 
 module Stackage.ShakeBuild where
 
-import           Data.Monoid
+import           Control.Concurrent.MVar
 import           Stackage.BuildConstraints
 import           Stackage.BuildPlan
+import           Stackage.CheckBuildPlan
 import           Stackage.PackageDescription
 import           Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy)
 import           Stackage.Prelude (unFlagName)
@@ -17,6 +18,7 @@ import           Control.Exception
 import           Control.Monad hiding (forM_)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
+import           Data.Monoid
 import qualified Data.Set as S
 import qualified Data.Text as T
 import           Development.Shake hiding (doesFileExist,doesDirectoryExist)
@@ -32,81 +34,94 @@ performBuild pb = do
     shakeDir <- fmap (<//> "shake/") (getCurrentDirectory >>= canonicalizePath)
     createDirectoryIfMissing True shakeDir
     haddockFiles <- liftIO (newTVarIO mempty)
-    withArgs
-        []
-        (shakeArgs
-             shakeOptions {shakeFiles = shakeDir
-                          ,shakeVerbosity = Diagnostic}
-             (shakePlan haddockFiles pb shakeDir))
+    registerLock <- liftIO (newMVar ())
+    withArgs [] $
+        shakeArgs
+            shakeOptions
+            { shakeFiles = shakeDir
+            , shakeThreads = 2
+            } $
+        shakePlan haddockFiles registerLock pb shakeDir
 
 -- | The complete build plan as far as Shake is concerned.
-shakePlan :: TVar (Map String FilePath) -> PerformBuild -> FilePath -> Rules ()
-shakePlan haddockFiles pb shakeDir = do
+shakePlan :: TVar (Map String FilePath)
+          -> MVar ()
+          -> PerformBuild
+          -> FilePath
+          -> Rules ()
+shakePlan haddockFiles registerLock pb shakeDir = do
     fetched <- target (targetForFetched shakeDir) $
                fetchedTarget shakeDir pb
-    db <- target
-              (targetForDb' shakeDir)
-              (databaseTarget shakeDir pb)
+    db <- target (targetForDb' shakeDir) $
+          databaseTarget shakeDir pb
     _ <- forM corePackages $
          \name ->
-              let fp =
-                      targetForPackage shakeDir name
+              let fp = targetForPackage shakeDir name
               in target fp (makeFile fp)
     packageTargets <- forM normalPackages $
                       \(name,plan) ->
-                           target
-                               (targetForPackage shakeDir name)
-                               (do need [db, fetched]
-                                   packageTarget haddockFiles pb shakeDir name plan)
+                           target (targetForPackage shakeDir name) $
+                           do need [db, fetched]
+                              packageTarget
+                                  haddockFiles
+                                  registerLock
+                                  pb
+                                  shakeDir
+                                  name
+                                  plan
     want packageTargets
-    where corePackages =
-              M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb
-          normalPackages =
-              filter (not . (`elem` corePackages) . fst) $
+    where corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb
+          normalPackages = 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 =
-    do if pbGlobalInstall pb
-          then return ()
-          else do liftIO (createDirectoryIfMissing True dir)
-                  liftIO (removeDirectoryRecursive dir)
-                  () <- cmd "ghc-pkg" "init" dir
-                  liftIO (copyBuiltInHaddocks (FP.decodeString (pbDocDir pb)))
-       makeFile (targetForDb' shakeDir)
-  where dir = buildDatabase pb
+databaseTarget shakeDir pb = do
+    if pbGlobalInstall pb
+        then return ()
+        else do
+            liftIO (createDirectoryIfMissing True dir)
+            liftIO (removeDirectoryRecursive dir)
+            () <- cmd "ghc-pkg" "init" dir
+            liftIO
+                (copyBuiltInHaddocks
+                     (FP.decodeString
+                          (pbDocDir pb)))
+    makeFile (targetForDb' shakeDir)
+    where dir = buildDatabase pb
 
 -- | Build, test and generate documentation for the package.
 packageTarget :: TVar (Map String FilePath)
-              -> PerformBuild -> FilePath -> PackageName -> PackagePlan
+              -> MVar ()
+              -> PerformBuild
+              -> FilePath
+              -> PackageName
+              -> PackagePlan
               -> Action ()
-packageTarget haddockFiles pb shakeDir name plan = do
-    need (map (targetForPackage shakeDir)
-              (M.keys (sdPackages (ppDesc plan))))
+packageTarget haddockFiles registerLock pb shakeDir name plan = do
+    need $
+        map (targetForPackage shakeDir) $
+        filter (/= name) $
+        M.keys $ M.filter libAndExe $ sdPackages $ ppDesc plan
     pwd <- liftIO getCurrentDirectory
     env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment)
     unpack shakeDir nameVer
     configure pkgDir env pb plan
-    () <- cmd cwd env "cabal" "build"
-    register pkgDir env
-    when (pcHaddocks (ppConstraints plan) /= Don'tBuild) $
-        (generateHaddocks haddockFiles pb pkgDir env name nameVer)
+    () <- cmd cwd env "cabal" "build" "--ghc-options=-O0"
+    register pkgDir env registerLock
     makeFile (targetForPackage shakeDir name)
-    where cwd =
-              Cwd pkgDir
-          defaultEnv pwd =
-              [ ( "HASKELL_PACKAGE_SANDBOX"
-                , pwd <//>
-                  buildDatabase pb)
-              | pbGlobalInstall pb]
+    where cwd = Cwd pkgDir
+          defaultEnv pwd = [( "HASKELL_PACKAGE_SANDBOX"
+                            , pwd <//> buildDatabase pb) | pbGlobalInstall pb]
           pkgDir = shakeDir <//> nameVer
-          nameVer =
-              display name ++
+          nameVer = display name ++
               "-" ++
               display (ppVersion plan)
 
+{-when (pcHaddocks (ppConstraints plan) /= Don'tBuild) $
+(generateHaddocks haddockFiles pb pkgDir env name nameVer)-}
+
 -- | Make sure all package archives have been fetched.
 fetchedTarget :: FilePath -> PerformBuild -> Action ()
 fetchedTarget shakeDir pb = do
@@ -115,63 +130,64 @@ fetchedTarget shakeDir pb = do
               (\(name,plan) ->
                     display name ++
                     "-" ++
-                    display (ppVersion plan))
-              (M.toList
-                   (bpPackages
-                        (pbPlan pb)))
+                    display (ppVersion plan)) $
+          M.toList $ bpPackages $ pbPlan pb
     makeFile (targetForFetched shakeDir)
 
 -- | Unpack the package.
 unpack :: FilePath -> String -> Action ()
 unpack shakeDir nameVer = do
     unpacked <- liftIO (doesDirectoryExist pkgDir)
-    unless unpacked (cmd (Cwd shakeDir) "cabal" "unpack" nameVer)
-    where pkgDir =
-              shakeDir <//> nameVer
+    unless unpacked $
+        cmd (Cwd shakeDir) "cabal" "unpack" nameVer
+    where pkgDir = shakeDir <//> nameVer
 
 -- | Configure the given package.
 configure :: FilePath -> CmdOption -> PerformBuild -> PackagePlan -> Action ()
 configure pkgDir env pb plan = do
-    configured <- liftIO
-                      (doesFileExist
-                           (pkgDir <//> "dist" <//> "setup-config"))
-    unless
-        configured
-        (do pwd <- liftIO getCurrentDirectory
-            cmd (Cwd pkgDir) env "cabal" "configure" (opts pwd))
-  where 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=" ++ planFlags plan] ++
-            ["--package-db=" ++
-             pwd <//>
-             buildDatabase pb | not (pbGlobalInstall pb)]
+    configured <- liftIO $ doesFileExist $ pkgDir <//> "dist" <//>
+                                           "setup-config"
+    unless configured $
+        do pwd <- liftIO getCurrentDirectory
+           cmd
+               (Cwd pkgDir)
+               env
+               "cabal"
+               "configure"
+               (opts pwd)
+    where 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=" ++ planFlags plan] ++
+              ["--package-db=" ++ pwd <//> buildDatabase pb | not (pbGlobalInstall pb)]
 
 -- | Register the package.
 --
 -- TODO: Do a mutex lock in here. Does Shake already support doing
 -- this out of the box?
-register :: FilePath -> CmdOption -> Action ()
-register pkgDir env =
-    do () <- cmd cwd env "cabal" "copy"
-       cmd cwd env "cabal" "register"
-  where cwd = Cwd pkgDir
+register :: FilePath -> CmdOption -> MVar () -> Action ()
+register pkgDir env registerLock = do
+    () <- cmd cwd env "cabal" "copy"
+    -- FIXME:
+    liftIO
+        (takeMVar registerLock)
+    () <- cmd cwd env "cabal" "register"
+    liftIO (putMVar registerLock ())
+    where cwd = Cwd pkgDir
 
 -- | Generate haddocks for the package.
-generateHaddocks
-    :: TVar (Map String FilePath)
-    -> PerformBuild
-    -> FilePath
-    -> CmdOption
-    -> PackageName
-    -> FilePattern
-    -> Action ()
+generateHaddocks :: TVar (Map String FilePath)
+                 -> PerformBuild
+                 -> FilePath
+                 -> CmdOption
+                 -> PackageName
+                 -> FilePattern
+                 -> Action ()
 generateHaddocks haddockFiles pb pkgDir env name nameVer = do
-    hfs <- liftIO (readTVarIO haddockFiles)
+    hfs <- liftIO $ readTVarIO haddockFiles
     () <- cmd
               (Cwd pkgDir)
               env
@@ -190,36 +206,35 @@ generateHaddocks haddockFiles pb pkgDir env name nameVer = do
                              , "/,"
                              , hf])
                    (M.toList hfs))
-    liftIO
-        (renameOrCopy
-             (FP.decodeString
-                  (pkgDir <//> "dist" <//> "doc" <//> "html" <//> display name))
-             (FP.decodeString
-                  (pbDocDir pb <//> nameVer)))
-    enewPath <- liftIO
-                    (try $
-                     canonicalizePath
-                         (pbDocDir pb <//> nameVer <//> display name ++
-                          ".haddock"))
+    liftIO $
+        renameOrCopy
+            (FP.decodeString
+                 (pkgDir <//> "dist" <//> "doc" <//> "html" <//> display name))
+            (FP.decodeString
+                 (pbDocDir pb <//> nameVer))
+    enewPath <- liftIO $
+                try $
+                canonicalizePath
+                    (pbDocDir pb <//> nameVer <//> display name ++ ".haddock")
     case enewPath of
-        Left (e :: IOException) ->
-            return () -- FIXME: log it with Shake.
-        Right newPath ->
-            liftIO
-                (atomically $
-                 modifyTVar haddockFiles $
-                 M.insert nameVer newPath)
+        Left (e :: IOException) -> return () -- FIXME: log it with Shake.
+        Right newPath -> liftIO $
+            atomically $
+            modifyTVar haddockFiles $
+            M.insert nameVer newPath
 
 -- | Generate a flags string for the package plan.
 planFlags :: PackagePlan -> String
-planFlags plan = unwords $ map go $ M.toList (pcFlagOverrides (ppConstraints plan))
-  where
-    go (name',isOn) =
-        concat
-            [ if isOn
-                  then ""
-                  else "-"
-            , T.unpack (unFlagName name')]
+planFlags plan = unwords $
+    map go $
+    M.toList
+        (pcFlagOverrides
+             (ppConstraints plan))
+    where go (name',isOn) = concat
+                  [ if isOn
+                        then ""
+                        else "-"
+                  , T.unpack (unFlagName name')]
 
 -- | Database location.
 buildDatabase :: PerformBuild -> FilePattern