git.iko.soy/stackage
on e7622de help sign in
stackage/app/stackage.hs
124 lines 5.3 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.Init (stackageInit)
7import Stackage.Select (defaultSelectSettings, select)
8import Stackage.Tarballs (makeTarballs)
9import Stackage.Test (runTestSuites)
10import Stackage.Types
11import Stackage.Uploads (checkUploads)
12import Stackage.Util (allowPermissive)
13import System.Environment (getArgs, getProgName)
14import System.IO (hFlush, stdout)
16data SelectArgs = SelectArgs
17 { excluded :: [String]
18 , noPlatform :: Bool
19 , onlyPermissive :: Bool
20 , allowed :: [String]
21 , buildPlanDest :: FilePath
22 , globalDB :: Bool
23 }
25parseSelectArgs :: [String] -> IO SelectArgs
26parseSelectArgs =
27 loop SelectArgs
28 { excluded = []
29 , noPlatform = False
30 , onlyPermissive = False
31 , allowed = []
32 , buildPlanDest = defaultBuildPlan
33 , globalDB = False
34 }
35 where
36 loop x [] = return x
37 loop x ("--exclude":y:rest) = loop x { excluded = y : excluded x } rest
38 loop x ("--no-platform":rest) = loop x { noPlatform = True } rest
39 loop x ("--only-permissive":rest) = loop x { onlyPermissive = True } rest
40 loop x ("--allow":y:rest) = loop x { allowed = y : allowed x } rest
41 loop x ("--build-plan":y:rest) = loop x { buildPlanDest = y } rest
42 loop x ("--use-global-db":rest) = loop x { globalDB = True } rest
43 loop _ (y:_) = error $ "Did not understand argument: " ++ y
45data BuildArgs = BuildArgs
46 { sandbox :: String
47 , buildPlanSrc :: FilePath
48 , extraArgs' :: [String] -> [String]
49 , noDocs :: Bool
50 }
52parseBuildArgs :: [String] -> IO BuildArgs
53parseBuildArgs =
54 loop BuildArgs
55 { sandbox = sandboxRoot defaultBuildSettings
56 , buildPlanSrc = defaultBuildPlan
57 , extraArgs' = id
58 , noDocs = False
59 }
60 where
61 loop x [] = return x
62 loop x ("--sandbox":y:rest) = loop x { sandbox = y } rest
63 loop x ("--build-plan":y:rest) = loop x { buildPlanSrc = y } rest
64 loop x ("--arg":y:rest) = loop x { extraArgs' = extraArgs' x . (y:) } rest
65 loop x ("--no-docs":rest) = loop x { noDocs = True } rest
66 loop _ (y:_) = error $ "Did not understand argument: " ++ y
68defaultBuildPlan :: FilePath
69defaultBuildPlan = "build-plan.txt"
71withBuildSettings :: [String] -> (BuildSettings -> BuildPlan -> IO a) -> IO a
72withBuildSettings args f = do
73 BuildArgs {..} <- parseBuildArgs args
74 bp <- readBuildPlan buildPlanSrc
75 let settings = defaultBuildSettings
76 { sandboxRoot = sandbox
77 , extraArgs = extraArgs' . extraArgs defaultBuildSettings
78 , buildDocs = not noDocs
79 }
80 f settings bp
82main :: IO ()
83main = do
84 args <- getArgs
85 case args of
86 ["uploads"] -> checkUploads "allowed.txt" "new-allowed.txt"
87 "select":rest -> do
88 SelectArgs {..} <- parseSelectArgs rest
89 bp <- select
90 defaultSelectSettings
91 { excludedPackages = fromList $ map PackageName excluded
92 , requireHaskellPlatform = not noPlatform
93 , allowedPackage =
94 if onlyPermissive
95 then allowPermissive allowed
96 else const $ Right ()
97 , useGlobalDatabase = globalDB
98 }
99 writeBuildPlan buildPlanDest bp
100 ("check":rest) -> withBuildSettings rest $ const checkPlan
101 ("build":rest) -> withBuildSettings rest build
102 ("test":rest) -> withBuildSettings rest runTestSuites
103 ("tarballs":rest) -> withBuildSettings rest $ const makeTarballs
104 ["init"] -> do
105 putStrLn "Note: init isn't really ready for prime time use."
106 putStrLn "Using it may make it impossible to build stackage."
107 putStr "Are you sure you want continue (y/n)? "
108 hFlush stdout
109 x <- getLine
110 case x of
111 c:_ | c `elem` "yY" -> stackageInit
112 _ -> putStrLn "Probably a good decision, exiting."
113 ["update"] -> stackageInit >> error "FIXME update"
114 _ -> do
115 pn <- getProgName
116 putStrLn $ "Usage: " ++ pn ++ " <command>"
117 putStrLn "Available commands:"
118 --putStrLn " update Download updated Stackage databases. Automatically calls init."
119 --putStrLn " init Initialize your cabal file to use Stackage"
120 putStrLn " uploads"
121 putStrLn " select [--no-clean] [--no-platform] [--exclude package...] [--only-permissive] [--allow package] [--build-plan file]"
122 putStrLn " check [--build-plan file] [--sandbox rootdir] [--arg cabal-arg]"
123 putStrLn " build [--build-plan file] [--sandbox rootdir] [--arg cabal-arg]"
124 putStrLn " test [--build-plan file] [--sandbox rootdir] [--arg cabal-arg] [--no-docs]"