git.iko.soy/stackage
on ffefa14 help sign in
stackage/app/stackage.hs
125 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.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 , 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 :: GhcMajorVersion -> [String] -> IO BuildArgs
53parseBuildArgs version =
54 loop BuildArgs
55 { sandbox = sandboxRoot $ defaultBuildSettings version
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 version <- getGhcVersion
74 BuildArgs {..} <- parseBuildArgs version args
75 bp <- readBuildPlan buildPlanSrc
76 let settings = (defaultBuildSettings version)
77 { sandboxRoot = sandbox
78 , extraArgs = extraArgs' . extraArgs (defaultBuildSettings version)
79 , buildDocs = not noDocs
80 }
81 f settings bp
83main :: IO ()
84main = do
85 args <- getArgs
86 case args of
87 "select":rest -> do
88 SelectArgs {..} <- parseSelectArgs rest
89 ghcVersion <- getGhcVersion
90 bp <- select
91 (defaultSelectSettings ghcVersion)
92 { excludedPackages = fromList $ map PackageName excluded
93 , requireHaskellPlatform = not noPlatform
94 , allowedPackage =
95 if onlyPermissive
96 then allowPermissive allowed
97 else const $ Right ()
98 , useGlobalDatabase = globalDB
99 }
100 writeBuildPlan buildPlanDest bp
101 ("check":rest) -> withBuildSettings rest checkPlan
102 ("build":rest) -> withBuildSettings rest build
103 ("test":rest) -> withBuildSettings rest runTestSuites
104 ("tarballs":rest) -> withBuildSettings rest $ const makeTarballs
105 ["init"] -> do
106 putStrLn "Note: init isn't really ready for prime time use."
107 putStrLn "Using it may make it impossible to build stackage."
108 putStr "Are you sure you want continue (y/n)? "
109 hFlush stdout
110 x <- getLine
111 case x of
112 c:_ | c `elem` "yY" -> stackageInit
113 _ -> putStrLn "Probably a good decision, exiting."
114 ["update"] -> stackageInit >> error "FIXME update"
115 _ -> do
116 pn <- getProgName
117 putStrLn $ "Usage: " ++ pn ++ " <command>"
118 putStrLn "Available commands:"
119 --putStrLn " update Download updated Stackage databases. Automatically calls init."
120 --putStrLn " init Initialize your cabal file to use Stackage"
121 putStrLn " uploads"
122 putStrLn " select [--no-clean] [--no-platform] [--exclude package...] [--only-permissive] [--allow package] [--build-plan file]"
123 putStrLn " check [--build-plan file] [--sandbox rootdir] [--arg cabal-arg]"
124 putStrLn " build [--build-plan file] [--sandbox rootdir] [--arg cabal-arg]"
125 putStrLn " test [--build-plan file] [--sandbox rootdir] [--arg cabal-arg] [--no-docs]"