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

Use PackageIdentifier

Browse Source
This commit is contained in:
Michael Snoyman 2015-03-13 08:39:50 +02:00
parent 75faf6126b
commit 351c03b881
2 changed files with 16 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Stackage/GhcPkg.hs
View File

@ -81,7 +81,7 @@ unregisterPackage :: (ByteString -> IO ()) -- ^ log func
-> FilePath -- ^ doc directory
-> [String] -> PackageIdentifier -> IO ()
unregisterPackage log' docDir flags ident@(PackageIdentifier name _) = do
log' $ "Unregistering " ++ encodeUtf8 (display ident)
log' $ "Unregistering " ++ encodeUtf8 (display ident) ++ "\n"
void (readProcessWithExitCode
"ghc-pkg"
("unregister": flags ++ ["--force", unpack $ display name])

27
Stackage/PerformBuild.hs
View File

@ -281,6 +281,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
wfd testComps (runTests withUnpacked)
pname = piName sbPackageInfo
pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo)
name = display pname
namever = concat
[ name
@ -385,7 +386,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
-- dependency's haddocks before this finishes
atomically $ putTMVar (piResult sbPackageInfo) True
prevHaddockResult <- getPreviousResult pb Haddock pname
prevHaddockResult <- getPreviousResult pb Haddock pident
let needHaddock = pbEnableHaddock
&& checkPrevResult prevHaddockResult pcHaddocks
&& not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)
@ -424,7 +425,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
$ modifyTVar sbHaddockFiles
$ insertMap namever newPath
savePreviousResult pb Haddock pname $ either (const False) (const True) eres
savePreviousResult pb Haddock pident $ either (const False) (const True) eres
case (eres, pcHaddocks) of
(Left e, ExpectSuccess) -> throwM e
(Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
@ -435,7 +436,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
runTests withUnpacked = wf testOut $ \outH -> do
let run = runChild outH
prevTestResult <- getPreviousResult pb Test pname
prevTestResult <- getPreviousResult pb Test pident
let needTest = pbEnableTests
&& checkPrevResult prevTestResult pcTests
when needTest $ withUnpacked $ do
@ -449,7 +450,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
log' $ "Test run " ++ namever
run "cabal" ["test", "--log=" ++ fpToText testRunOut]
savePreviousResult pb Test pname $ either (const False) (const True) eres
savePreviousResult pb Test pident $ either (const False) (const True) eres
case (eres, pcTests) of
(Left e, ExpectSuccess) -> throwM e
(Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
@ -501,26 +502,28 @@ data ResultType = Haddock | Test
-- | The result generated on a previous run
data PrevResult = PRNoResult | PRSuccess | PRFailure
deriving (Show, Enum, Eq, Ord, Bounded, Read)
-- | Check if we should rerun based on a PrevResult and the expected status
checkPrevResult :: PrevResult -> TestState -> Bool
checkPrevResult _ Don'tBuild = False
checkPrevResult PRNoResult _ = True
checkPrevResult PRSuccess _ = False
checkPrevResult PRFailure ExpectSuccess = True
checkPrevResult PRFailure _ = False
withPRPath :: PerformBuild -> ResultType -> PackageName -> (FilePath -> IO a) -> IO a
withPRPath pb rt (PackageName name) inner = do
withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a
withPRPath pb rt ident inner = do
createTree $ parent fp
inner fp
where
fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromString name
fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromText (display ident)
successBS, failureBS :: ByteString
successBS = "success"
failureBS = "failure"
getPreviousResult :: PerformBuild -> ResultType -> PackageName -> IO PrevResult
getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult
getPreviousResult w x y = withPRPath w x y $ \fp -> do
eres <- tryIO $ readFile fp
return $ case eres of
@ -529,12 +532,12 @@ getPreviousResult w x y = withPRPath w x y $ \fp -> do
| bs == failureBS -> PRFailure
_ -> PRNoResult
savePreviousResult :: PerformBuild -> ResultType -> PackageName -> Bool -> IO ()
savePreviousResult pb rt name res =
withPRPath pb rt name $ \fp -> writeFile fp $
savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO ()
savePreviousResult pb rt ident res =
withPRPath pb rt ident $ \fp -> writeFile fp $
if res then successBS else failureBS
deletePreviousResults :: PerformBuild -> PackageName -> IO ()
deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO ()
deletePreviousResults pb name =
forM_ [minBound..maxBound] $ \rt ->
withPRPath pb rt name $ \fp ->