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