git.iko.soy/stackage
on master help sign in
Error output: display Github handle when possible (fixes #22)
f105cabMichael Snoyman
Stackage/InstallInfo.hs+6−2
compare with master
unifiedsplit
@@ -41,7 +41,7 @@ getInstallInfo settings = do
41 putStrLn "Printing build plan to build-plan.log"
41 putStrLn "Printing build plan to build-plan.log"
42 writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final
42 writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final
43
43
44− case checkBadVersions settings final of
44+ case checkBadVersions settings pdb final of
45 badVersions
45 badVersions
46 | Map.null badVersions -> return ()
46 | Map.null badVersions -> return ()
47 | otherwise -> do
47 | otherwise -> do
@@ -85,9 +85,10 @@ iiPackageList = map packageVersionString . Map.toList . Map.map fst . iiPackages
85
85
86-- | Check for internal mismatches in required and actual package versions.
86-- | Check for internal mismatches in required and actual package versions.
87checkBadVersions :: BuildSettings
87checkBadVersions :: BuildSettings
88+ -> PackageDB
88 -> Map PackageName BuildInfo
89 -> Map PackageName BuildInfo
89 -> Map String (Map PackageName (Version, VersionRange))
90 -> Map String (Map PackageName (Version, VersionRange))
90−checkBadVersions settings buildPlan =
91+checkBadVersions settings (PackageDB pdb) buildPlan =
91 Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan
92 Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan
92 where
93 where
93 unexpectedFailure name _ = name `Set.notMember` expectedFailures settings
94 unexpectedFailure name _ = name `Set.notMember` expectedFailures settings
@@ -102,6 +103,9 @@ checkBadVersions settings buildPlan =
102 [ packageVersionString (name, biVersion bi)
103 [ packageVersionString (name, biVersion bi)
103 , " ("
104 , " ("
104 , unMaintainer $ biMaintainer bi
105 , unMaintainer $ biMaintainer bi
106+ , case Map.lookup name pdb of
107+ Just PackageInfo { piGithubUser = Just gu } -> " @" ++ gu
108+ _ -> ""
105 , ")"
109 , ")"
106 ]
110 ]
107
111
Stackage/LoadDatabase.hs+37−7
@@ -1,10 +1,13 @@
1module Stackage.LoadDatabase where
1module Stackage.LoadDatabase where
2
2
3import qualified Codec.Archive.Tar as Tar
3import qualified Codec.Archive.Tar as Tar
4+import Control.Monad (guard)
4import qualified Data.ByteString.Lazy as L
5import qualified Data.ByteString.Lazy as L
5import qualified Data.ByteString.Lazy.Char8 as L8
6import qualified Data.ByteString.Lazy.Char8 as L8
7+import Data.List (stripPrefix)
6import qualified Data.Map as Map
8import qualified Data.Map as Map
7−import Data.Maybe (mapMaybe)
9+import Data.Maybe (catMaybes, listToMaybe,
10+ mapMaybe)
8import Data.Monoid (Monoid (..))
11import Data.Monoid (Monoid (..))
9import Data.Set (member)
12import Data.Set (member)
10import qualified Data.Set as Set
13import qualified Data.Set as Set
@@ -12,6 +15,9 @@ import Distribution.Compiler (CompilerFlavor (GHC))
12import Distribution.Package (Dependency (Dependency))
15import Distribution.Package (Dependency (Dependency))
13import Distribution.PackageDescription (Condition (..),
16import Distribution.PackageDescription (Condition (..),
14 ConfVar (..),
17 ConfVar (..),
18+ FlagName (FlagName),
19+ RepoType (Git),
20+ SourceRepo (..),
15 benchmarkBuildInfo,
21 benchmarkBuildInfo,
16 buildInfo, buildTools,
22 buildInfo, buildTools,
17 condBenchmarks,
23 condBenchmarks,
@@ -23,13 +29,15 @@ import Distribution.PackageDescription (Condition (..),
23 condTreeData,
29 condTreeData,
24 flagDefault, flagName,
30 flagDefault, flagName,
25 genPackageFlags,
31 genPackageFlags,
26− libBuildInfo,
32+ homepage, libBuildInfo,
33+ packageDescription,
34+ sourceRepos,
27− testBuildInfo,
35+ testBuildInfo)
28− FlagName (FlagName))
29import Distribution.PackageDescription.Parse (ParseResult (ParseOk),
36import Distribution.PackageDescription.Parse (ParseResult (ParseOk),
30 parsePackageDescription)
37 parsePackageDescription)
31import Distribution.System (buildArch, buildOS)
38import Distribution.System (buildArch, buildOS)
32−import Distribution.Version (withinRange, unionVersionRanges)
39+import Distribution.Version (unionVersionRanges,
40+ withinRange)
33import Stackage.Config
41import Stackage.Config
34import Stackage.Types
42import Stackage.Types
35import Stackage.Util
43import Stackage.Util
@@ -71,7 +79,7 @@ loadPackageDB settings core deps = do
71 _ ->
79 _ ->
72 case Tar.entryContent e of
80 case Tar.entryContent e of
73 Tar.NormalFile bs _ -> do
81 Tar.NormalFile bs _ -> do
74− let (deps', hasTests, buildTools', mgpd, execs) = parseDeps bs
82+ let (deps', hasTests, buildTools', mgpd, execs, mgithub) = parseDeps bs
75 return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
83 return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
76 { piVersion = v
84 { piVersion = v
77 , piDeps = deps'
85 , piDeps = deps'
@@ -79,6 +87,7 @@ loadPackageDB settings core deps = do
79 , piBuildTools = buildTools'
87 , piBuildTools = buildTools'
80 , piGPD = mgpd
88 , piGPD = mgpd
81 , piExecs = execs
89 , piExecs = execs
90+ , piGithubUser = mgithub
82 }
91 }
83 _ -> return pdb
92 _ -> return pdb
84
93
@@ -93,8 +102,11 @@ loadPackageDB settings core deps = do
93 , Set.fromList $ map depName $ allBuildInfo gpd
102 , Set.fromList $ map depName $ allBuildInfo gpd
94 , Just gpd
103 , Just gpd
95 , Set.fromList $ map (Executable . fst) $ condExecutables gpd
104 , Set.fromList $ map (Executable . fst) $ condExecutables gpd
105+ , listToMaybe $ catMaybes
106+ $ parseGithubUserHP (homepage $ packageDescription gpd)
107+ : map parseGithubUserSR (sourceRepos $ packageDescription gpd)
96 )
108 )
97− _ -> (mempty, defaultHasTestSuites, Set.empty, Nothing, Set.empty)
109+ _ -> (mempty, defaultHasTestSuites, Set.empty, Nothing, Set.empty, Nothing)
98 where
110 where
99 allBuildInfo gpd = concat
111 allBuildInfo gpd = concat
100 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd
112 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd
@@ -126,3 +138,21 @@ loadPackageDB settings core deps = do
126
138
127 flags' = map flagName (filter flagDefault $ genPackageFlags gpd) ++
139 flags' = map flagName (filter flagDefault $ genPackageFlags gpd) ++
128 (map FlagName $ Set.toList $ Stackage.Types.flags settings)
140 (map FlagName $ Set.toList $ Stackage.Types.flags settings)
141+
142+-- | Attempt to grab the Github username from a homepage.
143+parseGithubUserHP :: String -> Maybe String
144+parseGithubUserHP url1 = do
145+ url2 <- listToMaybe $ mapMaybe (flip stripPrefix url1)
146+ [ "http://github.com/"
147+ , "https://github.com/"
148+ ]
149+ let x = takeWhile (/= '/') url2
150+ guard $ not $ null x
151+ Just x
152+
153+-- | Attempt to grab the Github username from a source repo.
154+parseGithubUserSR :: SourceRepo -> Maybe String
155+parseGithubUserSR sr =
156+ case (repoType sr, repoLocation sr) of
157+ (Just Git, Just s) -> parseGithubUserHP s
158+ _ -> Nothing
Stackage/Types.hs+1
@@ -33,6 +33,7 @@ data PackageInfo = PackageInfo
33 , piBuildTools :: Set Executable
33 , piBuildTools :: Set Executable
34 , piGPD :: Maybe GenericPackageDescription
34 , piGPD :: Maybe GenericPackageDescription
35 , piExecs :: Set Executable
35 , piExecs :: Set Executable
36+ , piGithubUser :: Maybe String
36 }
37 }
37 deriving (Show, Eq)
38 deriving (Show, Eq)
38
39