allow user to set default value for command line options with env vars or config file

yesod/Options.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE PatternGuards       #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Options (injectDefaults) where
+
+import           Control.Applicative
+import qualified Control.Exception         as E
+import           Control.Monad
+import           Data.Char                 (isAlphaNum, isSpace, toLower)
+import           Data.List.Split           (splitOn)
+import qualified Data.Map                  as M
+import           Data.Maybe                (catMaybes)
+import           Data.Monoid
+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
+injectDefaults :: String -> ParserInfo a -> IO (ParserInfo a)
+injectDefaults prefix 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) }
+
+-- | 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 (BindP p1 f) =
+   BindP (injectDefaultP env path p1) (\a -> injectDefaultP env path (f a))
+
+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

yesod/main.hs

@@ -4,7 +4,6 @@ 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 +12,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
 
@@ -63,12 +63,10 @@ data Command = Init
              | Version
   deriving (Show, Eq)
 
-type Environment = [(String, String)]
-
 main :: IO ()
 main = do
-  env <- getEnvironment
-  o <- execParser (optParser' env)
+  o <- execParser =<< injectDefaults "yesod" optParser'
+  print o
   let cabal xs = rawSystem' (cabalCommand o) xs
   case optCommand o of
     Init                -> scaffold
@@ -85,11 +83,11 @@ main = do
                               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 +98,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 +113,18 @@ 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'")
+                     <*> extraCabalArgs
 
 extraCabalArgs :: Parser [String]
 extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG"
@@ -138,12 +135,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

yesod/yesod.cabal

@@ -132,6 +132,7 @@ executable             yesod
                      , yaml               >= 0.8          && < 0.9
                      , optparse-applicative >= 0.4        && < 0.5
                      , fsnotify           >= 0.0          && < 0.1
+                     , split              >= 0.2          && < 0.3
 
     ghc-options:       -Wall -threaded
     main-is:           main.hs
@@ -143,7 +144,7 @@ executable             yesod
                        Keter
                        AddHandler
                        Paths_yesod
-
+                       Options
 
 source-repository head
   type:     git