From 97949eb86ce71eb2c0adef7091c1cc63fa124bac Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 4 Dec 2014 13:17:02 +0200 Subject: [PATCH] Start of Stackage2: CorePackages --- Stackage2/CorePackages.hs | 32 +++++++++++++ Stackage2/Prelude.hs | 73 ++++++++++++++++++++++++++++++ stackage.cabal | 20 ++++++++ test/Spec.hs | 1 + test/Stackage2/CorePackagesSpec.hs | 14 ++++++ 5 files changed, 140 insertions(+) create mode 100644 Stackage2/CorePackages.hs create mode 100644 Stackage2/Prelude.hs create mode 100644 test/Spec.hs create mode 100644 test/Stackage2/CorePackagesSpec.hs diff --git a/Stackage2/CorePackages.hs b/Stackage2/CorePackages.hs new file mode 100644 index 00000000..acee6fda --- /dev/null +++ b/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 diff --git a/Stackage2/Prelude.hs b/Stackage2/Prelude.hs new file mode 100644 index 00000000..d57b5d57 --- /dev/null +++ b/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 diff --git a/stackage.cabal b/stackage.cabal index 7b0150e5..2133edbb 100644 --- a/stackage.cabal +++ b/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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Stackage2/CorePackagesSpec.hs b/test/Stackage2/CorePackagesSpec.hs new file mode 100644 index 00000000..1bf7465d --- /dev/null +++ b/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))