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

Merge branch 'origin-develbuildghcapi'

Browse Source
This commit is contained in:
Luite Stegeman 2012-11-02 12:27:31 +01:00
commit 00f8764799
3 changed files with 148 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

91
yesod/Options.hs Normal file
View 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
View File

@ -1,10 +1,11 @@
{-# 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)
import Options.Applicative import Options.Applicative
import System.Environment (getEnvironment)
import System.Exit (ExitCode (ExitSuccess), exitWith) import System.Exit (ExitCode (ExitSuccess), exitWith)
import System.Process (rawSystem) import System.Process (rawSystem)
@ -13,6 +14,7 @@ import Yesod.Core (yesodVersion)
import AddHandler (addHandler) import AddHandler (addHandler)
import Devel (DevelOpts (..), devel) import Devel (DevelOpts (..), devel)
import Keter (keter) import Keter (keter)
import Options (injectDefaults)
import qualified Paths_yesod import qualified Paths_yesod
import Scaffolding.Scaffolder import Scaffolding.Scaffolder
@ -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,33 +61,42 @@ data Command = Init
| Version | Version
deriving (Show, Eq) 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 :: IO ()
main = do main = do
env <- getEnvironment o <- execParser =<< injectDefaults "yesod" [ ("yesod.devel.extracabalarg" , optCommand . develExtraArgs)
o <- execParser (optParser' env) , ("yesod.devel.ignore" , optCommand . develIgnore)
] optParser'
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' :: Environment -> ParserInfo Options optParser' :: ParserInfo Options
optParser' env = info (helper <*> optParser env) ( fullDesc <> header "Yesod Web Framework command line utility" ) optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" )
optParser :: Environment -> Parser Options optParser :: Parser Options
optParser env = Options optParser = Options
<$> flag Cabal CabalDev ( long "dev" <> short 'd' <> help "use cabal-dev" ) <$> flag Cabal CabalDev ( long "dev" <> short 'd' <> help "use cabal-dev" )
<*> switch ( long "verbose" <> short 'v' <> help "More verbose output" ) <*> switch ( long "verbose" <> short 'v' <> help "More verbose output" )
<*> subparser ( command "init" (info (pure Init) <*> subparser ( command "init" (info (pure Init)
@ -100,7 +107,7 @@ optParser env = Options
(progDesc $ "Build project (performs TH dependency analysis)" ++ windowsWarning)) (progDesc $ "Build project (performs TH dependency analysis)" ++ windowsWarning))
<> command "touch" (info (pure Touch) <> command "touch" (info (pure Touch)
(progDesc $ "Touch any files with altered TH dependencies but do not build" ++ windowsWarning)) (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")) (progDesc "Run project with the devel server"))
<> command "test" (info (pure Test) <> command "test" (info (pure Test)
(progDesc "Build and run the integration tests")) (progDesc "Build and run the integration tests"))
@ -115,19 +122,21 @@ optParser env = Options
keterOptions :: Parser Command keterOptions :: Parser Command
keterOptions = Keter <$> switch ( long "nobuild" <> short 'n' <> help "Skip rebuilding" ) keterOptions = Keter <$> switch ( long "nobuild" <> short 'n' <> help "Skip rebuilding" )
develOptions :: Environment -> Parser Command develOptions :: Parser Command
develOptions env = Devel <$> switch ( long "disable-api" <> short 'd' develOptions = Devel <$> switch ( long "disable-api" <> short 'd'
<> help "Disable fast GHC API rebuilding") <> help "Disable fast GHC API rebuilding")
<*> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND" <*> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND"
<> help "Run COMMAND after rebuild succeeds") <> help "Run COMMAND after rebuild succeeds")
<*> optStr ( long "failure-hook" <> short 'f' <> metavar "COMMAND" <*> optStr ( long "failure-hook" <> short 'f' <> metavar "COMMAND"
<> help "Run COMMAND when rebuild fails") <> help "Run COMMAND when rebuild fails")
<*> option ( long "event-timeout" <> short 't' <> value (-1) <> metavar "N" <*> option ( long "event-timeout" <> short 't' <> value (-1) <> metavar "N"
<> help "Force rescan of files every N seconds" ) <> help "Force rescan of files every N seconds" )
<*> optStr ( long "builddir" <> short 'b'
<*> optStrEnv env "CABAL_BUILDDIR" ( long "builddir" <> short 'b' <> help "Set custom cabal build directory, default `dist'")
<> help "Set custom cabal build directory, default `dist' or the CABAL_BUILDDIR environment variable") <*> many ( strOption ( long "ignore" <> short 'i' <> metavar "DIR"
<*> extraCabalArgs <> help "ignore file changes in DIR" )
)
<*> extraCabalArgs
extraCabalArgs :: Parser [String] extraCabalArgs :: Parser [String]
extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG" 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 :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
optStr m = nullOption $ value Nothing <> reader (Just . str) <> m 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. -- | Like @rawSystem@, but exits if it receives a non-success result.
rawSystem' :: String -> [String] -> IO () rawSystem' :: String -> [String] -> IO ()
rawSystem' x y = do rawSystem' x y = do

4
yesod/yesod.cabal
View File

@ -133,6 +133,8 @@ executable yesod
, yaml >= 0.8 && < 0.9 , yaml >= 0.8 && < 0.9
, 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
, lens >= 3.1 && < 4
ghc-options: -Wall -threaded ghc-options: -Wall -threaded
main-is: main.hs main-is: main.hs
@ -144,7 +146,7 @@ executable yesod
Keter Keter
AddHandler AddHandler
Paths_yesod Paths_yesod
Options
source-repository head source-repository head
type: git type: git