haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix handling of parameters that may occur multiple times

Browse Source
This commit is contained in:
Luite Stegeman 2012-11-02 01:07:08 +01:00
parent 976abcbb91
commit 54abbc8618
3 changed files with 61 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
yesod/Options.hs
View File

@ -5,12 +5,15 @@ module Options (injectDefaults) where
import Control.Applicative import Control.Applicative
import qualified Control.Exception as E import qualified Control.Exception as E
import Control.Lens
import Control.Monad import Control.Monad
import Data.Char (isAlphaNum, isSpace, toLower) import Data.Char (isAlphaNum, isSpace, toLower)
import Data.List (foldl')
import Data.List.Split (splitOn) import Data.List.Split (splitOn)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Data.Monoid import Data.Monoid
import Data.Monoid.Lens
import Options.Applicative import Options.Applicative
import Options.Applicative.Types import Options.Applicative.Types
import System.Directory import System.Directory
@ -22,16 +25,31 @@ import System.FilePath ((</>))
-- 1. command line arguments: --long-option=value -- 1. command line arguments: --long-option=value
-- 2. environment variables: PREFIX_COMMAND_LONGOPTION=value -- 2. environment variables: PREFIX_COMMAND_LONGOPTION=value
-- 3. $HOME/.prefix/config: 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 e <- getEnvironment
config <- (readFile . (</> "config") =<< getAppUserDataDirectory prefix) config <- (readFile . (</> "config") =<< getAppUserDataDirectory prefix)
`E.catch` \(_::E.SomeException) -> return "" `E.catch` \(_::E.SomeException) -> return ""
let env = M.fromList . filter ((==[prefix]) . take 1 . fst) $ let env = M.fromList . filter ((==[prefix]) . take 1 . fst) $
configLines config <> -- config first configLines config <> -- config first
map (\(k,v) -> (splitOn "_" $ map toLower k, v)) e -- env vars override config map (\(k,v) -> (splitOn "_" $ map toLower k, v)) e -- env vars override config
print env p' = parser { infoParser = injectDefaultP env [prefix] (infoParser parser) }
return $ 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") -- | really simple key/value file reader: x.y = z -> (["x","y"],"z")
configLines :: String -> [([String], String)] configLines :: String -> [([String], String)]
@ -62,8 +80,7 @@ injectDefaultP env path (MultP p1 p2) =
MultP (injectDefaultP env path p1) (injectDefaultP env path p2) MultP (injectDefaultP env path p1) (injectDefaultP env path p2)
injectDefaultP env path (AltP p1 p2) = injectDefaultP env path (AltP p1 p2) =
AltP (injectDefaultP env path p1) (injectDefaultP env path p2) AltP (injectDefaultP env path p1) (injectDefaultP env path p2)
injectDefaultP env path (BindP p1 f) = injectDefaultP _env _path b@(BindP {}) = b
BindP (injectDefaultP env path p1) (\a -> injectDefaultP env path (f a))
getEnvValue :: M.Map [String] String -> [String] -> OptName -> Maybe String getEnvValue :: M.Map [String] String -> [String] -> OptName -> Maybe String
getEnvValue env path (OptLong l) = M.lookup (path ++ [normalizeName l]) env getEnvValue env path (OptLong l) = M.lookup (path ++ [normalizeName l]) env
@ -71,3 +88,4 @@ getEnvValue _ _ _ = Nothing
normalizeName :: String -> String normalizeName :: String -> String
normalizeName = map toLower . filter isAlphaNum normalizeName = map toLower . filter isAlphaNum

60
yesod/main.hs
View File

@ -1,5 +1,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
import Control.Lens hiding (value)
import Control.Monad (unless) import Control.Monad (unless)
import Data.Monoid import Data.Monoid
import Data.Version (showVersion) import Data.Version (showVersion)
@ -32,17 +34,12 @@ windowsWarning :: String
windowsWarning = " (does not work on Windows)" windowsWarning = " (does not work on Windows)"
#endif #endif
cabalCommand :: Options -> String
cabalCommand mopt
| optCabalPgm mopt == CabalDev = "cabal-dev"
| otherwise = "cabal"
data CabalPgm = Cabal | CabalDev deriving (Show, Eq) data CabalPgm = Cabal | CabalDev deriving (Show, Eq)
data Options = Options data Options = Options
{ optCabalPgm :: CabalPgm { _optCabalPgm :: CabalPgm
, optVerbose :: Bool , _optVerbose :: Bool
, optCommand :: Command , _optCommand :: Command
} }
deriving (Show, Eq) deriving (Show, Eq)
@ -55,6 +52,7 @@ data Command = Init
, _develFailHook :: Maybe String , _develFailHook :: Maybe String
, _develRescan :: Int , _develRescan :: Int
, _develBuildDir :: Maybe String , _develBuildDir :: Maybe String
, _develIgnore :: [String]
, _develExtraArgs :: [String] , _develExtraArgs :: [String]
} }
| Test | Test
@ -63,25 +61,36 @@ data Command = Init
| Version | Version
deriving (Show, Eq) deriving (Show, Eq)
makeLenses ''Options
makeLenses ''Command
cabalCommand :: Options -> String
cabalCommand mopt
| mopt^.optCabalPgm == CabalDev = "cabal-dev"
| otherwise = "cabal"
main :: IO () main :: IO ()
main = do main = do
o <- execParser =<< injectDefaults "yesod" optParser' o <- execParser =<< injectDefaults "yesod" [ ("yesod.devel.extracabalarg" , optCommand . develExtraArgs)
, ("yesod.devel.ignore" , optCommand . develIgnore)
] optParser'
print o print o
let cabal xs = rawSystem' (cabalCommand o) xs let cabal xs = rawSystem' (cabalCommand o) xs
case optCommand o of case o^.optCommand of
Init -> scaffold Init -> scaffold
Configure -> cabal ["configure"] Configure -> cabal ["configure"]
Build es -> touch' >> cabal ("build":es) Build es -> touch' >> cabal ("build":es)
Touch -> touch' Touch -> touch'
Devel da s f r b es -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) r s f b) es 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 Keter noRebuild -> keter (cabalCommand o) noRebuild
Version -> do putStrLn ("yesod-core version:" ++ yesodVersion) Version -> do putStrLn ("yesod-core version:" ++ yesodVersion)
putStrLn ("yesod version:" ++ showVersion Paths_yesod.version) putStrLn ("yesod version:" ++ showVersion Paths_yesod.version)
AddHandler -> addHandler AddHandler -> addHandler
Test -> do touch' Test -> do touch'
cabal ["configure", "--enable-tests", "-flibrary-only"] cabal ["configure", "--enable-tests", "-flibrary-only"]
cabal ["build"] cabal ["build"]
cabal ["test"] cabal ["test"]
optParser' :: ParserInfo Options optParser' :: ParserInfo Options
optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" ) 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" ) <> help "Force rescan of files every N seconds" )
<*> optStr ( long "builddir" <> short 'b' <*> optStr ( long "builddir" <> short 'b'
<> help "Set custom cabal build directory, default `dist'") <> help "Set custom cabal build directory, default `dist'")
<*> many ( strOption ( long "ignore" <> short 'i' <> metavar "DIR"
<> help "ignore file changes in DIR" )
)
<*> extraCabalArgs <*> extraCabalArgs
extraCabalArgs :: Parser [String] extraCabalArgs :: Parser [String]

1
yesod/yesod.cabal
View File

@ -133,6 +133,7 @@ executable yesod
, optparse-applicative >= 0.4 && < 0.5 , optparse-applicative >= 0.4 && < 0.5
, fsnotify >= 0.0 && < 0.1 , fsnotify >= 0.0 && < 0.1
, split >= 0.2 && < 0.3 , split >= 0.2 && < 0.3
, lens >= 3.1 && < 4
ghc-options: -Wall -threaded ghc-options: -Wall -threaded
main-is: main.hs main-is: main.hs