From 54abbc861833eab22a855bef3417ea358c5afd27 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 2 Nov 2012 01:07:08 +0100 Subject: [PATCH] fix handling of parameters that may occur multiple times --- yesod/Options.hs | 30 +++++++++++++++++++----- yesod/main.hs | 60 ++++++++++++++++++++++++++++------------------- yesod/yesod.cabal | 1 + 3 files changed, 61 insertions(+), 30 deletions(-) diff --git a/yesod/Options.hs b/yesod/Options.hs index 3a6c06dd..9bedbf08 100644 --- a/yesod/Options.hs +++ b/yesod/Options.hs @@ -5,12 +5,15 @@ 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 @@ -22,16 +25,31 @@ import System.FilePath (()) -- 1. command line arguments: --long-option=value -- 2. environment variables: PREFIX_COMMAND_LONGOPTION=value -- 3. $HOME/.prefix/config: prefix.command.longoption=value -injectDefaults :: String -> ParserInfo a -> IO (ParserInfo a) -injectDefaults prefix parser = do +-- +-- 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 - print env - return $ parser { infoParser = injectDefaultP env [prefix] (infoParser parser) } + 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)] @@ -62,8 +80,7 @@ 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 (BindP p1 f) = - BindP (injectDefaultP env path p1) (\a -> injectDefaultP env path (f a)) +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 @@ -71,3 +88,4 @@ getEnvValue _ _ _ = Nothing normalizeName :: String -> String normalizeName = map toLower . filter isAlphaNum + diff --git a/yesod/main.hs b/yesod/main.hs index 6e902170..3d6548ea 100755 --- a/yesod/main.hs +++ b/yesod/main.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +import Control.Lens hiding (value) import Control.Monad (unless) import Data.Monoid import Data.Version (showVersion) @@ -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,25 +61,36 @@ data Command = Init | Version deriving (Show, Eq) +makeLenses ''Options +makeLenses ''Command + +cabalCommand :: Options -> String +cabalCommand mopt + | mopt^.optCabalPgm == CabalDev = "cabal-dev" + | otherwise = "cabal" + + main :: IO () main = do - o <- execParser =<< injectDefaults "yesod" optParser' + 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' :: ParserInfo Options optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" ) @@ -124,6 +133,9 @@ develOptions = Devel <$> switch ( long "disable-api" <> short 'd' <> 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] diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index d7eb8069..5324f027 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -133,6 +133,7 @@ executable yesod , 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