Code cleanup

.gitignore

@@ -6,3 +6,4 @@ cabal-dev
 *.chs.h
 .virthualenv
 *.swp
+runtests/

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

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

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

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

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

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
+    }

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

app/gen-install-line.hs

@@ -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

app/stackage.hs

@@ -0,0 +1,4 @@
+import           Stackage.Build (build)
+
+main :: IO ()
+main = build

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