diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +0.2.4 +===== + +* Configuration.Utils.Setup: fixed generation of 'PkgInfo' module for + package configurations with explict flags. + +* Improved documentation for 'Maybe' values. + 0.2.3 ===== diff --git a/configuration-tools.cabal b/configuration-tools.cabal --- a/configuration-tools.cabal +++ b/configuration-tools.cabal @@ -3,7 +3,7 @@ -- ------------------------------------------------------ -- Name: configuration-tools -Version: 0.2.3 +Version: 0.2.4 Synopsis: Tools for specifying and parsing configurations description: Tools for specifying and parsing configurations @@ -54,7 +54,7 @@ source-repository this type: git location: https://github.com/alephcloud/hs-configuration-tools.git - tag: 0.2.3 + tag: 0.2.4 Library hs-source-dirs: src diff --git a/constraints b/constraints --- a/constraints +++ b/constraints @@ -11,7 +11,7 @@ bytestring ==0.10.4.0, comonad ==4.2, conduit ==1.1.6, - configuration-tools ==0.2.3, + configuration-tools ==0.2.4, containers ==0.5.5.1, contravariant ==0.6, deepseq ==1.3.0.2, diff --git a/src/Configuration/Utils.hs b/src/Configuration/Utils.hs --- a/src/Configuration/Utils.hs +++ b/src/Configuration/Utils.hs @@ -311,10 +311,10 @@ -- > p = withText "user" $ \case -- > "alice" → pure (0 ∷ Int) -- > "bob" → pure 1 --- > e → faile $ "unrecognized user " ⊕ e +-- > e → fail $ "unrecognized user " ⊕ e -- setProperty - ∷ Lens' α β -- ^ Lens that into the target that is updated by the parser + ∷ Lens' α β -- ^ a lens into the target that is updated by the parser → T.Text -- ^ the JSON property name → (Value → Parser β) -- ^ the JSON 'Value' parser that is used to parse the value of the property → Object -- ^ the parsed JSON 'Value' 'Object' @@ -642,7 +642,51 @@ -- Optional configuration values are supposed to be encoded by wrapping -- the respective type with 'Maybe'. -- --- For this the following orphan 'FromJSON' instance is provided: +-- For simple values the standard 'FromJSON' instance from the aeson +-- package can be used with the along with the '..:' operator. +-- +-- When defining command line option parsers with '.::' and '%::' all +-- options are optional. When an option is not present on the command +-- line the default value is used. For 'Maybe' values it is therefore +-- enough to wrap the parsed value into 'Just'. +-- +-- > data LogConfig = LogConfig +-- > { _logLevel :: !Int +-- > , _logFile :: !(Maybe String) +-- > } +-- > +-- > $(makeLenses ''LogConfig) +-- > +-- > defaultLogConfig :: LogConfig +-- > defaultLogConfig = LogConfig +-- > { _logLevel = 1 +-- > , _logFile = Nothing +-- > } +-- > +-- > instance FromJSON (LogConfig -> LogConfig) where +-- > parseJSON = withObject "LogConfig" $ \o -> id +-- > <$< logLevel ..: "LogLevel" % o +-- > <*< logFile ..: "LogConfig" % o +-- > +-- > instance ToJSON LogConfig where +-- > toJSON config = object +-- > [ "LogLevel" .= _logLevel config +-- > , "LogConfig" .= _logFile config +-- > ] +-- > +-- > pLogConfig :: MParser LogConfig +-- > pLogConfig = id +-- > <$< logLevel .:: option +-- > % long "log-level" +-- > % metavar "INTEGER" +-- > % help "log level" +-- > <*< logFile .:: fmap Just % strOption +-- > % long "log-file" +-- > % metavar "FILENAME" +-- > % help "log file name" +-- +-- For product-type (record) 'Maybe' values the following orphan 'FromJSON' +-- instance is provided: -- -- > instance (FromJSON (a → a), FromJSON a) ⇒ FromJSON (Maybe a → Maybe a) -- > parseJSON Null = pure (const Nothing) diff --git a/src/Configuration/Utils/Setup.hs b/src/Configuration/Utils/Setup.hs --- a/src/Configuration/Utils/Setup.hs +++ b/src/Configuration/Utils/Setup.hs @@ -121,7 +121,7 @@ { postConf = mkPkgInfoModules } where - mkPkgInfoModules _ _ pkgDesc bInfo = mapM_ f . map (\(a,_,_) -> a) $ componentsConfigs bInfo + mkPkgInfoModules _ _ pkgDesc bInfo = mapM_ (f . \(a,_,_) -> a) $ componentsConfigs bInfo where f cname = case cname of CLibName -> updatePkgInfoModule Nothing pkgDesc bInfo @@ -144,13 +144,16 @@ where f = reverse . dropWhile isSpace getVCS :: IO (Maybe RepoType) -getVCS = do +getVCS = doesDirectoryExist ".hg" >>= \x0 -> if x0 then return (Just Mercurial) else doesDirectoryExist ".git" >>= \x1 -> if x1 then return (Just Git) else return Nothing +flagNameStr :: FlagName -> String +flagNameStr (FlagName s) = s + pkgInfoModule :: Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString pkgInfoModule cName pkgDesc bInfo = do (tag, revision, branch) <- getVCS >>= \x -> case x of @@ -160,11 +163,11 @@ let vcsBranch = if branch == "default" || branch == "master" then "" else branch vcsVersion = intercalate "-" . filter (/= "") $ [tag, revision, vcsBranch] - flags = map fst . filter snd . configConfigurationsFlags . configFlags $ bInfo + flags = map (flagNameStr . fst) . filter snd . configConfigurationsFlags . configFlags $ bInfo licenseString <- licenseFilesText pkgDesc - return $ B.intercalate "\n" $ + return $ B.intercalate "\n" [ "{-# LANGUAGE OverloadedStrings #-}" , "{-# LANGUAGE RankNTypes #-}" , "" @@ -281,9 +284,9 @@ hgInfo :: IO (String, String, String) hgInfo = do - tag <- fmap trim $ readProcess "hg" ["id", "-r", "max(ancestors(\".\") and tag())", "-t"] "" - rev <- fmap trim $ readProcess "hg" ["id", "-i"] "" - branch <- fmap trim $ readProcess "hg" ["id", "-b"] "" + tag <- trim <$> readProcess "hg" ["id", "-r", "max(ancestors(\".\") and tag())", "-t"] "" + rev <- trim <$> readProcess "hg" ["id", "-i"] "" + branch <- trim <$> readProcess "hg" ["id", "-b"] "" return (tag, rev, branch) gitInfo :: IO (String, String, String) @@ -293,8 +296,8 @@ case exitCode of ExitSuccess -> return $ trim out _ -> return "" - rev <- fmap trim $ readProcess "git" ["rev-parse", "--short", "HEAD"] "" - branch <- fmap trim $ readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "" + rev <- trim <$> readProcess "git" ["rev-parse", "--short", "HEAD"] "" + branch <- trim <$> readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "" return (tag, rev, branch) noVcsInfo :: IO (String, String, String)