From f105cabe5203e9ead9de2fdeb824764d6d9f2de4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 23 Jan 2013 14:05:35 +0200 Subject: [PATCH] Error output: display Github handle when possible (fixes #22) --- Stackage/InstallInfo.hs | 8 ++++++-- Stackage/LoadDatabase.hs | 44 +++++++++++++++++++++++++++++++++------- Stackage/Types.hs | 1 + 3 files changed, 44 insertions(+), 9 deletions(-) diff --git a/Stackage/InstallInfo.hs b/Stackage/InstallInfo.hs index 1c42245a..0dfad488 100644 --- a/Stackage/InstallInfo.hs +++ b/Stackage/InstallInfo.hs @@ -41,7 +41,7 @@ getInstallInfo settings = do putStrLn "Printing build plan to build-plan.log" writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final - case checkBadVersions settings final of + case checkBadVersions settings pdb final of badVersions | Map.null badVersions -> return () | otherwise -> do @@ -85,9 +85,10 @@ iiPackageList = map packageVersionString . Map.toList . Map.map fst . iiPackages -- | Check for internal mismatches in required and actual package versions. checkBadVersions :: BuildSettings + -> PackageDB -> Map PackageName BuildInfo -> Map String (Map PackageName (Version, VersionRange)) -checkBadVersions settings buildPlan = +checkBadVersions settings (PackageDB pdb) buildPlan = Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan where unexpectedFailure name _ = name `Set.notMember` expectedFailures settings @@ -102,6 +103,9 @@ checkBadVersions settings buildPlan = [ packageVersionString (name, biVersion bi) , " (" , unMaintainer $ biMaintainer bi + , case Map.lookup name pdb of + Just PackageInfo { piGithubUser = Just gu } -> " @" ++ gu + _ -> "" , ")" ] diff --git a/Stackage/LoadDatabase.hs b/Stackage/LoadDatabase.hs index b0afb21c..58963032 100644 --- a/Stackage/LoadDatabase.hs +++ b/Stackage/LoadDatabase.hs @@ -1,10 +1,13 @@ module Stackage.LoadDatabase where import qualified Codec.Archive.Tar as Tar +import Control.Monad (guard) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.List (stripPrefix) import qualified Data.Map as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (catMaybes, listToMaybe, + mapMaybe) import Data.Monoid (Monoid (..)) import Data.Set (member) import qualified Data.Set as Set @@ -12,6 +15,9 @@ import Distribution.Compiler (CompilerFlavor (GHC)) import Distribution.Package (Dependency (Dependency)) import Distribution.PackageDescription (Condition (..), ConfVar (..), + FlagName (FlagName), + RepoType (Git), + SourceRepo (..), benchmarkBuildInfo, buildInfo, buildTools, condBenchmarks, @@ -23,13 +29,15 @@ import Distribution.PackageDescription (Condition (..), condTreeData, flagDefault, flagName, genPackageFlags, - libBuildInfo, - testBuildInfo, - FlagName (FlagName)) + homepage, libBuildInfo, + packageDescription, + sourceRepos, + testBuildInfo) import Distribution.PackageDescription.Parse (ParseResult (ParseOk), parsePackageDescription) import Distribution.System (buildArch, buildOS) -import Distribution.Version (withinRange, unionVersionRanges) +import Distribution.Version (unionVersionRanges, + withinRange) import Stackage.Config import Stackage.Types import Stackage.Util @@ -71,7 +79,7 @@ loadPackageDB settings core deps = do _ -> case Tar.entryContent e of Tar.NormalFile bs _ -> do - let (deps', hasTests, buildTools', mgpd, execs) = parseDeps bs + let (deps', hasTests, buildTools', mgpd, execs, mgithub) = parseDeps bs return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo { piVersion = v , piDeps = deps' @@ -79,6 +87,7 @@ loadPackageDB settings core deps = do , piBuildTools = buildTools' , piGPD = mgpd , piExecs = execs + , piGithubUser = mgithub } _ -> return pdb @@ -93,8 +102,11 @@ loadPackageDB settings core deps = do , Set.fromList $ map depName $ allBuildInfo gpd , Just gpd , Set.fromList $ map (Executable . fst) $ condExecutables gpd + , listToMaybe $ catMaybes + $ parseGithubUserHP (homepage $ packageDescription gpd) + : map parseGithubUserSR (sourceRepos $ packageDescription gpd) ) - _ -> (mempty, defaultHasTestSuites, Set.empty, Nothing, Set.empty) + _ -> (mempty, defaultHasTestSuites, Set.empty, Nothing, Set.empty, Nothing) where allBuildInfo gpd = concat [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd @@ -126,3 +138,21 @@ loadPackageDB settings core deps = do flags' = map flagName (filter flagDefault $ genPackageFlags gpd) ++ (map FlagName $ Set.toList $ Stackage.Types.flags settings) + +-- | Attempt to grab the Github username from a homepage. +parseGithubUserHP :: String -> Maybe String +parseGithubUserHP url1 = do + url2 <- listToMaybe $ mapMaybe (flip stripPrefix url1) + [ "http://github.com/" + , "https://github.com/" + ] + let x = takeWhile (/= '/') url2 + guard $ not $ null x + Just x + +-- | Attempt to grab the Github username from a source repo. +parseGithubUserSR :: SourceRepo -> Maybe String +parseGithubUserSR sr = + case (repoType sr, repoLocation sr) of + (Just Git, Just s) -> parseGithubUserHP s + _ -> Nothing diff --git a/Stackage/Types.hs b/Stackage/Types.hs index c39b4ab3..cb1dada9 100644 --- a/Stackage/Types.hs +++ b/Stackage/Types.hs @@ -33,6 +33,7 @@ data PackageInfo = PackageInfo , piBuildTools :: Set Executable , piGPD :: Maybe GenericPackageDescription , piExecs :: Set Executable + , piGithubUser :: Maybe String } deriving (Show, Eq)