haskell/stackage
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage.git synced 2026-02-15 07:45:49 +01:00
Code Issues Actions 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 -> FilePath -- ^ doc directory
-> [String] -> PackageIdentifier -> IO () -> [String] -> PackageIdentifier -> IO ()
unregisterPackage log' docDir flags ident@(PackageIdentifier name _) = do unregisterPackage log' docDir flags ident@(PackageIdentifier name _) = do
log' $ "Unregistering " ++ encodeUtf8 (display ident) log' $ "Unregistering " ++ encodeUtf8 (display ident) ++ "\n"
void (readProcessWithExitCode void (readProcessWithExitCode
"ghc-pkg" "ghc-pkg"
("unregister": flags ++ ["--force", unpack $ display name]) ("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) wfd testComps (runTests withUnpacked)
pname = piName sbPackageInfo pname = piName sbPackageInfo
pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo)
name = display pname name = display pname
namever = concat namever = concat
[ name [ name
@ -385,7 +386,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
-- dependency's haddocks before this finishes -- dependency's haddocks before this finishes
atomically $ putTMVar (piResult sbPackageInfo) True atomically $ putTMVar (piResult sbPackageInfo) True
prevHaddockResult <- getPreviousResult pb Haddock pname prevHaddockResult <- getPreviousResult pb Haddock pident
let needHaddock = pbEnableHaddock let needHaddock = pbEnableHaddock
&& checkPrevResult prevHaddockResult pcHaddocks && checkPrevResult prevHaddockResult pcHaddocks
&& not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo) && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)
@ -424,7 +425,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
$ modifyTVar sbHaddockFiles $ modifyTVar sbHaddockFiles
$ insertMap namever newPath $ 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 case (eres, pcHaddocks) of
(Left e, ExpectSuccess) -> throwM e (Left e, ExpectSuccess) -> throwM e
(Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success" (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
@ -435,7 +436,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
runTests withUnpacked = wf testOut $ \outH -> do runTests withUnpacked = wf testOut $ \outH -> do
let run = runChild outH let run = runChild outH
prevTestResult <- getPreviousResult pb Test pname prevTestResult <- getPreviousResult pb Test pident
let needTest = pbEnableTests let needTest = pbEnableTests
&& checkPrevResult prevTestResult pcTests && checkPrevResult prevTestResult pcTests
when needTest $ withUnpacked $ do when needTest $ withUnpacked $ do
@ -449,7 +450,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
log' $ "Test run " ++ namever log' $ "Test run " ++ namever
run "cabal" ["test", "--log=" ++ fpToText testRunOut] 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 case (eres, pcTests) of
(Left e, ExpectSuccess) -> throwM e (Left e, ExpectSuccess) -> throwM e
(Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success" (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
@ -501,26 +502,28 @@ data ResultType = Haddock | Test
-- | The result generated on a previous run -- | The result generated on a previous run
data PrevResult = PRNoResult | PRSuccess | PRFailure 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 -- | Check if we should rerun based on a PrevResult and the expected status
checkPrevResult :: PrevResult -> TestState -> Bool
checkPrevResult _ Don'tBuild = False checkPrevResult _ Don'tBuild = False
checkPrevResult PRNoResult _ = True checkPrevResult PRNoResult _ = True
checkPrevResult PRSuccess _ = False checkPrevResult PRSuccess _ = False
checkPrevResult PRFailure ExpectSuccess = True checkPrevResult PRFailure ExpectSuccess = True
checkPrevResult PRFailure _ = False checkPrevResult PRFailure _ = False
withPRPath :: PerformBuild -> ResultType -> PackageName -> (FilePath -> IO a) -> IO a withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a
withPRPath pb rt (PackageName name) inner = do withPRPath pb rt ident inner = do
createTree $ parent fp createTree $ parent fp
inner fp inner fp
where where
fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromString name fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromText (display ident)
successBS, failureBS :: ByteString successBS, failureBS :: ByteString
successBS = "success" successBS = "success"
failureBS = "failure" failureBS = "failure"
getPreviousResult :: PerformBuild -> ResultType -> PackageName -> IO PrevResult getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult
getPreviousResult w x y = withPRPath w x y $ \fp -> do getPreviousResult w x y = withPRPath w x y $ \fp -> do
eres <- tryIO $ readFile fp eres <- tryIO $ readFile fp
return $ case eres of return $ case eres of
@ -529,12 +532,12 @@ getPreviousResult w x y = withPRPath w x y $ \fp -> do
| bs == failureBS -> PRFailure | bs == failureBS -> PRFailure
_ -> PRNoResult _ -> PRNoResult
savePreviousResult :: PerformBuild -> ResultType -> PackageName -> Bool -> IO () savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO ()
savePreviousResult pb rt name res = savePreviousResult pb rt ident res =
withPRPath pb rt name $ \fp -> writeFile fp $ withPRPath pb rt ident $ \fp -> writeFile fp $
if res then successBS else failureBS if res then successBS else failureBS
deletePreviousResults :: PerformBuild -> PackageName -> IO () deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO ()
deletePreviousResults pb name = deletePreviousResults pb name =
forM_ [minBound..maxBound] $ \rt -> forM_ [minBound..maxBound] $ \rt ->
withPRPath pb rt name $ \fp -> withPRPath pb rt name $ \fp ->