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