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

Port to system-filepath

Browse Source
This commit is contained in:
Chris Done 2015-02-17 14:54:54 +01:00
parent adafabb225
commit b6cc4f8ee0
2 changed files with 174 additions and 230 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

402
Stackage/ShakeBuild.hs
View File

@ -1,11 +1,12 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExtendedDefaultRules #-}
-- | Build everything with Shake. -- | Build everything with Shake.
module Stackage.ShakeBuild where module Stackage.ShakeBuild where
import Control.Concurrent
import Control.Monad
import Stackage.BuildConstraints import Stackage.BuildConstraints
import Stackage.BuildPlan import Stackage.BuildPlan
import Stackage.CheckBuildPlan import Stackage.CheckBuildPlan
@ -13,11 +14,11 @@ import Stackage.PackageDescription
import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy,copyDir) import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy,copyDir)
import Stackage.Prelude (unFlagName) import Stackage.Prelude (unFlagName)
import Control.Concurrent.MVar import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import Control.Exception import Control.Exception
import Control.Monad hiding (forM_) import Control.Monad
import Control.Monad.IO.Class
import Data.Conduit import Data.Conduit
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import Data.Conduit.Process import Data.Conduit.Process
@ -30,114 +31,89 @@ import Data.Monoid
import qualified Data.Set as S 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 qualified Data.Text.Encoding as T
import Data.Version import Data.Version
import Development.Shake hiding (doesFileExist,doesDirectoryExist) import Development.Shake.FilePath
import Distribution.Compat.ReadP import Distribution.Compat.ReadP
import Distribution.Package import Distribution.Package
import Distribution.Package (PackageName)
import Distribution.Text (display) import Distribution.Text (display)
import Distribution.Text (parse) import Distribution.Text (parse)
import qualified Filesystem as FP
import Filesystem.Path.CurrentOS (FilePath)
import qualified Filesystem.Path.CurrentOS as FP import qualified Filesystem.Path.CurrentOS as FP
import System.Directory import Prelude hiding (FilePath)
import System.Environment import System.Environment
import System.Exit import System.Exit
-- | Run the shake builder. -- | Run the shake builder.
performBuild :: PerformBuild -> IO () performBuild :: PerformBuild -> IO ()
performBuild pb = do performBuild pb' = do
shakeDir <- fmap (<//> "shake/") (getCurrentDirectory >>= canonicalizePath) cur <- FP.getWorkingDirectory
createDirectoryIfMissing True shakeDir let shakeDir = cur <> "shake/"
FP.createTree shakeDir
haddockFiles <- liftIO (newTVarIO mempty) haddockFiles <- liftIO (newTVarIO mempty)
registerLock <- liftIO (newMVar ()) registerLock <- liftIO (newMVar ())
pkgs <- getRegisteredPackages shakeDir pkgs <- getRegisteredPackages shakeDir
let !pb = pb'
{ pbInstallDest = cur <> pbInstallDest pb'
}
cleanOldPackages pb shakeDir pkgs cleanOldPackages pb shakeDir pkgs
printNewPackages pb pkgs printNewPackages pb pkgs
withArgs [] $ startShake 2 shakeDir (shakePlan haddockFiles registerLock pb shakeDir)
shakeArgs
shakeOptions
{ shakeFiles = shakeDir
, shakeThreads = 2
} $
shakePlan haddockFiles registerLock pb shakeDir
-- | 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) shakePlan :: TVar (Map String FilePath) -> MVar () -> PerformBuild -> FilePath -> Rules ()
-> MVar ()
-> PerformBuild
-> FilePath
-> Rules ()
shakePlan haddockFiles registerLock pb shakeDir = do shakePlan haddockFiles registerLock pb shakeDir = do
fetched <- target (targetForFetched shakeDir) $ fetched <- target (targetForFetched shakeDir) $ fetchedTarget shakeDir pb
fetchedTarget shakeDir pb
db <- target (targetForDb shakeDir) $ db <- target (targetForDb shakeDir) $
databaseTarget shakeDir pb databaseTarget shakeDir pb
_ <- forM (mapMaybe (\p -> find ((==p) . fst) versionMappings) corePackages) $ _ <- forM (mapMaybe (\p -> find ((==p) . fst) versionMappings) corePackages) $
\(name,version) -> \(name,version) ->
let fp = targetForPackage shakeDir name version let fp = targetForPackage shakeDir name version
in target fp (makeFile fp) in target fp (makeTargetFile fp)
packageTargets <- forM normalPackages $ packageTargets <-
\(name,plan) -> forM normalPackages $
target (targetForPackage shakeDir name (ppVersion plan)) $ \(name,plan) ->
do need [db, fetched] target (targetForPackage shakeDir name (ppVersion plan)) $
packageTarget do need [db, fetched]
haddockFiles packageTarget haddockFiles registerLock pb shakeDir name plan
registerLock haddockTargets <-
pb forM normalPackages $
shakeDir \(name,plan) ->
name target (targetForDocs shakeDir name (ppVersion plan)) $
plan do need [targetForPackage shakeDir name (ppVersion plan)]
haddockTargets <- forM normalPackages $ packageDocs haddockFiles shakeDir pb plan name
\(name,plan) ->
target (targetForDocs shakeDir name (ppVersion plan)) $
do need [targetForPackage shakeDir name (ppVersion plan)]
packageDocs haddockFiles shakeDir pb plan name
build <- target (targetForBuild pb)
(do need haddockTargets
copyToBuild pb shakeDir)
want haddockTargets want haddockTargets
want [build]
where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb))) where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb)))
corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb
normalPackages = filter (not . (`elem` corePackages) . fst) $ normalPackages = filter (not . (`elem` corePackages) . fst) $
M.toList $ bpPackages $ pbPlan pb M.toList $ bpPackages $ pbPlan pb
-- | Copy the build as a whole to builds/.
copyToBuild :: PerformBuild -> String -> Action ()
copyToBuild pb shakeDir = do
liftIO (putStrLn ("Copying snapshot to " ++ FP.encodeString (pbInstallDest pb)))
copy pbBinDir
copy pbLibDir
copy pbDataDir
copy pbDocDir
makeFile (targetForBuild pb)
where copy mkPath = liftIO $
do putStrLn ("Copying " ++ mkPath shakeDir)
copyDir
here
there
where here = (FP.decodeString $ mkPath shakeDir)
there = (FP.decodeString $ mkPath $ FP.encodeString $ pbInstallDest pb)
-- | Generate haddock docs for the package. -- | Generate haddock docs for the package.
packageDocs :: TVar (Map String FilePath) packageDocs :: TVar (Map String FilePath) -> FilePath -> PerformBuild -> PackagePlan -> PackageName -> Action ()
-> FilePattern
-> PerformBuild
-> PackagePlan
-> PackageName
-> Action ()
packageDocs haddockFiles shakeDir pb plan name = do packageDocs haddockFiles shakeDir pb plan name = do
pwd <- liftIO getCurrentDirectory pwd <- liftIO FP.getWorkingDirectory
env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment) env <- liftIO (fmap (Env . (++ defaultEnv pb shakeDir pwd)) getEnvironment)
when when (haddocksFlag /= Don'tBuild &&
(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 name version haddocksFlag haddockFiles
makeFile (targetForDocs shakeDir name (ppVersion plan)) pb
shakeDir
(pkgDir shakeDir name version)
env
name
version
haddocksFlag
makeTargetFile (targetForDocs shakeDir name (ppVersion plan))
where version = ppVersion plan where version = ppVersion plan
haddocksFlag = pcHaddocks $ ppConstraints plan haddocksFlag = pcHaddocks $ ppConstraints plan
defaultEnv pwd = [( "HASKELL_PACKAGE_SANDBOX"
, pwd <//> buildDatabase shakeDir) | pbGlobalInstall pb] -- | Default environment for running commands.
defaultEnv :: PerformBuild -> FilePath -> FilePath -> [(String, String)]
defaultEnv pb shakeDir pwd =
[( "HASKELL_PACKAGE_SANDBOX"
, FP.encodeString (pwd <> buildDatabase shakeDir))
| pbGlobalInstall pb]
-- | 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.
@ -146,68 +122,54 @@ databaseTarget shakeDir pb = do
if pbGlobalInstall pb if pbGlobalInstall pb
then return () then return ()
else do else do
liftIO (createDirectoryIfMissing True dir) liftIO (FP.removeTree dir)
liftIO (removeDirectoryRecursive dir) liftIO (FP.createTree dir)
() <- cmd "ghc-pkg" "init" dir () <- cmd "ghc-pkg" "init" (FP.encodeString dir)
liftIO $ copyBuiltInHaddocks $ FP.decodeString $ pbDocDir shakeDir liftIO $ copyBuiltInHaddocks $ pbDocDir pb
makeFile (targetForDb shakeDir) makeTargetFile (targetForDb shakeDir)
where dir = buildDatabase shakeDir where dir = buildDatabase shakeDir
-- | Build, test and generate documentation for the package. -- | Build, test and generate documentation for the package.
packageTarget :: TVar (Map String FilePath) packageTarget :: TVar (Map String FilePath) -> MVar () -> PerformBuild -> FilePath -> PackageName -> PackagePlan -> Action ()
-> MVar ()
-> PerformBuild
-> FilePath
-> PackageName
-> PackagePlan
-> Action ()
packageTarget haddockFiles registerLock pb shakeDir name plan = do packageTarget haddockFiles registerLock pb shakeDir name plan = do
need $ need $
map (\(name,version) -> targetForPackage shakeDir name version) $ map (\(name,version) -> targetForPackage shakeDir name version) $
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 getCurrentDirectory pwd <- liftIO FP.getWorkingDirectory
env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment) env <- liftIO (fmap (Env . (++ defaultEnv pb shakeDir pwd)) getEnvironment)
unpack shakeDir name version unpack shakeDir name version
configure shakeDir dir env pb plan configure shakeDir dir env pb plan
() <- cmd cwd env "cabal" "build" "--ghc-options=-O0" () <- cmd cwd env "cabal" "build" "--ghc-options=-O0"
register dir env registerLock register dir env registerLock
makeFile (targetForPackage shakeDir name version) makeTargetFile (targetForPackage shakeDir name version)
where dir = pkgDir shakeDir name version where dir = pkgDir shakeDir 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 pb)))
cwd = Cwd dir cwd = Cwd (FP.encodeString dir)
defaultEnv pwd = [( "HASKELL_PACKAGE_SANDBOX"
, pwd <//> buildDatabase shakeDir) | pbGlobalInstall pb]
-- | Make sure all package archives have been fetched. -- | Make sure all package archives have been fetched.
fetchedTarget :: FilePath -> PerformBuild -> Action () fetchedTarget :: FilePath -> PerformBuild -> Action ()
fetchedTarget shakeDir pb = do fetchedTarget shakeDir pb = do
() <- cmd "cabal" "fetch" "--no-dependencies" $ () <- cmd "cabal" "fetch" "--no-dependencies" $
map map
(\(name,plan) -> (\(name,plan) -> display name ++ "-" ++ display (ppVersion plan)) $
display name ++
"-" ++
display (ppVersion plan)) $
M.toList $ bpPackages $ pbPlan pb M.toList $ bpPackages $ pbPlan pb
makeFile (targetForFetched shakeDir) makeTargetFile (targetForFetched shakeDir)
-- | Unpack the package. -- | Unpack the package.
unpack :: FilePath -> PackageName -> Version -> Action () unpack :: FilePath -> PackageName -> Version -> Action ()
unpack shakeDir name version = do unpack shakeDir name version = do
unpacked <- liftIO $ unpacked <- liftIO $ FP.isFile $
doesFileExist $ pkgDir shakeDir name version <>
pkgDir shakeDir name version <//> FP.decodeString
display name ++ (display name ++ ".cabal")
".cabal"
unless unpacked $ unless unpacked $
do liftIO $ do liftIO $ catch (FP.removeTree (pkgDir shakeDir name version)) $
catch (removeDirectoryRecursive (pkgDir shakeDir name version)) $ \(_ :: IOException) -> return ()
\(_ :: IOException) ->
return ()
cmd cmd
(Cwd (shakeDir <//> "packages")) (Cwd (FP.encodeString (shakeDir <> "packages")))
"cabal" "cabal"
"unpack" "unpack"
(nameVer name version) (nameVer name version)
@ -215,21 +177,18 @@ unpack shakeDir name version = do
-- | Configure the given package. -- | Configure the given package.
configure :: FilePath -> FilePath -> CmdOption -> PerformBuild -> PackagePlan -> Action () configure :: FilePath -> FilePath -> CmdOption -> PerformBuild -> PackagePlan -> Action ()
configure shakeDir pkgDir env pb plan = do configure shakeDir pkgDir env pb plan = do
pwd <- liftIO getCurrentDirectory pwd <- liftIO FP.getWorkingDirectory
cmd cmd (Cwd (FP.encodeString pkgDir)) env "cabal" "configure" (opts pwd)
(Cwd pkgDir) where
env opts pwd =
"cabal" [ "--package-db=clear"
"configure" , "--package-db=global"
(opts pwd) , "--libdir=" ++ FP.encodeString (pbLibDir pb)
where opts pwd = [ "--package-db=clear" , "--bindir=" ++ FP.encodeString (pbBinDir pb)
, "--package-db=global" , "--datadir=" ++ FP.encodeString (pbDataDir pb)
, "--libdir=" ++ pbLibDir shakeDir , "--docdir=" ++ FP.encodeString (pbDocDir pb)
, "--bindir=" ++ pbBinDir shakeDir , "--flags=" ++ planFlags plan] ++
, "--datadir=" ++ pbDataDir shakeDir ["--package-db=" ++ FP.encodeString (buildDatabase shakeDir) | not (pbGlobalInstall pb)]
, "--docdir=" ++ pbDocDir shakeDir
, "--flags=" ++ planFlags plan] ++
["--package-db=" ++ buildDatabase shakeDir | not (pbGlobalInstall pb)]
-- | Register the package. -- | Register the package.
-- --
@ -238,86 +197,70 @@ configure shakeDir pkgDir env pb plan = do
register :: FilePath -> CmdOption -> MVar () -> Action () register :: FilePath -> CmdOption -> MVar () -> Action ()
register pkgDir env registerLock = do register pkgDir env registerLock = do
() <- cmd cwd env "cabal" "copy" () <- cmd cwd env "cabal" "copy"
-- FIXME: 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 pkgDir where cwd = Cwd (FP.encodeString pkgDir)
-- | Generate haddocks for the package. -- | Generate haddocks for the package.
generateHaddocks :: TVar (Map String FilePath) generateHaddocks :: TVar (Map String FilePath) -> PerformBuild -> FilePath -> FilePath -> CmdOption -> PackageName -> Version -> TestState -> Action ()
-> PerformBuild
-> FilePath
-> FilePath
-> CmdOption
-> PackageName
-> Version
-> TestState
-> Action ()
generateHaddocks haddockFiles pb shakeDir pkgDir env name version expected = do generateHaddocks haddockFiles pb shakeDir pkgDir env name version expected = do
hfs <- liftIO $ readTVarIO haddockFiles hfs <- liftIO $ readTVarIO haddockFiles
exitCode <- cmd exitCode <-
(Cwd pkgDir) cmd
env (Cwd (FP.encodeString pkgDir))
"cabal" env
"haddock" "cabal"
"--hyperlink-source" "haddock"
"--html" "--hyperlink-source"
"--hoogle" "--html"
"--html-location=../$pkg-$version/" "--hoogle"
(map "--html-location=../$pkg-$version/"
(\(pkgVer,hf) -> (map
concat (\(pkgVer,hf) ->
[ "--haddock-options=--read-interface=" concat
, "../" [ "--haddock-options=--read-interface="
, pkgVer , "../"
, "/," , pkgVer
, hf]) , "/,"
(M.toList hfs)) , FP.encodeString hf])
(M.toList hfs))
case (exitCode, expected) of case (exitCode, expected) of
(ExitSuccess,ExpectFailure) -> return () -- FIXME: warn. (ExitSuccess,ExpectFailure) -> return () -- FIXME: warn.
(ExitFailure{},ExpectSuccess) -> throw exitCode -- FIXME: report it (ExitFailure{},ExpectSuccess) -> throw exitCode -- FIXME: report it
_ -> return () _ -> return ()
copy copy
where ident = nameVer name version where
copy = do ident = nameVer name version
liftIO $ copy = do
do let orig = pkgDocDir shakeDir name version liftIO $
exists <- doesDirectoryExist orig do let orig = pkgDocDir shakeDir name version
when exists $ exists <- FP.isDirectory orig
renameOrCopy when exists $
(FP.decodeString orig) renameOrCopy
(FP.decodeString orig
(pbDocDir shakeDir <//> ident)) (pbDocDir pb <> FP.decodeString ident)
enewPath <- liftIO $ enewPath <-
try $ liftIO $
canonicalizePath try $
(pbDocDir shakeDir <//> ident <//> display name ++ FP.canonicalizePath
".haddock") (pbDocDir pb <> FP.decodeString ident <>
case enewPath of FP.decodeString (display name ++ ".haddock"))
Left (e :: IOException) -> return () -- FIXME: log it with Shake. case enewPath of
Right newPath -> liftIO $ Left (e :: IOException) -> return () -- FIXME: log it with Shake.
atomically $ Right newPath -> liftIO $ atomically $ modifyTVar haddockFiles $
modifyTVar haddockFiles $ M.insert (ident) newPath
M.insert (ident) newPath
-- | Generate a flags string for the package plan. -- | Generate a flags string for the package plan.
planFlags :: PackagePlan -> String planFlags :: PackagePlan -> String
planFlags plan = unwords $ planFlags plan = unwords $
map go $ map go $ M.toList (pcFlagOverrides (ppConstraints plan))
M.toList
(pcFlagOverrides
(ppConstraints plan))
where go (name',isOn) = concat where go (name',isOn) = concat
[ if isOn [ if isOn then "" else "-" , T.unpack (unFlagName name')]
then ""
else "-"
, T.unpack (unFlagName name')]
-- | Database location. -- | Database location.
buildDatabase :: FilePath -> FilePattern buildDatabase :: FilePath -> FilePath
buildDatabase shakeDir = shakeDir <//> "pkgdb" buildDatabase shakeDir = shakeDir <> "pkgdb"
-- | Print the name and version. -- | Print the name and version.
nameVer :: PackageName -> Version -> String nameVer :: PackageName -> Version -> String
@ -325,57 +268,59 @@ 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 :: FilePath -> PackageName -> Version -> FilePath
pkgDocDir shakeDir name version = pkgDir shakeDir name version <//> pkgDocDir shakeDir name version = pkgDir shakeDir name version <>
"dist" <//> "dist" <>
"doc" <//> "doc" <>
"html" <//> "html" <>
(display name) (FP.decodeString (display name))
-- | The package directory. -- | The package directory.
pkgDir :: FilePath -> PackageName -> Version -> FilePath pkgDir :: FilePath -> PackageName -> Version -> FilePath
pkgDir shakeDir name version = shakeDir <//> "packages" <//> pkgDir shakeDir name version = shakeDir <> "packages" <>
(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 -> FilePath targetForFetched :: FilePath -> Target
targetForFetched shakeDir = targetForFetched shakeDir =
shakeDir <//> "packages-fetched" Target (shakeDir <> "packages-fetched")
-- | Get the target file for a package. -- | Get the target file for a package.
targetForPackage :: FilePath -> PackageName -> Version -> FilePath targetForPackage :: FilePath -> PackageName -> Version -> Target
targetForPackage shakeDir name version = targetForPackage shakeDir name version = Target $
shakeDir <//> "packages" <//> nameVer name version <//> "dist" <//> "shake-build" shakeDir <> "packages" <>
FP.decodeString
(nameVer name version) <>
"dist" <>
"shake-build"
-- | Get the target file for a package. -- | Get the target file for a package.
targetForDocs :: FilePath -> PackageName -> Version -> FilePath targetForDocs :: FilePath -> PackageName -> Version -> Target
targetForDocs shakeDir name version = targetForDocs shakeDir name version = Target $
shakeDir <//> "packages" <//> nameVer name version <//> "dist" <//> "shake-docs" shakeDir <> "packages" <>
FP.decodeString
(nameVer name version) <>
"dist" <>
"shake-docs"
-- | Target for the complete, copied build under builds/date/. -- | Target for the complete, copied build under builds/date/.
targetForBuild :: PerformBuild -> FilePattern targetForBuild :: PerformBuild -> Target
targetForBuild pb = FP.encodeString (pbInstallDest pb) <//> "shake-built" targetForBuild pb = Target $ (pbInstallDest pb) <> "shake-built"
-- | Get a package database path. -- | Get a package database path.
targetForDb :: FilePath -> FilePath targetForDb :: FilePath -> Target
targetForDb shakeDir = targetForDb shakeDir =
shakeDir <//> "pkgdb-initialized" Target $ shakeDir <> "pkgdb-initialized"
-- | Declare a target, returning the target name.
target :: FilePattern -> Action () -> Rules FilePattern
target name act = do
name *> const act
return name
-- | Make a file of this name. -- | Make a file of this name.
makeFile :: FilePath -> Action () makeTargetFile :: Target -> Action ()
makeFile fp = liftIO $ writeFile fp "" makeTargetFile fp = liftIO $ FP.writeFile (unTarget fp) ""
pbBinDir, pbLibDir, pbDataDir, pbDocDir :: FilePath -> FilePath pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath
pbBinDir shakeDir = shakeDir <//> "bin" pbBinDir root = (pbInstallDest root) <> "bin"
pbLibDir shakeDir = shakeDir <//> "lib" pbLibDir root = (pbInstallDest root) <> "lib"
pbDataDir shakeDir = shakeDir <//> "share" pbDataDir root = (pbInstallDest root) <> "share"
pbDocDir shakeDir = shakeDir <//> "doc" pbDocDir root = (pbInstallDest root) <> "doc"
-- | Reason for purging a package. -- | Reason for purging a package.
data PurgeReason data PurgeReason
@ -423,7 +368,6 @@ cleanOldPackages pb shakeDir pkgs = do
(name, version, (Replaced newVersion)) (name, version, (Replaced newVersion))
Nothing -> Just (name, version, NoLongerIncluded)) Nothing -> Just (name, version, NoLongerIncluded))
pkgs pkgs
unless (null toRemove) unless (null toRemove)
(putStrLn ("There are " ++ show (length toRemove) ++ " packages to be purged.")) (putStrLn ("There are " ++ show (length toRemove) ++ " packages to be purged."))
when (length toRemove > 0) when (length toRemove > 0)
@ -471,18 +415,18 @@ purgePackage shakeDir name version reason = do
unregister = do unregister = do
void (readProcessWithExitCode void (readProcessWithExitCode
"ghc-pkg" "ghc-pkg"
["unregister", "-f", buildDatabase shakeDir, "--force", ident] ["unregister", "-f", FP.encodeString (buildDatabase shakeDir), "--force", ident]
"") "")
delete = removeDirectoryRecursive $ delete = FP.removeTree $
pkgDir shakeDir name version pkgDir shakeDir name version
-- | Get broken packages. -- | Get broken packages.
getBrokenPackages :: FilePath -> IO [PackageIdentifier] getBrokenPackages :: FilePath -> IO [PackageIdentifier]
getBrokenPackages shakeDir = do getBrokenPackages shakeDir = do
(_,ps) <- sourceProcessWithConsumer (_,ps) <- sourceProcessWithConsumer
(proc' (proc
"ghc-pkg" "ghc-pkg"
["check", "--simple-output", "-f", buildDatabase shakeDir]) ["check", "--simple-output", "-f", FP.encodeString (buildDatabase shakeDir)])
(CT.decodeUtf8 $= CT.lines $= CL.consume) (CT.decodeUtf8 $= CT.lines $= CL.consume)
return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) return (mapMaybe parsePackageIdent (T.words (T.unlines ps)))
@ -490,9 +434,9 @@ getBrokenPackages shakeDir = do
getRegisteredPackages :: FilePath -> IO [PackageIdentifier] getRegisteredPackages :: FilePath -> IO [PackageIdentifier]
getRegisteredPackages shakeDir = do getRegisteredPackages shakeDir = do
(_,ps) <- sourceProcessWithConsumer (_,ps) <- sourceProcessWithConsumer
(proc' (proc
"ghc-pkg" "ghc-pkg"
["list", "--simple-output", "-f", buildDatabase shakeDir]) ["list", "--simple-output", "-f", FP.encodeString (buildDatabase shakeDir)])
(CT.decodeUtf8 $= CT.lines $= CL.consume) (CT.decodeUtf8 $= CT.lines $= CL.consume)
return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) return (mapMaybe parsePackageIdent (T.words (T.unlines ps)))
@ -502,5 +446,3 @@ parsePackageIdent = fmap fst .
listToMaybe . listToMaybe .
filter (null . snd) . filter (null . snd) .
readP_to_S parse . T.unpack readP_to_S parse . T.unpack
proc' = proc

2
stackage.cabal
View File

@ -31,6 +31,8 @@ library
Stackage.PerformBuild Stackage.PerformBuild
Stackage.ShakeBuild Stackage.ShakeBuild
Stackage.CompleteBuild Stackage.CompleteBuild
other-modules:
Development.Shake.FilePath
build-depends: build-depends:
Cabal >= 1.14 Cabal >= 1.14
, aeson , aeson