Merge branch 'origin-develbuildghcapi'
This commit is contained in:
Luite Stegeman
commit
00f8764799
91
yesod/Options.hs
Normal file
91
yesod/Options.hs
Normal file
@ -0,0 +1,91 @@
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Options (injectDefaults) where
|
||||
|
||||
import Control.Applicative
|
||||
import qualified Control.Exception as E
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Data.Char (isAlphaNum, isSpace, toLower)
|
||||
import Data.List (foldl')
|
||||
import Data.List.Split (splitOn)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Monoid
|
||||
import Data.Monoid.Lens
|
||||
import Options.Applicative
|
||||
import Options.Applicative.Types
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.FilePath ((</>))
|
||||
|
||||
-- | inject defaults from either files or environments
|
||||
-- in order of priority:
|
||||
-- 1. command line arguments: --long-option=value
|
||||
-- 2. environment variables: PREFIX_COMMAND_LONGOPTION=value
|
||||
-- 3. $HOME/.prefix/config: prefix.command.longoption=value
|
||||
--
|
||||
-- note: this automatically injects values for standard options and flags
|
||||
-- (also inside subcommands), but not for more complex parsers that use BindP
|
||||
-- (like `many'). As a workaround a single special case is supported,
|
||||
-- for `many' arguments that generate a list of strings.
|
||||
|
||||
injectDefaults :: String -- ^ prefix, program name
|
||||
-> [(String, Setting a a [String] [String])] -- ^ append extra options for arguments that are lists of strings
|
||||
-> ParserInfo a -- ^ original parsers
|
||||
-> IO (ParserInfo a)
|
||||
injectDefaults prefix lenses parser = do
|
||||
e <- getEnvironment
|
||||
config <- (readFile . (</> "config") =<< getAppUserDataDirectory prefix)
|
||||
`E.catch` \(_::E.SomeException) -> return ""
|
||||
let env = M.fromList . filter ((==[prefix]) . take 1 . fst) $
|
||||
configLines config <> -- config first
|
||||
map (\(k,v) -> (splitOn "_" $ map toLower k, v)) e -- env vars override config
|
||||
p' = parser { infoParser = injectDefaultP env [prefix] (infoParser parser) }
|
||||
return $ foldl' (\p (key,l) -> fmap (updateA env key l) p) p' lenses
|
||||
|
||||
updateA :: M.Map [String] String -> String -> Setting a a [String] [String] -> a -> a
|
||||
updateA env key upd a =
|
||||
case M.lookup (splitOn "." key) env of
|
||||
Nothing -> a
|
||||
Just v -> upd <>~ (splitOn ":" v) $ a
|
||||
|
||||
-- | really simple key/value file reader: x.y = z -> (["x","y"],"z")
|
||||
configLines :: String -> [([String], String)]
|
||||
configLines = catMaybes . map (mkLine . takeWhile (/='#')) . lines
|
||||
where
|
||||
trim = let f = reverse . dropWhile isSpace in f . f
|
||||
mkLine l | (k, ('=':v)) <- break (=='=') l = Just (splitOn "." (trim k), trim v)
|
||||
| otherwise = Nothing
|
||||
|
||||
-- | inject the environment into the parser
|
||||
-- the map contains the paths with the value that's passed into the reader if the
|
||||
-- command line parser gives no result
|
||||
injectDefaultP :: M.Map [String] String -> [String] -> Parser a -> Parser a
|
||||
injectDefaultP _env _path n@(NilP{}) = n
|
||||
injectDefaultP env path p@(OptP o)
|
||||
| (Option (CmdReader cmds f) props) <- o =
|
||||
let cmdMap = M.fromList (map (\c -> (c, mkCmd c)) cmds)
|
||||
mkCmd cmd =
|
||||
let (Just parseri) = f cmd
|
||||
in parseri { infoParser = injectDefaultP env (path ++ [normalizeName cmd]) (infoParser parseri) }
|
||||
in OptP (Option (CmdReader cmds (`M.lookup` cmdMap)) props)
|
||||
| (Option (OptReader names (CReader _ rdr)) _) <- o =
|
||||
p <|> maybe empty pure (msum $ map (rdr <=< getEnvValue env path) names)
|
||||
| (Option (FlagReader names a) _) <- o =
|
||||
p <|> if any ((==Just "1") . getEnvValue env path) names then pure a else empty
|
||||
| otherwise = p
|
||||
injectDefaultP env path (MultP p1 p2) =
|
||||
MultP (injectDefaultP env path p1) (injectDefaultP env path p2)
|
||||
injectDefaultP env path (AltP p1 p2) =
|
||||
AltP (injectDefaultP env path p1) (injectDefaultP env path p2)
|
||||
injectDefaultP _env _path b@(BindP {}) = b
|
||||
|
||||
getEnvValue :: M.Map [String] String -> [String] -> OptName -> Maybe String
|
||||
getEnvValue env path (OptLong l) = M.lookup (path ++ [normalizeName l]) env
|
||||
getEnvValue _ _ _ = Nothing
|
||||
|
||||
normalizeName :: String -> String
|
||||
normalizeName = map toLower . filter isAlphaNum
|
||||
|
||||
105
yesod/main.hs
105
yesod/main.hs
@ -1,10 +1,11 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
import Control.Lens hiding (value)
|
||||
import Control.Monad (unless)
|
||||
import Data.Monoid
|
||||
import Data.Version (showVersion)
|
||||
import Options.Applicative
|
||||
import System.Environment (getEnvironment)
|
||||
import System.Exit (ExitCode (ExitSuccess), exitWith)
|
||||
import System.Process (rawSystem)
|
||||
|
||||
@ -13,6 +14,7 @@ import Yesod.Core (yesodVersion)
|
||||
import AddHandler (addHandler)
|
||||
import Devel (DevelOpts (..), devel)
|
||||
import Keter (keter)
|
||||
import Options (injectDefaults)
|
||||
import qualified Paths_yesod
|
||||
import Scaffolding.Scaffolder
|
||||
|
||||
@ -32,17 +34,12 @@ windowsWarning :: String
|
||||
windowsWarning = " (does not work on Windows)"
|
||||
#endif
|
||||
|
||||
cabalCommand :: Options -> String
|
||||
cabalCommand mopt
|
||||
| optCabalPgm mopt == CabalDev = "cabal-dev"
|
||||
| otherwise = "cabal"
|
||||
|
||||
data CabalPgm = Cabal | CabalDev deriving (Show, Eq)
|
||||
|
||||
data Options = Options
|
||||
{ optCabalPgm :: CabalPgm
|
||||
, optVerbose :: Bool
|
||||
, optCommand :: Command
|
||||
{ _optCabalPgm :: CabalPgm
|
||||
, _optVerbose :: Bool
|
||||
, _optCommand :: Command
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
@ -55,6 +52,7 @@ data Command = Init
|
||||
, _develFailHook :: Maybe String
|
||||
, _develRescan :: Int
|
||||
, _develBuildDir :: Maybe String
|
||||
, _develIgnore :: [String]
|
||||
, _develExtraArgs :: [String]
|
||||
}
|
||||
| Test
|
||||
@ -63,33 +61,42 @@ data Command = Init
|
||||
| Version
|
||||
deriving (Show, Eq)
|
||||
|
||||
type Environment = [(String, String)]
|
||||
makeLenses ''Options
|
||||
makeLenses ''Command
|
||||
|
||||
cabalCommand :: Options -> String
|
||||
cabalCommand mopt
|
||||
| mopt^.optCabalPgm == CabalDev = "cabal-dev"
|
||||
| otherwise = "cabal"
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
env <- getEnvironment
|
||||
o <- execParser (optParser' env)
|
||||
o <- execParser =<< injectDefaults "yesod" [ ("yesod.devel.extracabalarg" , optCommand . develExtraArgs)
|
||||
, ("yesod.devel.ignore" , optCommand . develIgnore)
|
||||
] optParser'
|
||||
print o
|
||||
let cabal xs = rawSystem' (cabalCommand o) xs
|
||||
case optCommand o of
|
||||
Init -> scaffold
|
||||
Configure -> cabal ["configure"]
|
||||
Build es -> touch' >> cabal ("build":es)
|
||||
Touch -> touch'
|
||||
Devel da s f r b es -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) r s f b) es
|
||||
Keter noRebuild -> keter (cabalCommand o) noRebuild
|
||||
Version -> do putStrLn ("yesod-core version:" ++ yesodVersion)
|
||||
putStrLn ("yesod version:" ++ showVersion Paths_yesod.version)
|
||||
AddHandler -> addHandler
|
||||
Test -> do touch'
|
||||
cabal ["configure", "--enable-tests", "-flibrary-only"]
|
||||
cabal ["build"]
|
||||
cabal ["test"]
|
||||
case o^.optCommand of
|
||||
Init -> scaffold
|
||||
Configure -> cabal ["configure"]
|
||||
Build es -> touch' >> cabal ("build":es)
|
||||
Touch -> touch'
|
||||
Devel da s f r b ign es -> devel (DevelOpts (o^.optCabalPgm == CabalDev) da (o^.optVerbose) r s f b) es
|
||||
Keter noRebuild -> keter (cabalCommand o) noRebuild
|
||||
Version -> do putStrLn ("yesod-core version:" ++ yesodVersion)
|
||||
putStrLn ("yesod version:" ++ showVersion Paths_yesod.version)
|
||||
AddHandler -> addHandler
|
||||
Test -> do touch'
|
||||
cabal ["configure", "--enable-tests", "-flibrary-only"]
|
||||
cabal ["build"]
|
||||
cabal ["test"]
|
||||
|
||||
optParser' :: Environment -> ParserInfo Options
|
||||
optParser' env = info (helper <*> optParser env) ( fullDesc <> header "Yesod Web Framework command line utility" )
|
||||
optParser' :: ParserInfo Options
|
||||
optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" )
|
||||
|
||||
optParser :: Environment -> Parser Options
|
||||
optParser env = Options
|
||||
optParser :: Parser Options
|
||||
optParser = Options
|
||||
<$> flag Cabal CabalDev ( long "dev" <> short 'd' <> help "use cabal-dev" )
|
||||
<*> switch ( long "verbose" <> short 'v' <> help "More verbose output" )
|
||||
<*> subparser ( command "init" (info (pure Init)
|
||||
@ -100,7 +107,7 @@ optParser env = Options
|
||||
(progDesc $ "Build project (performs TH dependency analysis)" ++ windowsWarning))
|
||||
<> command "touch" (info (pure Touch)
|
||||
(progDesc $ "Touch any files with altered TH dependencies but do not build" ++ windowsWarning))
|
||||
<> command "devel" (info (develOptions env)
|
||||
<> command "devel" (info develOptions
|
||||
(progDesc "Run project with the devel server"))
|
||||
<> command "test" (info (pure Test)
|
||||
(progDesc "Build and run the integration tests"))
|
||||
@ -115,19 +122,21 @@ optParser env = Options
|
||||
keterOptions :: Parser Command
|
||||
keterOptions = Keter <$> switch ( long "nobuild" <> short 'n' <> help "Skip rebuilding" )
|
||||
|
||||
develOptions :: Environment -> Parser Command
|
||||
develOptions env = Devel <$> switch ( long "disable-api" <> short 'd'
|
||||
<> help "Disable fast GHC API rebuilding")
|
||||
<*> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND"
|
||||
<> help "Run COMMAND after rebuild succeeds")
|
||||
<*> optStr ( long "failure-hook" <> short 'f' <> metavar "COMMAND"
|
||||
<> help "Run COMMAND when rebuild fails")
|
||||
<*> option ( long "event-timeout" <> short 't' <> value (-1) <> metavar "N"
|
||||
<> help "Force rescan of files every N seconds" )
|
||||
|
||||
<*> optStrEnv env "CABAL_BUILDDIR" ( long "builddir" <> short 'b'
|
||||
<> help "Set custom cabal build directory, default `dist' or the CABAL_BUILDDIR environment variable")
|
||||
<*> extraCabalArgs
|
||||
develOptions :: Parser Command
|
||||
develOptions = Devel <$> switch ( long "disable-api" <> short 'd'
|
||||
<> help "Disable fast GHC API rebuilding")
|
||||
<*> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND"
|
||||
<> help "Run COMMAND after rebuild succeeds")
|
||||
<*> optStr ( long "failure-hook" <> short 'f' <> metavar "COMMAND"
|
||||
<> help "Run COMMAND when rebuild fails")
|
||||
<*> option ( long "event-timeout" <> short 't' <> value (-1) <> metavar "N"
|
||||
<> help "Force rescan of files every N seconds" )
|
||||
<*> optStr ( long "builddir" <> short 'b'
|
||||
<> help "Set custom cabal build directory, default `dist'")
|
||||
<*> many ( strOption ( long "ignore" <> short 'i' <> metavar "DIR"
|
||||
<> help "ignore file changes in DIR" )
|
||||
)
|
||||
<*> extraCabalArgs
|
||||
|
||||
extraCabalArgs :: Parser [String]
|
||||
extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG"
|
||||
@ -138,12 +147,6 @@ extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metava
|
||||
optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
|
||||
optStr m = nullOption $ value Nothing <> reader (Just . str) <> m
|
||||
|
||||
optStrEnv :: Environment
|
||||
-> String
|
||||
-> Mod OptionFields (Maybe String)
|
||||
-> Parser (Maybe String)
|
||||
optStrEnv env v m = nullOption $ value (lookup v env) <> reader (Just . str) <> m
|
||||
|
||||
-- | Like @rawSystem@, but exits if it receives a non-success result.
|
||||
rawSystem' :: String -> [String] -> IO ()
|
||||
rawSystem' x y = do
|
||||
|
||||
@ -133,6 +133,8 @@ executable yesod
|
||||
, yaml >= 0.8 && < 0.9
|
||||
, optparse-applicative >= 0.4 && < 0.5
|
||||
, fsnotify >= 0.0 && < 0.1
|
||||
, split >= 0.2 && < 0.3
|
||||
, lens >= 3.1 && < 4
|
||||
|
||||
ghc-options: -Wall -threaded
|
||||
main-is: main.hs
|
||||
@ -144,7 +146,7 @@ executable yesod
|
||||
Keter
|
||||
AddHandler
|
||||
Paths_yesod
|
||||
|
||||
Options
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
||||
Loading…
Reference in New Issue
Block a user