Error output: display Github handle when possible (fixes #22)

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
+                _ -> ""
             , ")"
             ]
 

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,
+                                                        homepage, libBuildInfo,
-                                                        testBuildInfo,
+                                                        packageDescription,
-                                                        FlagName (FlagName))
+                                                        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

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)