diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # configuration-tools +## 0.7.1 (2025-03-04) + +* Support lastest GHC (9.12) +* Use setters instead of lenses in ..: and %.: +* Allow validation functions to return new values + ## 0.7.0 (2022-06-22) The version bump is due to the update of the dependency on optparse-applicative, diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -110,6 +110,7 @@ import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex import Distribution.Simple.Setup +import Distribution.Simple.Utils (createDirectoryIfMissingVerbose) import Distribution.Text import Distribution.Utils.Path import Distribution.Utils.ShortText @@ -128,10 +129,17 @@ import Prelude hiding (readFile, writeFile) import System.Directory - (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, - doesFileExist, getCurrentDirectory) + ( canonicalizePath + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + ) import System.Exit (ExitCode(ExitSuccess)) +#if MIN_VERSION_Cabal(3,14,0) +import System.FilePath (isDrive, takeDirectory) +#else import System.FilePath (isDrive, takeDirectory, ()) +#endif -- | Include this function when your setup doesn't contain any -- extra functionality. @@ -162,6 +170,11 @@ prettyLicense :: I.InstalledPackageInfo -> String prettyLicense = either prettyShow prettyShow . I.license +#if !MIN_VERSION_Cabal(3,14,0) +interpretSymbolicPath :: Maybe () -> FilePath -> FilePath +interpretSymbolicPath _ p = p +#endif + -- -------------------------------------------------------------------------- -- -- Cabal 2.0 @@ -173,28 +186,31 @@ -> LocalBuildInfo -> IO () mkPkgInfoModulesPostConf hook args flags pkgDesc bInfo = do - mapM_ (updatePkgInfoModule pkgDesc bInfo) $ Graph.toList $ componentGraph bInfo + mapM_ (updatePkgInfoModule pkgDesc bInfo flags) $ Graph.toList $ componentGraph bInfo hook args flags pkgDesc bInfo -updatePkgInfoModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> IO () -updatePkgInfoModule pkgDesc bInfo clbInfo = do - createDirectoryIfMissing True dirName +updatePkgInfoModule + :: PackageDescription + -> LocalBuildInfo + -> ConfigFlags + -> ComponentLocalBuildInfo + -> IO () +updatePkgInfoModule pkgDesc bInfo flags clbInfo = do + createDirectoryIfMissingVerbose verbosity True dirName moduleBytes <- pkgInfoModule moduleName cName pkgDesc bInfo updateFile fileName moduleBytes -- legacy module legacyModuleBytes <- pkgInfoModule legacyModuleName cName pkgDesc bInfo updateFile legacyFileName legacyModuleBytes - where - dirName = autogenComponentModulesDir bInfo clbInfo + verbosity = fromFlag $ configVerbosity flags + dirName = interpretSymbolicPath Nothing $ autogenComponentModulesDir bInfo clbInfo cName = unUnqualComponentName <$> componentNameString (componentLocalName clbInfo) - moduleName = pkgInfoModuleName - fileName = dirName ++ "/" ++ moduleName ++ ".hs" - + fileName = dirName moduleName <> ".hs" legacyModuleName = legacyPkgInfoModuleName cName - legacyFileName = dirName ++ "/" ++ legacyModuleName ++ ".hs" + legacyFileName = dirName legacyModuleName <> ".hs" -- -------------------------------------------------------------------------- -- -- Generate PkgInfo Module @@ -214,7 +230,7 @@ legacyPkgInfoModuleName :: Maybe String -> String legacyPkgInfoModuleName Nothing = "PkgInfo" -legacyPkgInfoModuleName (Just cn) = "PkgInfo_" ++ map tr cn +legacyPkgInfoModuleName (Just cn) = "PkgInfo_" <> map tr cn where tr '-' = '_' tr c = c @@ -236,7 +252,12 @@ then return Nothing else getVcsOfDir (takeDirectory canonicDir) -pkgInfoModule :: String -> Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString +pkgInfoModule + :: String + -> Maybe String + -> PackageDescription + -> LocalBuildInfo + -> IO B.ByteString pkgInfoModule moduleName cName pkgDesc bInfo = do (tag, revision, branch) <- getVCS >>= \case Just Mercurial -> hgInfo diff --git a/configuration-tools.cabal b/configuration-tools.cabal --- a/configuration-tools.cabal +++ b/configuration-tools.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: configuration-tools -version: 0.7.0 +version: 0.7.1 synopsis: Tools for specifying and parsing configurations description: Tools for specifying and parsing configurations @@ -30,19 +30,20 @@ license: MIT license-file: LICENSE author: Lars Kuhtz -maintainer: Lars Kuhtz +maintainer: Lars Kuhtz , Edmund Noble copyright: + (c) 2024-2025 Edmund Noble , (c) 2019-2020 Colin Woodbury , - (c) 2015-2023 Lars Kuhtz , + (c) 2015-2025 Lars Kuhtz , (c) 2014-2015 AlephCloud, Inc. category: Configuration, Console build-type: Custom tested-with: + , GHC==9.12 + , GHC==9.10 + , GHC==9.8 , GHC==9.6 , GHC==9.4 - , GHC==9.2 - , GHC==9.0.1 - , GHC==8.10.7 extra-doc-files: README.md, diff --git a/src/Configuration/Utils.hs b/src/Configuration/Utils.hs --- a/src/Configuration/Utils.hs +++ b/src/Configuration/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -135,7 +136,7 @@ import Control.Monad (void, when) import Control.Monad.Except (MonadError, throwError) -import Control.Monad.Writer (execWriterT, runWriterT) +import Control.Monad.Writer (runWriterT) import Control.Monad.IO.Class (MonadIO) import qualified Data.ByteString.Char8 as B8 @@ -170,13 +171,13 @@ -- this type is to avoid @ImpredicativeTypes@ when storing the function -- in the 'ProgramInfoValidate' record. -- -newtype ConfigValidationFunction a f = ConfigValidationFunction - { runConfigValidation ∷ ConfigValidation a f +newtype ConfigValidationFunction a f r = ConfigValidationFunction + { runConfigValidation ∷ ConfigValidation' a f r } type ProgramInfo a = ProgramInfoValidate a [] -data ProgramInfoValidate a f = ProgramInfo +data ProgramInfoValidate' a f r = ProgramInfo { _piDescription ∷ !String -- ^ Program Description , _piHelpHeader ∷ !(Maybe String) @@ -187,7 +188,7 @@ -- ^ options parser for configuration , _piDefaultConfiguration ∷ !a -- ^ default configuration - , _piValidateConfiguration ∷ !(ConfigValidationFunction a f) + , _piValidateConfiguration ∷ !(ConfigValidationFunction a f r) -- ^ a validation function. The 'Right' result is interpreted as a 'Foldable' -- structure of warnings. , _piConfigurationFiles ∷ ![ConfigFile] @@ -195,33 +196,35 @@ -- before any command line argument is evaluated. } +type ProgramInfoValidate a f = ProgramInfoValidate' a f a + -- | Program Description -- -piDescription ∷ Lens' (ProgramInfoValidate a f) String +piDescription ∷ Lens' (ProgramInfoValidate' a f r) String piDescription = lens _piDescription $ \s a → s { _piDescription = a } {-# INLINE piDescription #-} -- | Help header -- -piHelpHeader ∷ Lens' (ProgramInfoValidate a f) (Maybe String) +piHelpHeader ∷ Lens' (ProgramInfoValidate' a f r) (Maybe String) piHelpHeader = lens _piHelpHeader $ \s a → s { _piHelpHeader = a } {-# INLINE piHelpHeader #-} -- | Help footer -- -piHelpFooter ∷ Lens' (ProgramInfoValidate a f) (Maybe String) +piHelpFooter ∷ Lens' (ProgramInfoValidate' a f r) (Maybe String) piHelpFooter = lens _piHelpFooter $ \s a → s { _piHelpFooter = a } {-# INLINE piHelpFooter #-} -- | Options parser for configuration -- -piOptionParser ∷ Lens' (ProgramInfoValidate a f) (MParser a) +piOptionParser ∷ Lens' (ProgramInfoValidate' a f r) (MParser a) piOptionParser = lens _piOptionParser $ \s a → s { _piOptionParser = a } {-# INLINE piOptionParser #-} -- | Default configuration -- -piDefaultConfiguration ∷ Lens' (ProgramInfoValidate a f) a +piDefaultConfiguration ∷ Lens' (ProgramInfoValidate' a f r) a piDefaultConfiguration = lens _piDefaultConfiguration $ \s a → s { _piDefaultConfiguration = a } {-# INLINE piDefaultConfiguration #-} @@ -229,7 +232,7 @@ -- -- The 'Right' result is interpreted as a 'Foldable' structure of warnings. -- -piValidateConfiguration ∷ Lens' (ProgramInfoValidate a f) (ConfigValidationFunction a f) +piValidateConfiguration ∷ Lens' (ProgramInfoValidate' a f r) (ConfigValidationFunction a f r) piValidateConfiguration = lens _piValidateConfiguration $ \s a → s { _piValidateConfiguration = a } {-# INLINE piValidateConfiguration #-} @@ -246,10 +249,10 @@ -- piOptionParserAndDefaultConfiguration ∷ Lens - (ProgramInfoValidate a b) - (ProgramInfoValidate c d) - (MParser a, a, ConfigValidationFunction a b) - (MParser c, c, ConfigValidationFunction c d) + (ProgramInfoValidate' a b r) + (ProgramInfoValidate' c d r') + (MParser a, a, ConfigValidationFunction a b r) + (MParser c, c, ConfigValidationFunction c d r') piOptionParserAndDefaultConfiguration = lens g $ \s (a,b,c) → ProgramInfo { _piDescription = _piDescription s , _piHelpHeader = _piHelpHeader s @@ -283,13 +286,13 @@ -- -- 'piHelpHeader' and 'piHelpFooter' are set to 'Nothing'. -- -programInfoValidate +programInfoValidate' ∷ String → MParser a → a - → ConfigValidation a f - → ProgramInfoValidate a f -programInfoValidate desc parser defaultConfig valFunc = ProgramInfo + → ConfigValidation' a f r + → ProgramInfoValidate' a f r +programInfoValidate' desc parser defaultConfig valFunc = ProgramInfo { _piDescription = desc , _piHelpHeader = Nothing , _piHelpFooter = Nothing @@ -299,6 +302,19 @@ , _piConfigurationFiles = [] } +-- | Smart constructor for 'ProgramInfo'. +-- +-- 'piHelpHeader' and 'piHelpFooter' are set to 'Nothing'. +-- +programInfoValidate + ∷ String + → MParser a + → a + → ConfigValidation a f + → ProgramInfoValidate a f +programInfoValidate desc parser defaultConfig valFunc = + programInfoValidate' desc parser defaultConfig $ \c -> valFunc c >> return c + -- -------------------------------------------------------------------------- -- -- AppConfiguration @@ -343,6 +359,7 @@ , _configFiles ∷ ![ConfigFile] , _mainConfig ∷ !a } + deriving Functor -- | A list of configuration file locations. Configuration file locations are -- set either statically in the code or are provided dynamically on the command @@ -446,10 +463,10 @@ -- runWithConfiguration ∷ (FromJSON (a → a), ToJSON a, Foldable f, Monoid (f T.Text)) - ⇒ ProgramInfoValidate a f + ⇒ ProgramInfoValidate' a f r -- ^ program info value; use 'programInfo' to construct a value of this -- type - → (a → IO ()) + → (r → IO ()) -- ^ computation that is given the configuration that is parsed from -- the command line. → IO () @@ -574,8 +591,8 @@ -- Internal main function mainOptions - ∷ ∀ a f . FromJSON (a → a) - ⇒ ProgramInfoValidate a f + ∷ ∀ a f r . FromJSON (a → a) + ⇒ ProgramInfoValidate' a f r -- ^ Program Info value which may include a validation function → (∀ b . Maybe (MParser b)) @@ -646,7 +663,7 @@ -- runInternal ∷ (FromJSON (a → a), ToJSON a, Foldable f, Monoid (f T.Text)) - ⇒ ProgramInfoValidate a f + ⇒ ProgramInfoValidate' a f r -- ^ program info value; use 'programInfo' to construct a value of this -- type → (∀ b . Maybe (MParser b)) @@ -655,7 +672,7 @@ -- See the documentation of "Configuration.Utils.Setup" for a way -- how to generate this information automatically from the package -- description during the build process. - → (a → IO ()) + → (r → IO ()) -- ^ computation that is given the configuration that is parsed from -- the command line. → IO () @@ -672,10 +689,10 @@ (_configFiles cliAppConf) -- Validate final configuration - validateConfig appInfo $ _mainConfig appConf + validatedConf ← validateConfig appInfo $ _mainConfig appConf case _printConfig appConf of - Nothing → mainFunction ∘ _mainConfig $ appConf + Nothing → mainFunction ∘ _mainConfig $ validatedConf <$ appConf Just Full → B8.putStrLn ∘ Yaml.encode ∘ _mainConfig $ appConf Just Minimal → B8.putStrLn ∘ Yaml.encode @@ -714,7 +731,7 @@ ) ⇒ T.Text -- ^ program name (used in error messages) - → ProgramInfoValidate a f + → ProgramInfoValidate' a f r -- ^ program info value; use 'programInfo' to construct a value of this -- type → [String] @@ -752,12 +769,13 @@ -- validateConfig ∷ (Foldable f, Monoid (f T.Text)) - ⇒ ProgramInfoValidate a f + ⇒ ProgramInfoValidate' a f r → a - → IO () + → IO r validateConfig appInfo conf = do - warnings ← execWriterT ∘ exceptT (error ∘ T.unpack) return $ + (r, warnings) ← runWriterT ∘ exceptT (error ∘ T.unpack) return $ runConfigValidation (view piValidateConfiguration appInfo) conf when (any (const True) warnings) $ do T.hPutStrLn stderr "WARNINGS:" mapM_ (\w → T.hPutStrLn stderr $ "warning: " ⊕ w) warnings + return r diff --git a/src/Configuration/Utils/ConfigFile.hs b/src/Configuration/Utils/ConfigFile.hs --- a/src/Configuration/Utils/ConfigFile.hs +++ b/src/Configuration/Utils/ConfigFile.hs @@ -78,7 +78,6 @@ import Data.Monoid.Unicode import Data.String import qualified Data.Text as T -import Data.Typeable import Prelude hiding (any, concatMap, mapM_) @@ -126,7 +125,7 @@ -- > e → fail $ "unrecognized user " ⊕ e -- setProperty - ∷ Lens' a b -- ^ a lens into the target that is updated by the parser + ∷ Setter' a b -- ^ a lens into the target that is updated by the parser → T.Text -- ^ the JSON property name → (Value → Parser b) -- ^ the JSON 'Value' parser that is used to parse the value of the property → Object -- ^ the parsed JSON 'Value' 'Object' @@ -158,7 +157,7 @@ -- > <$< user ..: "user" % o -- > <*< pwd ..: "pwd" % o -- -(..:) ∷ FromJSON b ⇒ Lens' a b → T.Text → Object → Parser (a → a) +(..:) ∷ FromJSON b ⇒ Setter' a b → T.Text → Object → Parser (a → a) (..:) s k = setProperty s k parseJSON infix 6 ..: {-# INLINE (..:) #-} @@ -194,7 +193,7 @@ -- > <*< setProperty domain "domain" parseJSON o -- updateProperty - ∷ Lens' a b + ∷ Setter' a b → T.Text → (Value → Parser (b → b)) → Object @@ -230,7 +229,7 @@ -- > <$< auth %.: "auth" % o -- > <*< domain ..: "domain" % o -- -(%.:) ∷ FromJSON (b → b) ⇒ Lens' a b → T.Text → Object → Parser (a → a) +(%.:) ∷ FromJSON (b → b) ⇒ Setter' a b → T.Text → Object → Parser (a → a) (%.:) s k = updateProperty s k parseJSON infix 6 %.: {-# INLINE (%.:) #-} @@ -254,7 +253,7 @@ data ConfigFile = ConfigFileRequired { getConfigFile ∷ !T.Text } | ConfigFileOptional { getConfigFile ∷ !T.Text } - deriving (Show, Read, Eq, Ord, Typeable) + deriving (Show, Read, Eq, Ord) -- | An /internal/ type for the meta configuration that specifies how the -- configuration files are loaded and parsed. @@ -263,7 +262,7 @@ data ConfigFilesConfig = ConfigFilesConfig { _cfcHttpsPolicy ∷ !HttpsCertPolicy } - deriving (Show, Eq, Typeable) + deriving (Show, Eq) cfcHttpsPolicy ∷ Lens' ConfigFilesConfig HttpsCertPolicy cfcHttpsPolicy = lens _cfcHttpsPolicy $ \a b → a { _cfcHttpsPolicy = b } diff --git a/src/Configuration/Utils/Internal.hs b/src/Configuration/Utils/Internal.hs --- a/src/Configuration/Utils/Internal.hs +++ b/src/Configuration/Utils/Internal.hs @@ -21,6 +21,8 @@ , view , Lens' , Lens +, Setter' +, Setter , Iso' , Iso , iso @@ -70,15 +72,29 @@ -- type Lens' s a = Lens s s a a +-- | This is almost the same type as the type from the lens library with the same name. +-- +-- In case it is already import from the lens package this should be hidden +-- from the import. +-- +type Setter s t a b = (a -> Identity b) -> s -> Identity t + +-- | This is almost the same type as the type from the lens library with the same name. +-- +-- In case it is already import from the lens package this should be hidden +-- from the import. +-- +type Setter' s a = Setter s s a a + lens ∷ (s → a) → (s → b → t) → Lens s t a b lens getter setter lGetter s = setter s `fmap` lGetter (getter s) {-# INLINE lens #-} -over ∷ ((a → Identity b) → s → Identity t) → (a → b) → s → t +over ∷ Setter s t a b → (a → b) → s → t over s f = runIdentity . s (Identity . f) {-# INLINE over #-} -set ∷ ((a → Identity b) → s → Identity t) → b → s → t +set ∷ Setter s t a b → b → s → t set s a = runIdentity . s (const $ Identity a) {-# INLINE set #-} @@ -123,4 +139,3 @@ → m a errorT = exceptT (\e → error ∘ T.unpack $ "Error: " ⊕ e) return {-# INLINE errorT #-} - diff --git a/src/Configuration/Utils/Internal/ConfigFileReader.hs b/src/Configuration/Utils/Internal/ConfigFileReader.hs --- a/src/Configuration/Utils/Internal/ConfigFileReader.hs +++ b/src/Configuration/Utils/Internal/ConfigFileReader.hs @@ -50,7 +50,6 @@ import qualified Data.ByteString.Char8 as B8 import Data.Monoid.Unicode import qualified Data.Text as T -import Data.Typeable import qualified Data.Yaml as Yaml import GHC.Generics @@ -155,7 +154,7 @@ = Yaml | Json | Other - deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable, Generic) + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) instance NFData ConfigFileFormat diff --git a/src/Configuration/Utils/Internal/HttpsCertPolicy.hs b/src/Configuration/Utils/Internal/HttpsCertPolicy.hs --- a/src/Configuration/Utils/Internal/HttpsCertPolicy.hs +++ b/src/Configuration/Utils/Internal/HttpsCertPolicy.hs @@ -52,7 +52,6 @@ import Data.String import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Data.Typeable import qualified Data.X509 as TLS import qualified Data.X509.Validation as TLS @@ -80,7 +79,7 @@ , _certPolicyHostFingerprints ∷ !(HM.HashMap TLS.ServiceID TLS.Fingerprint) -- ^ a whitelist for services with trusted certificates } - deriving (Show, Eq, Typeable) + deriving (Show, Eq) certPolicyInsecure ∷ Lens' HttpsCertPolicy Bool certPolicyInsecure = lens _certPolicyInsecure $ \s a → s { _certPolicyInsecure = a } @@ -177,7 +176,7 @@ -- In particular exceptions should include rejected certificates. -- newtype VerboseTlsException = VerboseTlsException T.Text - deriving (Eq, Ord, Typeable) + deriving (Eq, Ord) instance Show VerboseTlsException where show (VerboseTlsException msg) = "TLS exception: " ⊕ T.unpack msg @@ -189,7 +188,7 @@ → Maybe (TLS.SignedExact TLS.Certificate) → TLS.TLSException → IO a -handleTlsException request cert e@(TLS.HandshakeFailed (TLS.Error_Protocol (msg, _b, _alert))) +handleTlsException request cert e@(TLS.HandshakeFailed (TLS.Error_Protocol msg _)) | "certificate rejected: [SelfSigned]" `L.isPrefixOf` msg = throwIO ∘ VerboseTlsException $ "The server uses a self-signed certificate. If you are sure that no-one" ⊕ " is intercepting the connection and this is the correct certificate you" 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 @@ -110,6 +110,7 @@ import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex import Distribution.Simple.Setup +import Distribution.Simple.Utils (createDirectoryIfMissingVerbose) import Distribution.Text import Distribution.Utils.Path import Distribution.Utils.ShortText @@ -128,10 +129,17 @@ import Prelude hiding (readFile, writeFile) import System.Directory - (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, - doesFileExist, getCurrentDirectory) + ( canonicalizePath + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + ) import System.Exit (ExitCode(ExitSuccess)) +#if MIN_VERSION_Cabal(3,14,0) +import System.FilePath (isDrive, takeDirectory) +#else import System.FilePath (isDrive, takeDirectory, ()) +#endif -- | Include this function when your setup doesn't contain any -- extra functionality. @@ -162,8 +170,10 @@ prettyLicense :: I.InstalledPackageInfo -> String prettyLicense = either prettyShow prettyShow . I.license -ft :: ShortText -> String -ft = fromShortText +#if !MIN_VERSION_Cabal(3,14,0) +interpretSymbolicPath :: Maybe () -> FilePath -> FilePath +interpretSymbolicPath _ p = p +#endif -- -------------------------------------------------------------------------- -- -- Cabal 2.0 @@ -176,28 +186,31 @@ -> LocalBuildInfo -> IO () mkPkgInfoModulesPostConf hook args flags pkgDesc bInfo = do - mapM_ (updatePkgInfoModule pkgDesc bInfo) $ Graph.toList $ componentGraph bInfo + mapM_ (updatePkgInfoModule pkgDesc bInfo flags) $ Graph.toList $ componentGraph bInfo hook args flags pkgDesc bInfo -updatePkgInfoModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> IO () -updatePkgInfoModule pkgDesc bInfo clbInfo = do - createDirectoryIfMissing True dirName +updatePkgInfoModule + :: PackageDescription + -> LocalBuildInfo + -> ConfigFlags + -> ComponentLocalBuildInfo + -> IO () +updatePkgInfoModule pkgDesc bInfo flags clbInfo = do + createDirectoryIfMissingVerbose verbosity True dirName moduleBytes <- pkgInfoModule moduleName cName pkgDesc bInfo updateFile fileName moduleBytes -- legacy module legacyModuleBytes <- pkgInfoModule legacyModuleName cName pkgDesc bInfo updateFile legacyFileName legacyModuleBytes - where - dirName = autogenComponentModulesDir bInfo clbInfo + verbosity = fromFlag $ configVerbosity flags + dirName = interpretSymbolicPath Nothing $ autogenComponentModulesDir bInfo clbInfo cName = unUnqualComponentName <$> componentNameString (componentLocalName clbInfo) - moduleName = pkgInfoModuleName - fileName = dirName ++ "/" ++ moduleName ++ ".hs" - + fileName = dirName moduleName <> ".hs" legacyModuleName = legacyPkgInfoModuleName cName - legacyFileName = dirName ++ "/" ++ legacyModuleName ++ ".hs" + legacyFileName = dirName legacyModuleName <> ".hs" -- -------------------------------------------------------------------------- -- -- Generate PkgInfo Module @@ -217,7 +230,7 @@ legacyPkgInfoModuleName :: Maybe String -> String legacyPkgInfoModuleName Nothing = "PkgInfo" -legacyPkgInfoModuleName (Just cn) = "PkgInfo_" ++ map tr cn +legacyPkgInfoModuleName (Just cn) = "PkgInfo_" <> map tr cn where tr '-' = '_' tr c = c @@ -239,7 +252,12 @@ then return Nothing else getVcsOfDir (takeDirectory canonicDir) -pkgInfoModule :: String -> Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString +pkgInfoModule + :: String + -> Maybe String + -> PackageDescription + -> LocalBuildInfo + -> IO B.ByteString pkgInfoModule moduleName cName pkgDesc bInfo = do (tag, revision, branch) <- getVCS >>= \case Just Mercurial -> hgInfo @@ -302,10 +320,10 @@ , " copyright = " <> (pack . show . copyright) pkgDesc , "" , " author :: IsString a => a" - , " author = \"" <> (pack . ft . author) pkgDesc <> "\"" + , " author = \"" <> (pack . fromShortText . author) pkgDesc <> "\"" , "" , " homepage :: IsString a => a" - , " homepage = \"" <> (pack . ft . homepage) pkgDesc <> "\"" + , " homepage = \"" <> (pack . fromShortText . homepage) pkgDesc <> "\"" , "" , " package :: IsString a => a" , " package = \"" <> (pack . display . package) pkgDesc <> "\"" @@ -397,4 +415,4 @@ ++ (if cr /= "" then ", " ++ cr else "") ++ "]" where - cr = (unwords . words . ft . I.copyright) a + cr = (unwords . words . fromShortText . I.copyright) a diff --git a/src/Configuration/Utils/Validation.hs b/src/Configuration/Utils/Validation.hs --- a/src/Configuration/Utils/Validation.hs +++ b/src/Configuration/Utils/Validation.hs @@ -17,6 +17,7 @@ -- module Configuration.Utils.Validation ( ConfigValidation +, ConfigValidation' -- * Networking , validateHttpOrHttpsUrl @@ -85,7 +86,8 @@ -- | A validation function. The type in the 'MonadWriter' is excpected to -- be a 'Foldable' structure for collecting warnings. -- -type ConfigValidation a f = ∀ m . (MonadIO m, Functor m, Applicative m, MonadError T.Text m, MonadWriter (f T.Text) m) ⇒ a → m () +type ConfigValidation a f = ConfigValidation' a f () +type ConfigValidation' a f r = ∀ m . (MonadIO m, Functor m, Applicative m, MonadError T.Text m, MonadWriter (f T.Text) m) ⇒ a → m r -- -------------------------------------------------------------------------- -- -- Networking @@ -506,4 +508,3 @@ → m () validateRange configName (lower,upper) x = unless (x ≥ lower ∧ x ≤ upper) ∘ throwError $ "value for " ⊕ configName ⊕ " must be within the range of (" ⊕ sshow lower ⊕ ", " ⊕ sshow upper ⊕ "), but was " ⊕ sshow x -