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