Start of Stackage2: CorePackages

Stackage2/CorePackages.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
+module Stackage2.CorePackages
+    ( getCorePackages
+    ) where
+
+import Stackage2.Prelude
+import qualified Data.Text as T
+
+-- | Get a @Map@ of all of the core packages. Core packages are defined as
+-- packages which ship with GHC itself.
+--
+-- Precondition: GHC global package database has only core packages, and GHC
+-- ships with just a single version of each packages.
+getCorePackages :: IO (Map PackageName Version)
+getCorePackages =
+    withCheckedProcess cp $ \ClosedStream src Inherited ->
+        src $$ decodeUtf8C =$ linesUnboundedC =$ foldMapMC parsePackage
+  where
+    cp = proc "ghc-pkg" ["--no-user-package-conf", "list"]
+    parsePackage t
+        | ":" `isInfixOf` t = return mempty
+        | Just p <- stripSuffix "-" p' = singletonMap
+            <$> simpleParse p
+            <*> simpleParse v
+        | otherwise = return mempty
+      where
+        (p', v) = T.breakOnEnd "-" $ dropParens $ T.strip t
+
+        dropParens s
+            | length s > 2 && headEx s == '(' && lastEx s == ')' =
+                initEx $ tailEx s
+            | otherwise = s

Stackage2/Prelude.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE NoImplicitPrelude  #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE TypeFamilies       #-}
+module Stackage2.Prelude
+    ( module X
+    , module Stackage2.Prelude
+    ) where
+
+import           ClassyPrelude.Conduit as X
+import           Data.Conduit.Process  as X
+import           Data.Typeable         (TypeRep, typeOf)
+import           Distribution.Package  as X (PackageName (PackageName))
+import qualified Distribution.Text     as DT
+import           Distribution.Version  as X (Version (..))
+import           System.Exit           (ExitCode (ExitSuccess))
+
+unPackageName :: PackageName -> Text
+unPackageName (PackageName str) = pack str
+
+mkPackageName :: Text -> PackageName
+mkPackageName = PackageName . unpack
+
+display :: (IsString text, Element text ~ Char, DT.Text a) => a -> text
+display = fromString . DT.display
+
+simpleParse :: (MonadThrow m, DT.Text a, Typeable a, MonoFoldable text, Element text ~ Char)
+            => text -> m a
+simpleParse orig = withTypeRep $ \rep ->
+    case DT.simpleParse str of
+        Nothing -> throwM (ParseFailed rep (pack str))
+        Just v  -> return v
+  where
+    str = unpack orig
+
+    withTypeRep :: Typeable a => (TypeRep -> m a) -> m a
+    withTypeRep f =
+        res
+      where
+        res = f (typeOf (unwrap res))
+
+        unwrap :: m a -> a
+        unwrap _ = error "unwrap"
+
+data ParseFailed = ParseFailed TypeRep Text
+    deriving (Show, Typeable)
+instance Exception ParseFailed
+
+data ProcessExitedUnsuccessfully = ProcessExitedUnsuccessfully CreateProcess ExitCode
+    deriving Typeable
+instance Show ProcessExitedUnsuccessfully where
+    show (ProcessExitedUnsuccessfully cp ec) = concat
+        [ "Process exited with "
+        , show ec
+        , ": "
+        , showCmdSpec (cmdspec cp)
+        ]
+      where
+        showCmdSpec (ShellCommand str) = str
+        showCmdSpec (RawCommand x xs) = unwords (x:xs)
+instance Exception ProcessExitedUnsuccessfully
+
+checkExitCode :: MonadThrow m => CreateProcess -> ExitCode -> m ()
+checkExitCode _ ExitSuccess = return ()
+checkExitCode cp ec = throwM $ ProcessExitedUnsuccessfully cp ec
+
+-- FIXME move into streaming-commons?
+withCheckedProcess cp f = do
+    (x, y, z, sph) <- streamingProcess cp
+    res <- f x y z
+    ec <- waitForStreamingProcess sph
+    checkExitCode cp ec
+    return res

stackage.cabal

@@ -29,6 +29,9 @@ library
                        Stackage.Select
                        Stackage.GhcPkg
                        Stackage.ServerFiles
+
+                       Stackage2.Prelude
+                       Stackage2.CorePackages
   build-depends:       base >= 4 && < 5
                      , containers
                      , Cabal >= 1.14
@@ -43,6 +46,10 @@ library
                      , time
                      , utf8-string
 
+                     , conduit-extra
+                     , classy-prelude-conduit
+                     , text
+
 executable stackage
   hs-source-dirs:      app
   main-is:             stackage.hs
@@ -50,6 +57,19 @@ executable stackage
                      , stackage
                      , containers
 
+test-suite spec
+  type:                exitcode-stdio-1.0
+  default-language:    Haskell2010
+  hs-source-dirs:      test
+  main-is:             Spec.hs
+  other-modules:       Stackage2.CorePackagesSpec
+  build-depends:       base
+                     , stackage
+                     , hspec
+                     , QuickCheck
+                     , text
+                     , classy-prelude-conduit
+
 source-repository head
   type:     git
   location: https://github.com/fpco/stackage

test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

test/Stackage2/CorePackagesSpec.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
+module Stackage2.CorePackagesSpec (spec) where
+
+import Stackage2.CorePackages
+import Stackage2.Prelude
+import Test.Hspec
+
+spec :: Spec
+spec = do
+    it "works" $ void getCorePackages
+    it "contains known core packages" $ do
+        m <- getCorePackages
+        forM_ (words "ghc containers base") $ \p ->
+            m `shouldSatisfy` (member (PackageName p))