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

Remove lens (I'm afraid of hitting Cabal hell)

Browse Source
This commit is contained in:
Michael Snoyman 2012-11-05 11:41:53 +02:00
parent b9eb79068c
commit 83264153fc
3 changed files with 28 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
yesod/Options.hs
View File

@ -5,7 +5,6 @@ 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 (foldl')
@ -13,7 +12,6 @@ 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
@ -32,7 +30,7 @@ import System.FilePath ((</>))
-- for `many' arguments that generate a list of strings. -- for `many' arguments that generate a list of strings.
injectDefaults :: String -- ^ prefix, program name injectDefaults :: String -- ^ prefix, program name
-> [(String, Setting a a [String] [String])] -- ^ append extra options for arguments that are lists of strings -> [(String, a -> [String] -> a)] -- ^ append extra options for arguments that are lists of strings
-> ParserInfo a -- ^ original parsers -> ParserInfo a -- ^ original parsers
-> IO (ParserInfo a) -> IO (ParserInfo a)
injectDefaults prefix lenses parser = do injectDefaults prefix lenses parser = do
@ -45,11 +43,11 @@ injectDefaults prefix lenses parser = do
p' = 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 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 :: M.Map [String] String -> String -> (a -> [String] -> a) -> a -> a
updateA env key upd a = updateA env key upd a =
case M.lookup (splitOn "." key) env of case M.lookup (splitOn "." key) env of
Nothing -> a Nothing -> a
Just v -> upd <>~ (splitOn ":" v) $ a Just v -> upd a (splitOn ":" v)
-- | 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)]

42
yesod/main.hs
View File

@ -1,7 +1,6 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-} {-# 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)
@ -37,23 +36,23 @@ windowsWarning = " (does not work on Windows)"
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)
data Command = Init data Command = Init
| Configure | Configure
| Build { _buildExtraArgs :: [String] } | Build { buildExtraArgs :: [String] }
| Touch | Touch
| Devel { _develDisableApi :: Bool | Devel { _develDisableApi :: Bool
, _develSuccessHook :: Maybe String , _develSuccessHook :: Maybe String
, _develFailHook :: Maybe String , _develFailHook :: Maybe String
, _develRescan :: Int , _develRescan :: Int
, _develBuildDir :: Maybe String , _develBuildDir :: Maybe String
, _develIgnore :: [String] , develIgnore :: [String]
, _develExtraArgs :: [String] , develExtraArgs :: [String]
} }
| Test | Test
| AddHandler | AddHandler
@ -61,28 +60,37 @@ data Command = Init
| Version | Version
deriving (Show, Eq) deriving (Show, Eq)
makeLenses ''Options
makeLenses ''Command
cabalCommand :: Options -> String cabalCommand :: Options -> String
cabalCommand mopt cabalCommand mopt
| mopt^.optCabalPgm == CabalDev = "cabal-dev" | optCabalPgm mopt == CabalDev = "cabal-dev"
| otherwise = "cabal" | otherwise = "cabal"
main :: IO () main :: IO ()
main = do main = do
o <- execParser =<< injectDefaults "yesod" [ ("yesod.devel.extracabalarg" , optCommand . develExtraArgs) o <- execParser =<< injectDefaults "yesod" [ ("yesod.devel.extracabalarg" , \o args -> o { optCommand =
, ("yesod.devel.ignore" , optCommand . develIgnore) case optCommand o of
, ("yesod.build.extracabalarg" , optCommand . buildExtraArgs) d@Devel{} -> d { develExtraArgs = args }
c -> c
})
, ("yesod.devel.ignore" , \o args -> o { optCommand =
case optCommand o of
d@Devel{} -> d { develIgnore = args }
c -> c
})
, ("yesod.build.extracabalarg" , \o args -> o { optCommand =
case optCommand o of
b@Build{} -> b { buildExtraArgs = args }
c -> c
})
] optParser' ] optParser'
let cabal xs = rawSystem' (cabalCommand o) xs let cabal xs = rawSystem' (cabalCommand o) xs
case o^.optCommand of case optCommand o 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 ign es -> devel (DevelOpts (o^.optCabalPgm == CabalDev) da (o^.optVerbose) r s f b) es Devel da s f r b _ig es -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) 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)

1
yesod/yesod.cabal
View File

@ -134,7 +134,6 @@ 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