git.iko.soy/stackage
on fcbfd6d help sign in
stackage/app/stackage.hs
148 lines 6.4 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2import Data.Set (fromList)
3import Stackage.Build (build, defaultBuildSettings)
4import Stackage.BuildPlan (readBuildPlan, writeBuildPlan, writeBuildPlanCsv)
5import Stackage.CheckPlan (checkPlan)
6import Stackage.GhcPkg (getGhcVersion)
7import Stackage.Init (stackageInit)
8import Stackage.Select (defaultSelectSettings, select)
9import Stackage.Tarballs (makeTarballs)
10import Stackage.Test (runTestSuites)
11import Stackage.Types
12import Stackage.Util (allowPermissive)
13import System.Environment (getArgs, getProgName)
14import System.IO (hFlush, stdout)
16data SelectArgs = SelectArgs
17 { excluded :: [String]
18 , noPlatform :: Bool
19 , ignoreUpgradeable :: Bool
20 , onlyPermissive :: Bool
21 , allowed :: [String]
22 , buildPlanDest :: FilePath
23 , buildPlanCsvDest :: FilePath
24 , globalDB :: Bool
25 }
27parseSelectArgs :: [String] -> IO SelectArgs
28parseSelectArgs =
29 loop SelectArgs
30 { excluded = []
31 , noPlatform = True
32 , ignoreUpgradeable = False
33 , onlyPermissive = False
34 , allowed = []
35 , buildPlanDest = defaultBuildPlan
36 , buildPlanCsvDest = defaultBuildPlanCsv
37 , globalDB = False
38 }
39 where
40 loop x [] = return x
41 loop x ("--exclude":y:rest) = loop x { excluded = y : excluded x } rest
42 loop x ("--no-platform":rest) = loop x { noPlatform = True } rest
43 loop x ("--platform":rest) = loop x { noPlatform = False } rest
44 loop x ("--ignore-upgradeable":rest) = loop x { ignoreUpgradeable = True } rest
45 loop x ("--only-permissive":rest) = loop x { onlyPermissive = True } rest
46 loop x ("--allow":y:rest) = loop x { allowed = y : allowed x } rest
47 loop x ("--build-plan":y:rest) = loop x { buildPlanDest = y } rest
48 loop x ("--build-plan-csv":y:rest) = loop x { buildPlanCsvDest = y } rest
49 loop x ("--use-global-db":rest) = loop x { globalDB = True } rest
50 loop _ (y:_) = error $ "Did not understand argument: " ++ y
52data BuildArgs = BuildArgs
53 { sandbox :: String
54 , buildPlanSrc :: FilePath
55 , extraArgs' :: [String] -> [String]
56 , noDocs :: Bool
57 , buildCores :: Maybe Int
58 , testThreads :: Maybe Int
59 }
61parseBuildArgs :: GhcMajorVersion -> [String] -> IO BuildArgs
62parseBuildArgs version =
63 loop BuildArgs
64 { sandbox = sandboxRoot $ defaultBuildSettings Nothing version
65 , buildPlanSrc = defaultBuildPlan
66 , extraArgs' = id
67 , noDocs = False
68 , buildCores = Nothing
69 , testThreads = Nothing
70 }
71 where
72 loop x [] = return x
73 loop x ("--sandbox":y:rest) = loop x { sandbox = y } rest
74 loop x ("--build-plan":y:rest) = loop x { buildPlanSrc = y } rest
75 loop x ("--arg":y:rest) = loop x { extraArgs' = extraArgs' x . (y:) } rest
76 loop x ("--no-docs":rest) = loop x { noDocs = True } rest
77 loop x ("-j":y:rest) = loop x { buildCores = Just $ read y } rest
78 loop x ("--test-threads":y:rest) = loop x { testThreads = Just $ read y } rest
79 loop _ (y:_) = error $ "Did not understand argument: " ++ y
81defaultBuildPlan :: FilePath
82defaultBuildPlan = "build-plan.txt"
84defaultBuildPlanCsv :: FilePath
85defaultBuildPlanCsv = "build-plan.csv"
87withBuildSettings :: [String] -> (BuildSettings -> BuildPlan -> IO a) -> IO a
88withBuildSettings args f = do
89 version <- getGhcVersion
90 BuildArgs {..} <- parseBuildArgs version args
91 bp <- readBuildPlan buildPlanSrc
92 let bs = defaultBuildSettings buildCores version
93 modTestThreads settings' =
94 case testThreads of
95 Nothing -> settings'
96 Just t -> settings' { testWorkerThreads = t }
97 settings = modTestThreads bs
98 { sandboxRoot = sandbox
99 , extraArgs = extraArgs' . extraArgs bs
100 , buildDocs = not noDocs
101 }
102 f settings bp
104main :: IO ()
105main = do
106 args <- getArgs
107 case args of
108 "select":rest -> do
109 SelectArgs {..} <- parseSelectArgs rest
110 ghcVersion <- getGhcVersion
111 bp <- select
112 (defaultSelectSettings ghcVersion $ not noPlatform)
113 { excludedPackages = fromList $ map PackageName excluded
114 , requireHaskellPlatform = not noPlatform
115 , ignoreUpgradeableCore = ignoreUpgradeable
116 , allowedPackage =
117 if onlyPermissive
118 then allowPermissive allowed
119 else const $ Right ()
120 , useGlobalDatabase = globalDB
121 }
122 writeBuildPlan buildPlanDest bp
123 writeBuildPlanCsv buildPlanCsvDest bp
124 ("check":rest) -> withBuildSettings rest checkPlan
125 ("build":rest) -> withBuildSettings rest build
126 ("test":rest) -> withBuildSettings rest runTestSuites
127 ("tarballs":rest) -> withBuildSettings rest $ const makeTarballs
128 ["init"] -> do
129 putStrLn "Note: init isn't really ready for prime time use."
130 putStrLn "Using it may make it impossible to build stackage."
131 putStr "Are you sure you want continue (y/n)? "
132 hFlush stdout
133 x <- getLine
134 case x of
135 c:_ | c `elem` "yY" -> stackageInit
136 _ -> putStrLn "Probably a good decision, exiting."
137 ["update"] -> stackageInit >> error "FIXME update"
138 _ -> do
139 pn <- getProgName
140 putStrLn $ "Usage: " ++ pn ++ " <command>"
141 putStrLn "Available commands:"
142 --putStrLn " update Download updated Stackage databases. Automatically calls init."
143 --putStrLn " init Initialize your cabal file to use Stackage"
144 putStrLn " uploads"
145 putStrLn " select [--no-clean] [--no-platform] [--exclude package...] [--only-permissive] [--allow package] [--build-plan file]"
146 putStrLn " check [--build-plan file] [--sandbox rootdir] [--arg cabal-arg]"
147 putStrLn " build [--build-plan file] [--sandbox rootdir] [--arg cabal-arg]"
148 putStrLn " test [--build-plan file] [--sandbox rootdir] [--arg cabal-arg] [--no-docs]"