4be1358 · stackage · git.iko.soy

.gitignore+1

compare with master

unifiedsplit

@@ -6,3 +6,4 @@ cabal-dev

6*.chs.h

7.virthualenv

8*.swp

9+runtests/

Stackage/Build.hsnew file+30

@@ -0,0 +1,30 @@

1+module Stackage.Build

2+ ( build

3+ ) where

4+

5+import Control.Monad (unless)

6+import Stackage.CheckPlan

7+import Stackage.Test

8+import Stackage.Util

9+import Stackage.InstallInfo

10+import System.Process (waitForProcess, runProcess)

11+import System.Exit (ExitCode (ExitSuccess), exitWith)

12+import System.IO (IOMode (WriteMode), withBinaryFile)

13+

14+build :: IO ()

15+build = do

16+ ii <- getInstallInfo

17+ checkPlan ii

18+

19+ rm_r "cabal-dev"

20+

21+ putStrLn "No mismatches, good to go!"

22+

23+ ph <- withBinaryFile "build.log" WriteMode $ \handle ->

24+ runProcess "cabal-dev" ("install":"-fnetwork23":iiPackageList ii) Nothing Nothing Nothing (Just handle) (Just handle)

25+ ec <- waitForProcess ph

26+ unless (ec == ExitSuccess) $ exitWith ec

27+

28+ putStrLn "Environment built, beginning individual test suites"

29+

30+ runTestSuites ii

Stackage/CheckPlan.hsnew file+35

@@ -0,0 +1,35 @@

1+module Stackage.CheckPlan

2+ ( checkPlan

3+ ) where

4+

5+import Control.Monad (unless)

6+import Data.List (sort)

7+import Stackage.Types

8+import Stackage.InstallInfo

9+import System.Process (readProcess)

10+import System.Exit (ExitCode (ExitFailure), exitWith)

11+

12+data Mismatch = OnlyDryRun String | OnlySimpleList String

13+ deriving Show

14+

15+checkPlan :: InstallInfo -> IO ()

16+checkPlan ii = do

17+ dryRun' <- readProcess "cabal-dev" ("install":"--dry-run":"-fnetwork23":iiPackageList ii) ""

18+ let dryRun = sort $ drop 2 $ lines dryRun'

19+ let mismatches = getMismatches dryRun (iiPackageList ii)

20+ unless (null mismatches) $ do

21+ putStrLn "Found the following mismtaches"

22+ mapM_ print mismatches

23+ exitWith $ ExitFailure 1

24+

25+getMismatches :: [String] -> [String] -> [Mismatch]

26+getMismatches =

27+ go

28+ where

29+ go [] y = map OnlySimpleList y

30+ go x [] = map OnlyDryRun x

31+ go (x:xs) (y:ys) =

32+ case compare x y of

33+ EQ -> go xs ys

34+ LT -> OnlyDryRun x : go xs (y:ys)

35+ GT -> OnlySimpleList y : go (x:xs) ys

Stackage/Config.hs−1

@@ -6,7 +6,6 @@ import Control.Monad.Trans.Writer (execWriter, tell)

6import Data.Set (singleton, fromList)

7import Control.Monad (when, unless)

8import Distribution.System (OS (..), buildOS)

9−import Distribution.Version (anyVersion)

10import Distribution.Text (simpleParse)

9import Distribution.Text (simpleParse)

11

10

12-- | Packages which are shipped with GHC but are not included in the

11-- | Packages which are shipped with GHC but are not included in the

Stackage/InstallInfo.hsnew file+28

@@ -0,0 +1,28 @@

1+module Stackage.InstallInfo

2+ ( getInstallInfo

3+ , iiPackageList

4+ ) where

5+

6+import Stackage.Types

7+import Stackage.Util

8+import Stackage.Config

9+import Stackage.LoadDatabase

10+import Stackage.NarrowDatabase

11+import Stackage.HaskellPlatform

12+import qualified Data.Map as Map

13+import qualified Data.Set as Set

14+

15+getInstallInfo :: IO InstallInfo

16+getInstallInfo = do

17+ hp <- loadHaskellPlatform

18+ let allPackages = Map.union stablePackages $ identsToRanges (hplibs hp)

