From 4be13587afce4d3f70f3e0eb7be6739d415cf487 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 22 Nov 2012 09:27:07 +0200 Subject: [PATCH] Code cleanup --- .gitignore | 1 + Stackage/Build.hs | 30 ++++++++++++ Stackage/CheckPlan.hs | 35 ++++++++++++++ Stackage/Config.hs | 1 - Stackage/InstallInfo.hs | 28 +++++++++++ Stackage/Test.hs | 60 +++++++++++++++++++++++ Stackage/Types.hs | 5 ++ Stackage/Util.hs | 11 +++++ app/gen-install-line.hs | 104 ---------------------------------------- app/stackage.hs | 4 ++ stackage.cabal | 13 ++--- 11 files changed, 181 insertions(+), 111 deletions(-) create mode 100644 Stackage/Build.hs create mode 100644 Stackage/CheckPlan.hs create mode 100644 Stackage/InstallInfo.hs create mode 100644 Stackage/Test.hs delete mode 100644 app/gen-install-line.hs create mode 100644 app/stackage.hs diff --git a/.gitignore b/.gitignore index 803badb3..9861587e 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ cabal-dev *.chs.h .virthualenv *.swp +runtests/ diff --git a/Stackage/Build.hs b/Stackage/Build.hs new file mode 100644 index 00000000..a2a7423b --- /dev/null +++ b/Stackage/Build.hs @@ -0,0 +1,30 @@ +module Stackage.Build + ( build + ) where + +import Control.Monad (unless) +import Stackage.CheckPlan +import Stackage.Test +import Stackage.Util +import Stackage.InstallInfo +import System.Process (waitForProcess, runProcess) +import System.Exit (ExitCode (ExitSuccess), exitWith) +import System.IO (IOMode (WriteMode), withBinaryFile) + +build :: IO () +build = do + ii <- getInstallInfo + checkPlan ii + + rm_r "cabal-dev" + + putStrLn "No mismatches, good to go!" + + ph <- withBinaryFile "build.log" WriteMode $ \handle -> + runProcess "cabal-dev" ("install":"-fnetwork23":iiPackageList ii) Nothing Nothing Nothing (Just handle) (Just handle) + ec <- waitForProcess ph + unless (ec == ExitSuccess) $ exitWith ec + + putStrLn "Environment built, beginning individual test suites" + + runTestSuites ii diff --git a/Stackage/CheckPlan.hs b/Stackage/CheckPlan.hs new file mode 100644 index 00000000..00fc7c1e --- /dev/null +++ b/Stackage/CheckPlan.hs @@ -0,0 +1,35 @@ +module Stackage.CheckPlan + ( checkPlan + ) where + +import Control.Monad (unless) +import Data.List (sort) +import Stackage.Types +import Stackage.InstallInfo +import System.Process (readProcess) +import System.Exit (ExitCode (ExitFailure), exitWith) + +data Mismatch = OnlyDryRun String | OnlySimpleList String + deriving Show + +checkPlan :: InstallInfo -> IO () +checkPlan ii = do + dryRun' <- readProcess "cabal-dev" ("install":"--dry-run":"-fnetwork23":iiPackageList ii) "" + let dryRun = sort $ drop 2 $ lines dryRun' + let mismatches = getMismatches dryRun (iiPackageList ii) + unless (null mismatches) $ do + putStrLn "Found the following mismtaches" + mapM_ print mismatches + exitWith $ ExitFailure 1 + +getMismatches :: [String] -> [String] -> [Mismatch] +getMismatches = + go + where + go [] y = map OnlySimpleList y + go x [] = map OnlyDryRun x + go (x:xs) (y:ys) = + case compare x y of + EQ -> go xs ys + LT -> OnlyDryRun x : go xs (y:ys) + GT -> OnlySimpleList y : go (x:xs) ys diff --git a/Stackage/Config.hs b/Stackage/Config.hs index cd5d36ee..e5ef4eba 100644 --- a/Stackage/Config.hs +++ b/Stackage/Config.hs @@ -6,7 +6,6 @@ import Control.Monad.Trans.Writer (execWriter, tell) import Data.Set (singleton, fromList) import Control.Monad (when, unless) import Distribution.System (OS (..), buildOS) -import Distribution.Version (anyVersion) import Distribution.Text (simpleParse) -- | Packages which are shipped with GHC but are not included in the diff --git a/Stackage/InstallInfo.hs b/Stackage/InstallInfo.hs new file mode 100644 index 00000000..83f27d5e --- /dev/null +++ b/Stackage/InstallInfo.hs @@ -0,0 +1,28 @@ +module Stackage.InstallInfo + ( getInstallInfo + , iiPackageList + ) where + +import Stackage.Types +import Stackage.Util +import Stackage.Config +import Stackage.LoadDatabase +import Stackage.NarrowDatabase +import Stackage.HaskellPlatform +import qualified Data.Map as Map +import qualified Data.Set as Set + +getInstallInfo :: IO InstallInfo +getInstallInfo = do + hp <- loadHaskellPlatform + let allPackages = Map.union stablePackages $ identsToRanges (hplibs hp) + let totalCore = extraCore `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp) + pdb <- loadPackageDB totalCore allPackages + final <- narrowPackageDB pdb $ Set.fromList $ Map.keys allPackages + return InstallInfo + { iiCore = totalCore + , iiPackages = final + } + +iiPackageList :: InstallInfo -> [String] +iiPackageList = map packageVersionString . Map.toList . iiPackages diff --git a/Stackage/Test.hs b/Stackage/Test.hs new file mode 100644 index 00000000..f962d420 --- /dev/null +++ b/Stackage/Test.hs @@ -0,0 +1,60 @@ +module Stackage.Test + ( runTestSuites + ) where + +import Control.Monad (when, foldM) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Stackage.Types +import Stackage.Util +import Stackage.Config +import System.Directory (removeFile, createDirectory) +import System.Process (waitForProcess, runProcess) +import System.Exit (ExitCode (ExitSuccess)) +import System.FilePath ((), (<.>)) +import System.IO (IOMode (WriteMode, AppendMode), withBinaryFile) + +runTestSuites :: InstallInfo -> IO () +runTestSuites ii = do + let testdir = "runtests" + rm_r testdir + createDirectory testdir + allPass <- foldM (runTestSuite testdir) True $ Map.toList $ iiPackages ii + if allPass + then putStrLn "All test suites that were expected to pass did pass" + else error $ "There were failures, please see the logs in " ++ testdir + +runTestSuite :: FilePath -> Bool -> (PackageName, Version) -> IO Bool +runTestSuite testdir prevPassed pair@(packageName, _) = do + passed <- do + ph1 <- getHandle WriteMode $ \handle -> runProcess "cabal" ["unpack", package] (Just testdir) Nothing Nothing (Just handle) (Just handle) + ec1 <- waitForProcess ph1 + if (ec1 /= ExitSuccess) + then return False + else do + ph2 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["-s", "../../cabal-dev", "configure", "--enable-tests"] (Just dir) Nothing Nothing (Just handle) (Just handle) + ec2 <- waitForProcess ph2 + if (ec2 /= ExitSuccess) + then return False + else do + ph3 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["build"] (Just dir) Nothing Nothing (Just handle) (Just handle) + ec3 <- waitForProcess ph3 + if (ec3 /= ExitSuccess) + then return False + else do + ph4 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["test"] (Just dir) Nothing Nothing (Just handle) (Just handle) + ec4 <- waitForProcess ph4 + return $ ec4 == ExitSuccess + let expectedFailure = packageName `Set.member` expectedFailures + if passed + then do + removeFile logfile + when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would." + else putStrLn $ "Test suite failed: " ++ package + rm_r dir + return $! prevPassed && (passed || expectedFailure) + where + logfile = testdir package <.> "log" + dir = testdir package + getHandle mode = withBinaryFile logfile mode + package = packageVersionString pair diff --git a/Stackage/Types.hs b/Stackage/Types.hs index ac2ba5d7..8bee0f72 100644 --- a/Stackage/Types.hs +++ b/Stackage/Types.hs @@ -38,3 +38,8 @@ data HaskellPlatform = HaskellPlatform instance Monoid HaskellPlatform where mempty = HaskellPlatform mempty mempty HaskellPlatform a x `mappend` HaskellPlatform b y = HaskellPlatform (mappend a b) (mappend x y) + +data InstallInfo = InstallInfo + { iiCore :: Set PackageName + , iiPackages :: Map PackageName Version + } diff --git a/Stackage/Util.hs b/Stackage/Util.hs index 970b9fc3..9eeb6f21 100644 --- a/Stackage/Util.hs +++ b/Stackage/Util.hs @@ -3,10 +3,21 @@ module Stackage.Util where import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Version (thisVersion) +import Data.Version (showVersion) import Stackage.Types +import System.Directory (doesDirectoryExist, removeDirectoryRecursive) +import Control.Monad (when) identsToRanges :: Set PackageIdentifier -> Map PackageName VersionRange identsToRanges = Map.unions . map go . Set.toList where go (PackageIdentifier package version) = Map.singleton package $ thisVersion version + +packageVersionString :: (PackageName, Version) -> String +packageVersionString (PackageName p, v) = concat [p, "-", showVersion v] + +rm_r :: FilePath -> IO () +rm_r fp = do + exists <- doesDirectoryExist fp + when exists $ removeDirectoryRecursive fp diff --git a/app/gen-install-line.hs b/app/gen-install-line.hs deleted file mode 100644 index f15623a1..00000000 --- a/app/gen-install-line.hs +++ /dev/null @@ -1,104 +0,0 @@ -import Control.Monad (when, unless, foldM) -import Data.List (sort) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Version (showVersion) -import Stackage.HaskellPlatform -import Stackage.LoadDatabase -import Stackage.NarrowDatabase -import Stackage.Types -import Stackage.Util -import Stackage.Config -import System.Directory (doesDirectoryExist, removeDirectoryRecursive, removeFile, createDirectory) -import System.Process (readProcess, waitForProcess, runProcess) -import System.Exit (ExitCode (ExitSuccess), exitWith) -import System.FilePath ((), (<.>)) -import System.IO (IOMode (WriteMode, AppendMode), withBinaryFile) - -data Mismatch = OnlyDryRun String | OnlySimpleList String - deriving Show - -main :: IO () -main = do - hp <- loadHaskellPlatform - let allPackages = Map.union stablePackages $ identsToRanges (hplibs hp) - pdb <- loadPackageDB (extraCore `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp)) allPackages - final <- narrowPackageDB pdb $ Set.fromList $ Map.keys allPackages - let simpleList = map (\(PackageName p, v) -> p ++ "-" ++ showVersion v) $ Map.toList final - writeFile "to-install.txt" $ unlines simpleList - - rm_r "cabal-dev" - - dryRun' <- readProcess "cabal-dev" ("install":"--dry-run":"-fnetwork23":simpleList) "" - writeFile "dry-run.txt" dryRun' - let dryRun = sort $ drop 2 $ lines dryRun' - let mismatches = getMismatches dryRun simpleList - if null mismatches - then do - putStrLn "No mismatches, good to go!" - ph <- withBinaryFile "build.log" WriteMode $ \handle -> runProcess "cabal-dev" ("install":"-fnetwork23":simpleList) Nothing Nothing Nothing (Just handle) (Just handle) - ec <- waitForProcess ph - unless (ec == ExitSuccess) $ exitWith ec - putStrLn "Environment built, beginning individual test suites" - let testdir = "runtests" - rm_r testdir - createDirectory testdir - allPass <- foldM (runTestSuite testdir) True $ zip simpleList $ Map.toList final - if allPass - then putStrLn "All test suites pass" - else putStrLn "There were failures, please see the logs in runtests" - else do - putStrLn "Found the following mismtaches" - mapM_ print mismatches - -rm_r :: FilePath -> IO () -rm_r fp = do - exists <- doesDirectoryExist fp - when exists $ removeDirectoryRecursive fp - -runTestSuite :: FilePath -> Bool -> (String, (PackageName, Version)) -> IO Bool -runTestSuite testdir prevPassed (package, (packageName, _)) = do - passed <- do - ph1 <- getHandle WriteMode $ \handle -> runProcess "cabal-dev" ["unpack", package] (Just testdir) Nothing Nothing (Just handle) (Just handle) - ec1 <- waitForProcess ph1 - if (ec1 /= ExitSuccess) - then return False - else do - putStrLn dir - ph2 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["-s", "../../cabal-dev", "configure", "--enable-tests"] (Just dir) Nothing Nothing (Just handle) (Just handle) - ec2 <- waitForProcess ph2 - if (ec2 /= ExitSuccess) - then return False - else do - ph3 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["build"] (Just dir) Nothing Nothing (Just handle) (Just handle) - ec3 <- waitForProcess ph3 - if (ec3 /= ExitSuccess) - then return False - else do - ph4 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["test"] (Just dir) Nothing Nothing (Just handle) (Just handle) - ec4 <- waitForProcess ph4 - return $ ec4 == ExitSuccess - let expectedFailure = packageName `Set.member` expectedFailures - if passed - then do - removeFile logfile - when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would." - else putStrLn $ "Test suite failed: " ++ package - rm_r dir - return $! prevPassed && (passed || expectedFailure) - where - logfile = testdir package <.> "log" - dir = testdir package - getHandle mode = withBinaryFile logfile mode - -getMismatches :: [String] -> [String] -> [Mismatch] -getMismatches = - go - where - go [] y = map OnlySimpleList y - go x [] = map OnlyDryRun x - go (x:xs) (y:ys) = - case compare x y of - EQ -> go xs ys - LT -> OnlyDryRun x : go xs (y:ys) - GT -> OnlySimpleList y : go (x:xs) ys diff --git a/app/stackage.hs b/app/stackage.hs new file mode 100644 index 00000000..b2d94425 --- /dev/null +++ b/app/stackage.hs @@ -0,0 +1,4 @@ +import Stackage.Build (build) + +main :: IO () +main = build diff --git a/stackage.cabal b/stackage.cabal index 533232c2..b5a9d203 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -21,6 +21,10 @@ library Stackage.Util Stackage.Types Stackage.Config + Stackage.InstallInfo + Stackage.CheckPlan + Stackage.Test + Stackage.Build build-depends: base >= 4 && < 5 , containers , Cabal @@ -29,13 +33,10 @@ library , directory , filepath , transformers + , process -executable stackage-gen-install-line +executable stackage hs-source-dirs: app - main-is: gen-install-line.hs + main-is: stackage.hs build-depends: base , stackage - , containers - , filepath - , process - , directory