haskell/stackage
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage.git synced 2026-03-11 11:16:34 +01:00
Code Issues Actions 1 Packages Projects Releases Wiki Activity

Make a reader environment

Browse Source
This commit is contained in:
Chris Done 2015-02-17 15:23:24 +01:00
parent b6cc4f8ee0
commit bdbde2c2fb
1 changed files with 127 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

240
Stackage/ShakeBuild.hs
View File

@ -1,7 +1,9 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE ExtendedDefaultRules #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
-- | Build everything with Shake. -- | Build everything with Shake.
@ -11,7 +13,7 @@ import Stackage.BuildConstraints
import Stackage.BuildPlan import Stackage.BuildPlan
import Stackage.CheckBuildPlan import Stackage.CheckBuildPlan
import Stackage.PackageDescription import Stackage.PackageDescription
import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy,copyDir) import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy)
import Stackage.Prelude (unFlagName) import Stackage.Prelude (unFlagName)
import Control.Concurrent import Control.Concurrent
@ -32,7 +34,8 @@ import qualified Data.Set as S
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Version import Data.Version
import Development.Shake.FilePath import Development.Shake.FilePath hiding (Env)
import qualified Development.Shake.FilePath as Shake
import Distribution.Compat.ReadP import Distribution.Compat.ReadP
import Distribution.Package import Distribution.Package
import Distribution.Text (display) import Distribution.Text (display)
@ -44,6 +47,15 @@ import Prelude hiding (FilePath)
import System.Environment import System.Environment
import System.Exit import System.Exit
data Env = Env
{envCur :: FilePath
,envShake :: FilePath
,envHadLock :: TVar (Map String FilePath)
,envRegLock :: MVar ()
,envPB :: PerformBuild
,envRegistered :: [PackageIdentifier]
}
-- | Run the shake builder. -- | Run the shake builder.
performBuild :: PerformBuild -> IO () performBuild :: PerformBuild -> IO ()
performBuild pb' = do performBuild pb' = do
@ -56,55 +68,59 @@ performBuild pb' = do
let !pb = pb' let !pb = pb'
{ pbInstallDest = cur <> pbInstallDest pb' { pbInstallDest = cur <> pbInstallDest pb'
} }
cleanOldPackages pb shakeDir pkgs !env = Env
printNewPackages pb pkgs { envCur = cur
startShake 2 shakeDir (shakePlan haddockFiles registerLock pb shakeDir) , envShake = shakeDir
, envHadLock = haddockFiles
, envRegLock = registerLock
, envPB = pb
, envRegistered = pkgs
}
cleanOldPackages env
printNewPackages env
startShake 2 shakeDir (shakePlan env)
-- | The complete build plan as far as Shake is concerned. -- | The complete build plan as far as Shake is concerned.
shakePlan :: TVar (Map String FilePath) -> MVar () -> PerformBuild -> FilePath -> Rules () shakePlan :: Env -> Rules ()
shakePlan haddockFiles registerLock pb shakeDir = do shakePlan env@Env{..} = do
fetched <- target (targetForFetched shakeDir) $ fetchedTarget shakeDir pb fetched <- target (targetForFetched env) $ fetchedTarget env
db <- target (targetForDb shakeDir) $ db <- target (targetForDb env) $ databaseTarget env
databaseTarget shakeDir pb void $ forM (mapMaybe (\p -> find ((==p) . fst) versionMappings) corePackages) $
_ <- forM (mapMaybe (\p -> find ((==p) . fst) versionMappings) corePackages) $ \(name,version) ->
\(name,version) -> let fp = targetForPackage envShake name version
let fp = targetForPackage shakeDir name version in target fp (makeTargetFile fp)
in target fp (makeTargetFile fp) void $ forM normalPackages $
packageTargets <-
forM normalPackages $
\(name,plan) -> \(name,plan) ->
target (targetForPackage shakeDir name (ppVersion plan)) $ target (targetForPackage envShake name (ppVersion plan)) $
do need [db, fetched] do need [db, fetched]
packageTarget haddockFiles registerLock pb shakeDir name plan packageTarget env name plan
haddockTargets <- haddockTargets <-
forM normalPackages $ forM normalPackages $
\(name,plan) -> \(name,plan) ->
target (targetForDocs shakeDir name (ppVersion plan)) $ target (targetForDocs envShake name (ppVersion plan)) $
do need [targetForPackage shakeDir name (ppVersion plan)] do need [targetForPackage envShake name (ppVersion plan)]
packageDocs haddockFiles shakeDir pb plan name packageDocs env plan name
want haddockTargets want haddockTargets
where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb))) where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan envPB)))
corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan envPB
normalPackages = filter (not . (`elem` corePackages) . fst) $ normalPackages = filter (not . (`elem` corePackages) . fst) $
M.toList $ bpPackages $ pbPlan pb M.toList $ bpPackages $ pbPlan envPB
-- | Generate haddock docs for the package. -- | Generate haddock docs for the package.
packageDocs :: TVar (Map String FilePath) -> FilePath -> PerformBuild -> PackagePlan -> PackageName -> Action () packageDocs :: Env -> PackagePlan -> PackageName -> Action ()
packageDocs haddockFiles shakeDir pb plan name = do packageDocs env@Env{..} plan name = do
pwd <- liftIO FP.getWorkingDirectory pwd <- liftIO FP.getWorkingDirectory
env <- liftIO (fmap (Env . (++ defaultEnv pb shakeDir pwd)) getEnvironment) envmap <- liftIO (fmap (Shake.Env . (++ defaultEnv envPB envShake pwd)) getEnvironment)
when (haddocksFlag /= Don'tBuild && when (haddocksFlag /= Don'tBuild &&
not (S.null $ sdModules $ ppDesc plan)) $ not (S.null $ sdModules $ ppDesc plan)) $
generateHaddocks generateHaddocks
haddockFiles
pb
shakeDir
(pkgDir shakeDir name version)
env env
(pkgDir env name version)
envmap
name name
version version
haddocksFlag haddocksFlag
makeTargetFile (targetForDocs shakeDir name (ppVersion plan)) makeTargetFile (targetForDocs envShake name (ppVersion plan))
where version = ppVersion plan where version = ppVersion plan
haddocksFlag = pcHaddocks $ ppConstraints plan haddocksFlag = pcHaddocks $ ppConstraints plan
@ -117,99 +133,99 @@ defaultEnv pb shakeDir pwd =
-- | Initialize the database if there one needs to be, and in any case -- | Initialize the database if there one needs to be, and in any case
-- create the target file. -- create the target file.
databaseTarget :: FilePath -> PerformBuild -> Action () databaseTarget :: Env -> Action ()
databaseTarget shakeDir pb = do databaseTarget env = do
if pbGlobalInstall pb if pbGlobalInstall (envPB env)
then return () then return ()
else do else do
liftIO (FP.removeTree dir) liftIO (FP.removeTree dir)
liftIO (FP.createTree dir) liftIO (FP.createTree dir)
() <- cmd "ghc-pkg" "init" (FP.encodeString dir) () <- cmd "ghc-pkg" "init" (FP.encodeString dir)
liftIO $ copyBuiltInHaddocks $ pbDocDir pb liftIO $ copyBuiltInHaddocks $ pbDocDir (envPB env)
makeTargetFile (targetForDb shakeDir) makeTargetFile (targetForDb env)
where dir = buildDatabase shakeDir where dir = buildDatabase (envShake env)
-- | Build, test and generate documentation for the package. -- | Build, test and generate documentation for the package.
packageTarget :: TVar (Map String FilePath) -> MVar () -> PerformBuild -> FilePath -> PackageName -> PackagePlan -> Action () packageTarget :: Env -> PackageName -> PackagePlan -> Action ()
packageTarget haddockFiles registerLock pb shakeDir name plan = do packageTarget env@Env{..} name plan = do
need $ need $
map (\(name,version) -> targetForPackage shakeDir name version) $ map (\(pname,pver) -> targetForPackage envShake pname pver) $
mapMaybe (\p -> find ((==p) . fst) versionMappings) $ mapMaybe (\p -> find ((==p) . fst) versionMappings) $
filter (/= name) $ filter (/= name) $
M.keys $ M.filter libAndExe $ sdPackages $ ppDesc plan M.keys $ M.filter libAndExe $ sdPackages $ ppDesc plan
pwd <- liftIO FP.getWorkingDirectory pwd <- liftIO FP.getWorkingDirectory
env <- liftIO (fmap (Env . (++ defaultEnv pb shakeDir pwd)) getEnvironment) envmap <- liftIO (fmap (Shake.Env . (++ defaultEnv envPB envShake pwd)) getEnvironment)
unpack shakeDir name version unpack env name version
configure shakeDir dir env pb plan configure env dir envmap plan
() <- cmd cwd env "cabal" "build" "--ghc-options=-O0" () <- cmd cwd envmap "cabal" "build" "--ghc-options=-O0"
register dir env registerLock register dir envmap envRegLock
makeTargetFile (targetForPackage shakeDir name version) makeTargetFile (targetForPackage envShake name version)
where dir = pkgDir shakeDir name version where dir = pkgDir env name version
version = ppVersion plan version = ppVersion plan
versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb))) versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan envPB)))
cwd = Cwd (FP.encodeString dir) cwd = Cwd (FP.encodeString dir)
-- | Make sure all package archives have been fetched. -- | Make sure all package archives have been fetched.
fetchedTarget :: FilePath -> PerformBuild -> Action () fetchedTarget :: Env -> Action ()
fetchedTarget shakeDir pb = do fetchedTarget env@Env{..} = do
() <- cmd "cabal" "fetch" "--no-dependencies" $ () <- cmd "cabal" "fetch" "--no-dependencies" $
map map
(\(name,plan) -> display name ++ "-" ++ display (ppVersion plan)) $ (\(name,plan) -> display name ++ "-" ++ display (ppVersion plan)) $
M.toList $ bpPackages $ pbPlan pb M.toList $ bpPackages $ pbPlan envPB
makeTargetFile (targetForFetched shakeDir) makeTargetFile (targetForFetched env)
-- | Unpack the package. -- | Unpack the package.
unpack :: FilePath -> PackageName -> Version -> Action () unpack :: Env -> PackageName -> Version -> Action ()
unpack shakeDir name version = do unpack env@Env{..} name version = do
unpacked <- liftIO $ FP.isFile $ unpacked <- liftIO $ FP.isFile $
pkgDir shakeDir name version <> pkgDir env name version <>
FP.decodeString FP.decodeString
(display name ++ ".cabal") (display name ++ ".cabal")
unless unpacked $ unless unpacked $
do liftIO $ catch (FP.removeTree (pkgDir shakeDir name version)) $ do liftIO $ catch (FP.removeTree (pkgDir env name version)) $
\(_ :: IOException) -> return () \(_ :: IOException) -> return ()
cmd cmd
(Cwd (FP.encodeString (shakeDir <> "packages"))) (Cwd (FP.encodeString (envShake <> "packages")))
"cabal" "cabal"
"unpack" "unpack"
(nameVer name version) (nameVer name version)
-- | Configure the given package. -- | Configure the given package.
configure :: FilePath -> FilePath -> CmdOption -> PerformBuild -> PackagePlan -> Action () configure :: Env -> FilePath -> CmdOption -> PackagePlan -> Action ()
configure shakeDir pkgDir env pb plan = do configure Env{..} pdir env plan =
pwd <- liftIO FP.getWorkingDirectory cmd (Cwd (FP.encodeString pdir)) env "cabal" "configure" opts
cmd (Cwd (FP.encodeString pkgDir)) env "cabal" "configure" (opts pwd)
where where
opts pwd = opts =
[ "--package-db=clear" [ "--package-db=clear"
, "--package-db=global" , "--package-db=global"
, "--libdir=" ++ FP.encodeString (pbLibDir pb) , "--libdir=" ++ FP.encodeString (pbLibDir envPB)
, "--bindir=" ++ FP.encodeString (pbBinDir pb) , "--bindir=" ++ FP.encodeString (pbBinDir envPB)
, "--datadir=" ++ FP.encodeString (pbDataDir pb) , "--datadir=" ++ FP.encodeString (pbDataDir envPB)
, "--docdir=" ++ FP.encodeString (pbDocDir pb) , "--docdir=" ++ FP.encodeString (pbDocDir envPB)
, "--flags=" ++ planFlags plan] ++ , "--flags=" ++ planFlags plan] ++
["--package-db=" ++ FP.encodeString (buildDatabase shakeDir) | not (pbGlobalInstall pb)] ["--package-db=" ++ FP.encodeString (buildDatabase envShake)
| not (pbGlobalInstall envPB)]
-- | Register the package. -- | Register the package.
-- --
-- TODO: Do a mutex lock in here. Does Shake already support doing -- TODO: Do a mutex lock in here. Does Shake already support doing
-- this out of the box? -- this out of the box?
register :: FilePath -> CmdOption -> MVar () -> Action () register :: FilePath -> CmdOption -> MVar () -> Action ()
register pkgDir env registerLock = do register pdir env registerLock = do
() <- cmd cwd env "cabal" "copy" () <- cmd cwd env "cabal" "copy"
liftIO (takeMVar registerLock) liftIO (takeMVar registerLock)
() <- cmd cwd env "cabal" "register" () <- cmd cwd env "cabal" "register"
liftIO (putMVar registerLock ()) liftIO (putMVar registerLock ())
where cwd = Cwd (FP.encodeString pkgDir) where cwd = Cwd (FP.encodeString pdir)
-- | Generate haddocks for the package. -- | Generate haddocks for the package.
generateHaddocks :: TVar (Map String FilePath) -> PerformBuild -> FilePath -> FilePath -> CmdOption -> PackageName -> Version -> TestState -> Action () generateHaddocks :: Env -> FilePath -> CmdOption -> PackageName -> Version -> TestState -> Action ()
generateHaddocks haddockFiles pb shakeDir pkgDir env name version expected = do generateHaddocks env@Env{..} pdir envmap name version expected = do
hfs <- liftIO $ readTVarIO haddockFiles hfs <- liftIO $ readTVarIO envHadLock
exitCode <- exitCode <-
cmd cmd
(Cwd (FP.encodeString pkgDir)) (Cwd (FP.encodeString pdir))
env envmap
"cabal" "cabal"
"haddock" "haddock"
"--hyperlink-source" "--hyperlink-source"
@ -234,21 +250,21 @@ generateHaddocks haddockFiles pb shakeDir pkgDir env name version expected = do
ident = nameVer name version ident = nameVer name version
copy = do copy = do
liftIO $ liftIO $
do let orig = pkgDocDir shakeDir name version do let orig = pkgDocDir env name version
exists <- FP.isDirectory orig exists <- FP.isDirectory orig
when exists $ when exists $
renameOrCopy renameOrCopy
orig orig
(pbDocDir pb <> FP.decodeString ident) (pbDocDir envPB <> FP.decodeString ident)
enewPath <- enewPath <-
liftIO $ liftIO $
try $ try $
FP.canonicalizePath FP.canonicalizePath
(pbDocDir pb <> FP.decodeString ident <> (pbDocDir envPB <> FP.decodeString ident <>
FP.decodeString (display name ++ ".haddock")) FP.decodeString (display name ++ ".haddock"))
case enewPath of case enewPath of
Left (e :: IOException) -> return () -- FIXME: log it with Shake. Left (_ :: IOException) -> return () -- FIXME: log it with Shake.
Right newPath -> liftIO $ atomically $ modifyTVar haddockFiles $ Right newPath -> liftIO $ atomically $ modifyTVar envHadLock $
M.insert (ident) newPath M.insert (ident) newPath
-- | Generate a flags string for the package plan. -- | Generate a flags string for the package plan.
@ -267,23 +283,23 @@ nameVer :: PackageName -> Version -> String
nameVer name version = display name ++ "-" ++ display version nameVer name version = display name ++ "-" ++ display version
-- | The directory for the package's docs. -- | The directory for the package's docs.
pkgDocDir :: FilePath -> PackageName -> Version -> FilePath pkgDocDir :: Env -> PackageName -> Version -> FilePath
pkgDocDir shakeDir name version = pkgDir shakeDir name version <> pkgDocDir env@Env{..} name version = pkgDir env name version <>
"dist" <> "dist" <>
"doc" <> "doc" <>
"html" <> "html" <>
(FP.decodeString (display name)) (FP.decodeString (display name))
-- | The package directory. -- | The package directory.
pkgDir :: FilePath -> PackageName -> Version -> FilePath pkgDir :: Env -> PackageName -> Version -> FilePath
pkgDir shakeDir name version = shakeDir <> "packages" <> pkgDir Env{..} name version = envShake <> "packages" <>
(FP.decodeString (nameVer name version)) (FP.decodeString (nameVer name version))
-- | Get the target file for confirming that all packages have been -- | Get the target file for confirming that all packages have been
-- pre-fetched. -- pre-fetched.
targetForFetched :: FilePath -> Target targetForFetched :: Env -> Target
targetForFetched shakeDir = targetForFetched Env{..} =
Target (shakeDir <> "packages-fetched") Target (envShake <> "packages-fetched")
-- | Get the target file for a package. -- | Get the target file for a package.
targetForPackage :: FilePath -> PackageName -> Version -> Target targetForPackage :: FilePath -> PackageName -> Version -> Target
@ -308,9 +324,9 @@ targetForBuild :: PerformBuild -> Target
targetForBuild pb = Target $ (pbInstallDest pb) <> "shake-built" targetForBuild pb = Target $ (pbInstallDest pb) <> "shake-built"
-- | Get a package database path. -- | Get a package database path.
targetForDb :: FilePath -> Target targetForDb :: Env -> Target
targetForDb shakeDir = targetForDb Env{..} =
Target $ shakeDir <> "pkgdb-initialized" Target $ envShake <> "pkgdb-initialized"
-- | Make a file of this name. -- | Make a file of this name.
makeTargetFile :: Target -> Action () makeTargetFile :: Target -> Action ()
@ -329,8 +345,8 @@ data PurgeReason
| Broken | Broken
-- | Print the new packages. -- | Print the new packages.
printNewPackages :: PerformBuild -> [PackageIdentifier] -> IO (Map PackageName Version) printNewPackages :: Env -> IO ()
printNewPackages pb pkgs = do printNewPackages Env{..} = do
unless unless
(M.null new) (M.null new)
(do putStrLn (do putStrLn
@ -338,26 +354,24 @@ printNewPackages pb pkgs = do
show (M.size new) ++ show (M.size new) ++
" packages to build and install: ") " packages to build and install: ")
forM_ forM_
(take maxDisplay (M.toList new)) (map fst (take maxDisplay (M.toList new)))
(\(name,ver) -> (putStrLn . display)
putStrLn (display name))
when (M.size new > maxDisplay) when (M.size new > maxDisplay)
(putStrLn ("And " ++ show (M.size new - maxDisplay) ++ " more."))) (putStrLn ("And " ++ show (M.size new - maxDisplay) ++ " more.")))
return new
where maxDisplay = 10 where maxDisplay = 10
new = M.filterWithKey new = M.filterWithKey
(\name ver -> (\name _ ->
isNothing (find ((== name) . pkgName) pkgs)) isNothing (find ((== name) . pkgName) envRegistered))
versions versions
versions = (M.map ppVersion . versions = (M.map ppVersion .
M.filter (not . S.null . sdModules . ppDesc) . M.filter (not . S.null . sdModules . ppDesc) .
bpPackages . pbPlan) pb bpPackages . pbPlan) envPB
-- | Clean up old versions of packages that are no longer in use. -- | Clean up old versions of packages that are no longer in use.
cleanOldPackages :: PerformBuild -> FilePath -> [PackageIdentifier] -> IO () cleanOldPackages :: Env -> IO ()
cleanOldPackages pb shakeDir pkgs = do cleanOldPackages env@Env{..} = do
putStrLn "Collecting garbage" putStrLn "Collecting garbage"
pkgs <- getRegisteredPackages shakeDir pkgs <- getRegisteredPackages envShake
let toRemove = mapMaybe let toRemove = mapMaybe
(\(PackageIdentifier name version) -> (\(PackageIdentifier name version) ->
case M.lookup name versions of case M.lookup name versions of
@ -380,12 +394,12 @@ cleanOldPackages pb shakeDir pkgs = do
| version' == version -> | version' == version ->
return () return ()
Just newVersion -> purgePackage Just newVersion -> purgePackage
shakeDir env
name name
version version
(Replaced newVersion) (Replaced newVersion)
Nothing -> purgePackage shakeDir name version NoLongerIncluded Nothing -> purgePackage env name version NoLongerIncluded
broken <- getBrokenPackages shakeDir broken <- getBrokenPackages envShake
unless (null broken) unless (null broken)
(putStrLn ("There are " ++ show (length broken) ++ " broken packages to be purged.")) (putStrLn ("There are " ++ show (length broken) ++ " broken packages to be purged."))
when (length broken > 0) when (length broken > 0)
@ -394,15 +408,15 @@ cleanOldPackages pb shakeDir pkgs = do
forM_ forM_
broken broken
(\(PackageIdentifier name version) -> (\(PackageIdentifier name version) ->
purgePackage shakeDir name version Broken) purgePackage env name version Broken)
where versions = (M.map ppVersion . bpPackages . pbPlan) pb where versions = (M.map ppVersion . bpPackages . pbPlan) envPB
-- | Purge the given package and version. -- | Purge the given package and version.
purgePackage :: FilePath -> PackageName -> Version -> PurgeReason -> IO () purgePackage :: Env -> PackageName -> Version -> PurgeReason -> IO ()
purgePackage shakeDir name version reason = do purgePackage env name version reason = do
putStr $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... " putStr $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... "
unregister unregister
delete remove
putStrLn "done." putStrLn "done."
where showReason = where showReason =
case reason of case reason of
@ -415,10 +429,10 @@ purgePackage shakeDir name version reason = do
unregister = do unregister = do
void (readProcessWithExitCode void (readProcessWithExitCode
"ghc-pkg" "ghc-pkg"
["unregister", "-f", FP.encodeString (buildDatabase shakeDir), "--force", ident] ["unregister", "-f", FP.encodeString (buildDatabase (envShake env)), "--force", ident]
"") "")
delete = FP.removeTree $ remove = FP.removeTree $
pkgDir shakeDir name version pkgDir env name version
-- | Get broken packages. -- | Get broken packages.
getBrokenPackages :: FilePath -> IO [PackageIdentifier] getBrokenPackages :: FilePath -> IO [PackageIdentifier]