19+ let totalCore = extraCore `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp)

20+ pdb <- loadPackageDB totalCore allPackages

21+ final <- narrowPackageDB pdb $ Set.fromList $ Map.keys allPackages

22+ return InstallInfo

23+ { iiCore = totalCore

24+ , iiPackages = final

25+ }

26+

27+iiPackageList :: InstallInfo -> [String]

28+iiPackageList = map packageVersionString . Map.toList . iiPackages

Stackage/Test.hsnew file+60

@@ -0,0 +1,60 @@

1+module Stackage.Test

2+ ( runTestSuites

3+ ) where

4+

5+import Control.Monad (when, foldM)

6+import qualified Data.Map as Map

7+import qualified Data.Set as Set

8+import Stackage.Types

9+import Stackage.Util

10+import Stackage.Config

11+import System.Directory (removeFile, createDirectory)

12+import System.Process (waitForProcess, runProcess)

13+import System.Exit (ExitCode (ExitSuccess))

14+import System.FilePath ((</>), (<.>))

15+import System.IO (IOMode (WriteMode, AppendMode), withBinaryFile)

16+

17+runTestSuites :: InstallInfo -> IO ()

18+runTestSuites ii = do

19+ let testdir = "runtests"

20+ rm_r testdir

21+ createDirectory testdir

22+ allPass <- foldM (runTestSuite testdir) True $ Map.toList $ iiPackages ii

23+ if allPass

24+ then putStrLn "All test suites that were expected to pass did pass"

25+ else error $ "There were failures, please see the logs in " ++ testdir

26+

27+runTestSuite :: FilePath -> Bool -> (PackageName, Version) -> IO Bool

28+runTestSuite testdir prevPassed pair@(packageName, _) = do

29+ passed <- do

30+ ph1 <- getHandle WriteMode $ \handle -> runProcess "cabal" ["unpack", package] (Just testdir) Nothing Nothing (Just handle) (Just handle)

31+ ec1 <- waitForProcess ph1

32+ if (ec1 /= ExitSuccess)

33+ then return False

34+ else do

35+ ph2 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["-s", "../../cabal-dev", "configure", "--enable-tests"] (Just dir) Nothing Nothing (Just handle) (Just handle)

36+ ec2 <- waitForProcess ph2

37+ if (ec2 /= ExitSuccess)

38+ then return False

39+ else do

40+ ph3 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["build"] (Just dir) Nothing Nothing (Just handle) (Just handle)

41+ ec3 <- waitForProcess ph3

42+ if (ec3 /= ExitSuccess)

43+ then return False

44+ else do

45+ ph4 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["test"] (Just dir) Nothing Nothing (Just handle) (Just handle)

46+ ec4 <- waitForProcess ph4

47+ return $ ec4 == ExitSuccess

48+ let expectedFailure = packageName `Set.member` expectedFailures

49+ if passed

50+ then do

51+ removeFile logfile

52+ when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."

53+ else putStrLn $ "Test suite failed: " ++ package

54+ rm_r dir

55+ return $! prevPassed && (passed || expectedFailure)

56+ where

57+ logfile = testdir </> package <.> "log"

58+ dir = testdir </> package

59+ getHandle mode = withBinaryFile logfile mode

60+ package = packageVersionString pair

Stackage/Types.hs+5

@@ -38,3 +38,8 @@ data HaskellPlatform = HaskellPlatform

38instance Monoid HaskellPlatform where

39 mempty = HaskellPlatform mempty mempty

40 HaskellPlatform a x `mappend` HaskellPlatform b y = HaskellPlatform (mappend a b) (mappend x y)

41+

42+data InstallInfo = InstallInfo

43+ { iiCore :: Set PackageName

44+ , iiPackages :: Map PackageName Version

45+ }

Stackage/Util.hs+11

@@ -3,10 +3,21 @@ module Stackage.Util where

3import qualified Data.Map as Map

4import qualified Data.Set as Set

5import Distribution.Version (thisVersion)

6+import Data.Version (showVersion)

6import Stackage.Types

7import Stackage.Types

8+import System.Directory (doesDirectoryExist, removeDirectoryRecursive)

9+import Control.Monad (when)

7

10

8identsToRanges :: Set PackageIdentifier -> Map PackageName VersionRange

11identsToRanges :: Set PackageIdentifier -> Map PackageName VersionRange

9identsToRanges =

12identsToRanges =

10 Map.unions . map go . Set.toList

13 Map.unions . map go . Set.toList

11 where

14 where

12 go (PackageIdentifier package version) = Map.singleton package $ thisVersion version

15 go (PackageIdentifier package version) = Map.singleton package $ thisVersion version

16+

17+packageVersionString :: (PackageName, Version) -> String

18+packageVersionString (PackageName p, v) = concat [p, "-", showVersion v]

19+

20+rm_r :: FilePath -> IO ()

21+rm_r fp = do

22+ exists <- doesDirectoryExist fp

23+ when exists $ removeDirectoryRecursive fp

app/gen-install-line.hsdeleted−104

@@ -1,104 +0,0 @@

1−import Control.Monad (when, unless, foldM)

2−import Data.List (sort)

3−import qualified Data.Map as Map

4−import qualified Data.Set as Set

5−import Data.Version (showVersion)

6−import Stackage.HaskellPlatform

7−import Stackage.LoadDatabase

8−import Stackage.NarrowDatabase

9−import Stackage.Types

10−import Stackage.Util

11−import Stackage.Config

12−import System.Directory (doesDirectoryExist, removeDirectoryRecursive, removeFile, createDirectory)

13−import System.Process (readProcess, waitForProcess, runProcess)

14−import System.Exit (ExitCode (ExitSuccess), exitWith)

15−import System.FilePath ((</>), (<.>))

16−import System.IO (IOMode (WriteMode, AppendMode), withBinaryFile)

17−

18−data Mismatch = OnlyDryRun String | OnlySimpleList String

19− deriving Show

20−

21−main :: IO ()

22−main = do

23− hp <- loadHaskellPlatform

24− let allPackages = Map.union stablePackages $ identsToRanges (hplibs hp)

25− pdb <- loadPackageDB (extraCore `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp)) allPackages

