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