26− final <- narrowPackageDB pdb $ Set.fromList $ Map.keys allPackages

27− let simpleList = map (\(PackageName p, v) -> p ++ "-" ++ showVersion v) $ Map.toList final

28− writeFile "to-install.txt" $ unlines simpleList

29−

30− rm_r "cabal-dev"

31−

32− dryRun' <- readProcess "cabal-dev" ("install":"--dry-run":"-fnetwork23":simpleList) ""

33− writeFile "dry-run.txt" dryRun'

34− let dryRun = sort $ drop 2 $ lines dryRun'

35− let mismatches = getMismatches dryRun simpleList

36− if null mismatches

37− then do

38− putStrLn "No mismatches, good to go!"

39− ph <- withBinaryFile "build.log" WriteMode $ \handle -> runProcess "cabal-dev" ("install":"-fnetwork23":simpleList) Nothing Nothing Nothing (Just handle) (Just handle)

40− ec <- waitForProcess ph

41− unless (ec == ExitSuccess) $ exitWith ec

42− putStrLn "Environment built, beginning individual test suites"

43− let testdir = "runtests"

44− rm_r testdir

45− createDirectory testdir

46− allPass <- foldM (runTestSuite testdir) True $ zip simpleList $ Map.toList final

47− if allPass

48− then putStrLn "All test suites pass"

49− else putStrLn "There were failures, please see the logs in runtests"

50− else do

51− putStrLn "Found the following mismtaches"

52− mapM_ print mismatches

53−

54−rm_r :: FilePath -> IO ()

55−rm_r fp = do

56− exists <- doesDirectoryExist fp

57− when exists $ removeDirectoryRecursive fp

58−

59−runTestSuite :: FilePath -> Bool -> (String, (PackageName, Version)) -> IO Bool

60−runTestSuite testdir prevPassed (package, (packageName, _)) = do

61− passed <- do

62− ph1 <- getHandle WriteMode $ \handle -> runProcess "cabal-dev" ["unpack", package] (Just testdir) Nothing Nothing (Just handle) (Just handle)

63− ec1 <- waitForProcess ph1

64− if (ec1 /= ExitSuccess)

65− then return False

66− else do

67− putStrLn dir

68− ph2 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["-s", "../../cabal-dev", "configure", "--enable-tests"] (Just dir) Nothing Nothing (Just handle) (Just handle)

69− ec2 <- waitForProcess ph2

70− if (ec2 /= ExitSuccess)

71− then return False

72− else do

73− ph3 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["build"] (Just dir) Nothing Nothing (Just handle) (Just handle)

74− ec3 <- waitForProcess ph3

75− if (ec3 /= ExitSuccess)

76− then return False

77− else do

78− ph4 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["test"] (Just dir) Nothing Nothing (Just handle) (Just handle)

79− ec4 <- waitForProcess ph4

80− return $ ec4 == ExitSuccess

81− let expectedFailure = packageName `Set.member` expectedFailures

82− if passed

83− then do

84− removeFile logfile

85− when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."

86− else putStrLn $ "Test suite failed: " ++ package

87− rm_r dir

88− return $! prevPassed && (passed || expectedFailure)

89− where

90− logfile = testdir </> package <.> "log"

91− dir = testdir </> package

92− getHandle mode = withBinaryFile logfile mode

93−

94−getMismatches :: [String] -> [String] -> [Mismatch]

95−getMismatches =

96− go

97− where

98− go [] y = map OnlySimpleList y

99− go x [] = map OnlyDryRun x

100− go (x:xs) (y:ys) =

101− case compare x y of

102− EQ -> go xs ys

103− LT -> OnlyDryRun x : go xs (y:ys)

104− GT -> OnlySimpleList y : go (x:xs) ys

app/stackage.hsnew file+4

@@ -0,0 +1,4 @@

1+import Stackage.Build (build)

2+

3+main :: IO ()

4+main = build

stackage.cabal+7−6

@@ -21,6 +21,10 @@ library

21 Stackage.Util

22 Stackage.Types

23 Stackage.Config

24+ Stackage.InstallInfo

25+ Stackage.CheckPlan

26+ Stackage.Test

27+ Stackage.Build

24 build-depends: base >= 4 && < 5

28 build-depends: base >= 4 && < 5

25 , containers

29 , containers

26 , Cabal

30 , Cabal

@@ -29,13 +33,10 @@ library

29 , directory

33 , directory

30 , filepath

34 , filepath

31 , transformers

35 , transformers

36+ , process

32

37

33−executable stackage-gen-install-line

38+executable stackage

34 hs-source-dirs: app

39 hs-source-dirs: app

35− main-is: gen-install-line.hs

40+ main-is: stackage.hs

36 build-depends: base

41 build-depends: base

37 , stackage

42 , stackage

38− , containers

39− , filepath

40− , process

41− , directory