summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorlarsk <>2018-03-17 15:44:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-03-17 15:44:00 (GMT)
commit6ea2560d97689e22b7939c97c89fc6b86c6aff5c (patch)
tree524e12aae7b1798d5a88bb1f59a4da732d2ab305
parent3b6ee0350a2fa748e474e93ff6fb7bab971056e6 (diff)
version 0.3.10.3.1
-rw-r--r--CHANGELOG.md8
-rw-r--r--Setup.hs26
-rw-r--r--configuration-tools.cabal11
-rw-r--r--examples/Example.hs10
-rw-r--r--src/Configuration/Utils.hs114
-rw-r--r--src/Configuration/Utils/CommandLine.hs16
-rw-r--r--src/Configuration/Utils/ConfigFile.hs53
-rw-r--r--src/Configuration/Utils/Http.hs4
-rw-r--r--src/Configuration/Utils/Internal.hs46
-rw-r--r--src/Configuration/Utils/Internal/ConfigFileReader.hs40
-rw-r--r--src/Configuration/Utils/Monoid.hs29
-rw-r--r--src/Configuration/Utils/Operators.hs16
-rw-r--r--src/Configuration/Utils/Setup.hs26
-rw-r--r--src/Configuration/Utils/Validation.hs72
-rw-r--r--test/TestTools.hs34
15 files changed, 278 insertions, 227 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 18b879d..8f47288 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,8 +1,14 @@
+0.3.1 (2018-03-16)
+==================
+
+* Support GHC-8.4.1 and Cabal-2.2
+* Replaced the use of non-ascii identifiers in the public API
+
0.3.0
=====
* Remove built in short options `-p`, `-c`, and `-i`
-* Support CHG-8.2 and Cabal-2.0
+* Support GHC-8.2 and Cabal-2.0
0.2.15
======
diff --git a/Setup.hs b/Setup.hs
index cdb87cf..73f7e7d 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -129,6 +129,10 @@ import Distribution.Types.LocalBuildInfo
import Distribution.Types.UnqualComponentName
#endif
+#if MIN_VERSION_Cabal(2,2,0)
+import Distribution.Pretty
+#endif
+
import System.Process
import Control.Applicative
@@ -209,6 +213,8 @@ pkgInfoModuleName (Just cn) = "PkgInfo_" ++ map tr cn
tr '-' = '_'
tr c = c
+-- FIXME: autoModulesDir is deprecated and should be replaced by
+-- autogenComponentModulesDir.
pkgInfoFileName :: Maybe String -> LocalBuildInfo -> FilePath
pkgInfoFileName cn bInfo = autogenModulesDir bInfo ++ "/" ++ pkgInfoModuleName cn ++ ".hs"
@@ -235,6 +241,16 @@ unFlagName :: FlagName -> String
unFlagName (FlagName s) = s
#endif
+#if !MIN_VERSION_Cabal(2,2,0)
+unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)]
+unFlagAssignment = id
+#endif
+
+#if !MIN_VERSION_Cabal(2,2,0)
+prettyShow :: Text a => a -> String
+prettyShow = display
+#endif
+
pkgInfoModule :: Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString
pkgInfoModule cName pkgDesc bInfo = do
(tag, revision, branch) <- getVCS >>= \x -> case x of
@@ -244,7 +260,7 @@ pkgInfoModule cName pkgDesc bInfo = do
let vcsBranch = if branch == "default" || branch == "master" then "" else branch
vcsVersion = intercalate "-" . filter (/= "") $ [tag, revision, vcsBranch]
- flags = map (unFlagName . fst) . filter snd . configConfigurationsFlags . configFlags $ bInfo
+ flags = map (unFlagName . fst) . filter snd . unFlagAssignment . configConfigurationsFlags . configFlags $ bInfo
licenseString <- licenseFilesText pkgDesc
@@ -288,7 +304,7 @@ pkgInfoModule cName pkgDesc bInfo = do
, " arch = \"" <> (pack . display . hostPlatform) bInfo <> "\""
, ""
, " license :: IsString a => a"
- , " license = \"" <> (pack . display . license) pkgDesc <> "\""
+ , " license = \"" <> (pack . prettyShow . license) pkgDesc <> "\""
, ""
, " licenseText :: IsString a => a"
, " licenseText = " <> (pack . show) licenseString
@@ -450,7 +466,11 @@ noVcsInfo = return ("", "", "")
pkgIdWithLicense :: I.InstalledPackageInfo -> String
pkgIdWithLicense a = (display . packageId) a
++ " ["
- ++ (display . I.license) a
+#if MIN_VERSION_Cabal(2,2,0)
+ ++ (either prettyShow prettyShow . I.license) a
+#else
+ ++ (prettyShow . I.license) a
+#endif
++ (if cr /= "" then ", " ++ cr else "")
++ "]"
where
diff --git a/configuration-tools.cabal b/configuration-tools.cabal
index 588aa2a..85b5401 100644
--- a/configuration-tools.cabal
+++ b/configuration-tools.cabal
@@ -1,10 +1,10 @@
-- ------------------------------------------------------ --
--- Copyright © 2015-2017 Lars Kuhtz <lakuhtz@gmail.com>
+-- Copyright © 2015-2018 Lars Kuhtz <lakuhtz@gmail.com>
-- Copyright © 2014-2015 AlephCloud Systems, Inc.
-- ------------------------------------------------------ --
Name: configuration-tools
-Version: 0.3.0
+Version: 0.3.1
Synopsis: Tools for specifying and parsing configurations
description:
Tools for specifying and parsing configurations
@@ -35,7 +35,7 @@ License-file: LICENSE
Author: Lars Kuhtz <lakuhtz@gmail.com>
Maintainer: Lars Kuhtz <lakuhtz@gmail.com>
Copyright:
- (c) 2015-2017 Lars Kuhtz <lakuhtz@gmail.com>,
+ (c) 2015-2018 Lars Kuhtz <lakuhtz@gmail.com>,
(c) 2014-2015 AlephCloud, Inc.
Category: Configuration, Console
Build-type: Custom
@@ -58,7 +58,7 @@ source-repository head
source-repository this
type: git
location: https://github.com/alephcloud/hs-configuration-tools.git
- tag: 0.3.0
+ tag: 0.3.1
flag remote-configs
Description: enable loading of configuration files from HTTP URLs
@@ -109,7 +109,8 @@ Library
text >= 1.0,
unordered-containers >= 0.2.4.0,
yaml >= 0.8.8.3,
- profunctors >= 4.0.4
+ profunctors >= 4.0.4,
+ semigroups >= 0.18
if flag(old-transformers)
build-depends:
diff --git a/examples/Example.hs b/examples/Example.hs
index 708d15d..eb8e884 100644
--- a/examples/Example.hs
+++ b/examples/Example.hs
@@ -58,10 +58,10 @@ data Auth = Auth
-- (alternatively we could have used TemplateHaskell along with
-- 'makeLenses' from "Control.Lens" from the lens package.)
-user ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth
+user ∷ Functor f ⇒ (String → f String) → Auth → f Auth
user f s = (\u → s { _user = u }) <$> f (_user s)
-pwd ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth
+pwd ∷ Functor f ⇒ (String → f String) → Auth → f Auth
pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s)
defaultAuth ∷ Auth
@@ -102,13 +102,13 @@ data HttpURL = HttpURL
, _path ∷ !String
}
-auth ∷ Functor φ ⇒ (Auth → φ Auth) → HttpURL → φ HttpURL
+auth ∷ Functor f ⇒ (Auth → f Auth) → HttpURL → f HttpURL
auth f s = (\u → s { _auth = u }) <$> f (_auth s)
-domain ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL
+domain ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL
domain f s = (\u → s { _domain = u }) <$> f (_domain s)
-path ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL
+path ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL
path f s = (\u → s { _path = u }) <$> f (_path s)
defaultHttpURL ∷ HttpURL
diff --git a/src/Configuration/Utils.hs b/src/Configuration/Utils.hs
index 6c81b04..a7752ac 100644
--- a/src/Configuration/Utils.hs
+++ b/src/Configuration/Utils.hs
@@ -166,24 +166,24 @@ import Control.Monad.Trans.Control
-- this type is to avoid @ImpredicativeTypes@ when storing the function
-- in the 'ProgramInfoValidate' record.
--
-newtype ConfigValidationFunction α λ = ConfigValidationFunction
- { runConfigValidation ∷ ConfigValidation α λ
+newtype ConfigValidationFunction a f = ConfigValidationFunction
+ { runConfigValidation ∷ ConfigValidation a f
}
-type ProgramInfo α = ProgramInfoValidate α []
+type ProgramInfo a = ProgramInfoValidate a []
-data ProgramInfoValidate α λ = ProgramInfo
+data ProgramInfoValidate a f = ProgramInfo
{ _piDescription ∷ !String
-- ^ Program Description
, _piHelpHeader ∷ !(Maybe String)
-- ^ Help header
, _piHelpFooter ∷ !(Maybe String)
-- ^ Help footer
- , _piOptionParser ∷ !(MParser α)
+ , _piOptionParser ∷ !(MParser a)
-- ^ options parser for configuration
- , _piDefaultConfiguration ∷ !α
+ , _piDefaultConfiguration ∷ !a
-- ^ default configuration
- , _piValidateConfiguration ∷ !(ConfigValidationFunction α λ)
+ , _piValidateConfiguration ∷ !(ConfigValidationFunction a f)
-- ^ a validation function. The 'Right' result is interpreted as a 'Foldable'
-- structure of warnings.
, _piConfigurationFiles ∷ ![ConfigFile]
@@ -193,31 +193,31 @@ data ProgramInfoValidate α λ = ProgramInfo
-- | Program Description
--
-piDescription ∷ Lens' (ProgramInfoValidate α λ) String
+piDescription ∷ Lens' (ProgramInfoValidate a f) String
piDescription = lens _piDescription $ \s a → s { _piDescription = a }
{-# INLINE piDescription #-}
-- | Help header
--
-piHelpHeader ∷ Lens' (ProgramInfoValidate α λ) (Maybe String)
+piHelpHeader ∷ Lens' (ProgramInfoValidate a f) (Maybe String)
piHelpHeader = lens _piHelpHeader $ \s a → s { _piHelpHeader = a }
{-# INLINE piHelpHeader #-}
-- | Help footer
--
-piHelpFooter ∷ Lens' (ProgramInfoValidate α λ) (Maybe String)
+piHelpFooter ∷ Lens' (ProgramInfoValidate a f) (Maybe String)
piHelpFooter = lens _piHelpFooter $ \s a → s { _piHelpFooter = a }
{-# INLINE piHelpFooter #-}
-- | Options parser for configuration
--
-piOptionParser ∷ Lens' (ProgramInfoValidate α λ) (MParser α)
+piOptionParser ∷ Lens' (ProgramInfoValidate a f) (MParser a)
piOptionParser = lens _piOptionParser $ \s a → s { _piOptionParser = a }
{-# INLINE piOptionParser #-}
-- | Default configuration
--
-piDefaultConfiguration ∷ Lens' (ProgramInfoValidate α λ) α
+piDefaultConfiguration ∷ Lens' (ProgramInfoValidate a f) a
piDefaultConfiguration = lens _piDefaultConfiguration $ \s a → s { _piDefaultConfiguration = a }
{-# INLINE piDefaultConfiguration #-}
@@ -225,14 +225,14 @@ piDefaultConfiguration = lens _piDefaultConfiguration $ \s a → s { _piDefaultC
--
-- The 'Right' result is interpreted as a 'Foldable' structure of warnings.
--
-piValidateConfiguration ∷ Lens' (ProgramInfoValidate α λ) (ConfigValidationFunction α λ)
+piValidateConfiguration ∷ Lens' (ProgramInfoValidate a f) (ConfigValidationFunction a f)
piValidateConfiguration = lens _piValidateConfiguration $ \s a → s { _piValidateConfiguration = a }
{-# INLINE piValidateConfiguration #-}
-- | Configuration files that are loaded in order before any command line
-- argument is evaluated.
--
-piConfigurationFiles ∷ Lens' (ProgramInfoValidate α λ) [ConfigFile]
+piConfigurationFiles ∷ Lens' (ProgramInfoValidate a f) [ConfigFile]
piConfigurationFiles = lens _piConfigurationFiles $ \s a → s { _piConfigurationFiles = a }
{-# INLINE piConfigurationFiles #-}
@@ -242,10 +242,10 @@ piConfigurationFiles = lens _piConfigurationFiles $ \s a → s { _piConfiguratio
--
piOptionParserAndDefaultConfiguration
∷ Lens
- (ProgramInfoValidate α λ)
- (ProgramInfoValidate β γ)
- (MParser α, α, ConfigValidationFunction α λ)
- (MParser β, β, ConfigValidationFunction β γ)
+ (ProgramInfoValidate a b)
+ (ProgramInfoValidate c d)
+ (MParser a, a, ConfigValidationFunction a b)
+ (MParser c, c, ConfigValidationFunction c d)
piOptionParserAndDefaultConfiguration = lens g $ \s (a,b,c) → ProgramInfo
{ _piDescription = _piDescription s
, _piHelpHeader = _piHelpHeader s
@@ -267,11 +267,11 @@ piOptionParserAndDefaultConfiguration = lens g $ \s (a,b,c) → ProgramInfo
programInfo
∷ String
-- ^ program description
- → MParser α
+ → MParser a
-- ^ parser for updating the default configuration
- → α
+ → a
-- ^ default configuration
- → ProgramInfo α
+ → ProgramInfo a
programInfo desc parser defaultConfig =
programInfoValidate desc parser defaultConfig $ const (return ())
@@ -281,10 +281,10 @@ programInfo desc parser defaultConfig =
--
programInfoValidate
∷ String
- → MParser α
- → α
- → ConfigValidation α λ
- → ProgramInfoValidate α λ
+ → MParser a
+ → a
+ → ConfigValidation a f
+ → ProgramInfoValidate a f
programInfoValidate desc parser defaultConfig valFunc = ProgramInfo
{ _piDescription = desc
, _piHelpHeader = Nothing
@@ -310,37 +310,37 @@ programInfoValidate desc parser defaultConfig valFunc = ProgramInfo
-- NOTE that /meta/ configuration settings can only be provided via command
-- line options but not through configuration files.
--
-data AppConfiguration α = AppConfiguration
+data AppConfiguration a = AppConfiguration
{ _printConfig ∷ !Bool
, _configFilesConfig ∷ !ConfigFilesConfig
, _configFiles ∷ ![ConfigFile]
- , _mainConfig ∷ !α
+ , _mainConfig ∷ !a
}
-- | A flag that indicates that the application should output the effective
-- configuration and exit.
--
-printConfig ∷ Lens' (AppConfiguration α) Bool
+printConfig ∷ Lens' (AppConfiguration a) Bool
printConfig = lens _printConfig $ \s a → s { _printConfig = a }
-- | The 'ConfigFilesConfig' collects all parameters that determine how
-- configuration files are loaded and parsed.
--
-configFilesConfig ∷ Lens' (AppConfiguration α) ConfigFilesConfig
+configFilesConfig ∷ Lens' (AppConfiguration a) ConfigFilesConfig
configFilesConfig = lens _configFilesConfig $ \s a → s { _configFilesConfig = a }
-- | A list of configuration file locations. Configuration file locations are
-- set either statically in the code or are provided dynamically on the command
-- line via @--config-file@ options.
--
-configFiles ∷ Lens' (AppConfiguration α) [ConfigFile]
+configFiles ∷ Lens' (AppConfiguration a) [ConfigFile]
configFiles = lens _configFiles $ \s a → s { _configFiles = a }
-- | The /user/ configuration. During parsing this is represented as an update
-- function that yields a configuration value when applied to a default
-- value.
--
-mainConfig ∷ Lens (AppConfiguration α) (AppConfiguration β) α β
+mainConfig ∷ Lens (AppConfiguration a) (AppConfiguration b) a b
mainConfig = lens _mainConfig $ \s a → s { _mainConfig = a }
-- | This function parsers /all/ command line options:
@@ -357,8 +357,8 @@ mainConfig = lens _mainConfig $ \s a → s { _mainConfig = a }
-- value when applied to an default value.
--
pAppConfiguration
- ∷ O.Parser (α → α)
- → O.Parser (AppConfiguration (α → α))
+ ∷ O.Parser (a → a)
+ → O.Parser (AppConfiguration (a → a))
pAppConfiguration mainParser = AppConfiguration
<$> pPrintConfig
<*> (pConfigFilesConfig <*> pure defaultConfigFilesConfig)
@@ -407,11 +407,11 @@ pAppConfiguration mainParser = AppConfiguration
-- to the service.
--
runWithConfiguration
- ∷ (FromJSON (α → α), ToJSON α, Foldable λ, Monoid (λ T.Text))
- ⇒ ProgramInfoValidate α λ
+ ∷ (FromJSON (a → a), ToJSON a, Foldable f, Monoid (f T.Text))
+ ⇒ ProgramInfoValidate a f
-- ^ program info value; use 'programInfo' to construct a value of this
-- type
- → (α → IO ())
+ → (a → IO ())
-- ^ computation that is given the configuration that is parsed from
-- the command line.
→ IO ()
@@ -420,7 +420,7 @@ runWithConfiguration appInfo = runInternal appInfo Nothing
-- -------------------------------------------------------------------------- --
-- Main Configuration with Package Info
-pPkgInfo ∷ PkgInfo → MParser α
+pPkgInfo ∷ PkgInfo → MParser a
pPkgInfo (sinfo, detailedInfo, version, license) =
infoO <*> detailedInfoO <*> versionO <*> licenseO
where
@@ -502,8 +502,8 @@ type PkgInfo =
-- to the service.
--
runWithPkgInfoConfiguration
- ∷ (FromJSON (α → α), ToJSON α, Foldable λ, Monoid (λ T.Text))
- ⇒ ProgramInfoValidate α λ
+ ∷ (FromJSON (a → a), ToJSON a, Foldable f, Monoid (f T.Text))
+ ⇒ ProgramInfoValidate a f
-- ^ program info value; use 'programInfo' to construct a value of this
-- type
→ PkgInfo
@@ -512,7 +512,7 @@ runWithPkgInfoConfiguration
-- See the documentation of "Configuration.Utils.Setup" for a way
-- how to generate this information automatically from the package
-- description during the build process.
- → (α → IO ())
+ → (a → IO ())
-- ^ computation that is given the configuration that is parsed from
-- the command line.
→ IO ()
@@ -523,16 +523,16 @@ runWithPkgInfoConfiguration appInfo pkgInfo =
-- Internal main function
mainOptions
- ∷ ∀ α λ . FromJSON (α → α)
- ⇒ ProgramInfoValidate α λ
+ ∷ ∀ a f . FromJSON (a → a)
+ ⇒ ProgramInfoValidate a f
-- ^ Program Info value which may include a validation function
- → (∀ β . Maybe (MParser β))
+ → (∀ b . Maybe (MParser b))
-- ^ Maybe a package info parser. This parser is run only for its
-- side effects. It is supposed to /intercept/ the parsing process
-- and execute any implied action (showing help messages).
- → O.ParserInfo (AppConfiguration (α → α))
+ → O.ParserInfo (AppConfiguration (a → a))
mainOptions ProgramInfo{..} pkgInfoParser = O.info optionParser
$ O.progDesc _piDescription
⊕ O.fullDesc
@@ -593,17 +593,17 @@ mainOptions ProgramInfo{..} pkgInfoParser = O.info optionParser
-- | Internal main function
--
runInternal
- ∷ (FromJSON (α → α), ToJSON α, Foldable λ, Monoid (λ T.Text))
- ⇒ ProgramInfoValidate α λ
+ ∷ (FromJSON (a → a), ToJSON a, Foldable f, Monoid (f T.Text))
+ ⇒ ProgramInfoValidate a f
-- ^ program info value; use 'programInfo' to construct a value of this
-- type
- → (∀ β . Maybe (MParser β))
+ → (∀ b . Maybe (MParser b))
-- 'PkgInfo' value that contains information about the package.
--
-- See the documentation of "Configuration.Utils.Setup" for a way
-- how to generate this information automatically from the package
-- description during the build process.
- → (α → IO ())
+ → (a → IO ())
-- ^ computation that is given the configuration that is parsed from
-- the command line.
→ IO ()
@@ -641,19 +641,19 @@ parseConfiguration
, MonadBaseControl IO m
#endif
, MonadError T.Text m
- , FromJSON (α → α)
- , ToJSON α
- , Foldable λ
- , Monoid (λ T.Text)
+ , FromJSON (a → a)
+ , ToJSON a
+ , Foldable f
+ , Monoid (f T.Text)
)
⇒ T.Text
-- ^ program name (used in error messages)
- → ProgramInfoValidate α λ
+ → ProgramInfoValidate a f
-- ^ program info value; use 'programInfo' to construct a value of this
-- type
→ [String]
-- ^ command line arguments
- → m α
+ → m a
parseConfiguration appName appInfo args = do
-- Parse command line arguments (add static config files to resulting app config)
@@ -685,9 +685,9 @@ parseConfiguration appName appInfo args = do
-- printed to 'stderr'.
--
validateConfig
- ∷ (Foldable λ, Monoid (λ T.Text))
- ⇒ ProgramInfoValidate α λ
- → α
+ ∷ (Foldable f, Monoid (f T.Text))
+ ⇒ ProgramInfoValidate a f
+ → a
→ IO ()
validateConfig appInfo conf = do
warnings ← execWriterT ∘ exceptT (error ∘ T.unpack) return $
diff --git a/src/Configuration/Utils/CommandLine.hs b/src/Configuration/Utils/CommandLine.hs
index 324fdf4..c752b86 100644
--- a/src/Configuration/Utils/CommandLine.hs
+++ b/src/Configuration/Utils/CommandLine.hs
@@ -79,7 +79,7 @@ import Prelude.Unicode
-- | Type of option parsers that yield a modification function.
--
-type MParser α = O.Parser (α → α)
+type MParser a = O.Parser (a → a)
-- | An operator for applying a setter to an option parser that yields a value.
--
@@ -90,10 +90,10 @@ type MParser α = O.Parser (α → α)
-- > , _pwd ∷ !String
-- > }
-- >
--- > user ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth
+-- > user ∷ Functor f ⇒ (String → f String) → Auth → f Auth
-- > user f s = (\u → s { _user = u }) <$> f (_user s)
-- >
--- > pwd ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth
+-- > pwd ∷ Functor f ⇒ (String → f String) → Auth → f Auth
-- > pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s)
-- >
-- > -- or with lenses and TemplateHaskell just:
@@ -109,7 +109,7 @@ type MParser α = O.Parser (α → α)
-- > × long "pwd"
-- > ⊕ help "password for user"
--
-(.::) ∷ (Alternative φ, Applicative φ) ⇒ Lens' α β → φ β → φ (α → α)
+(.::) ∷ (Alternative f, Applicative f) ⇒ Lens' a b → f b → f (a → a)
(.::) a opt = set a <$> opt <|> pure id
infixr 5 .::
{-# INLINE (.::) #-}
@@ -124,13 +124,13 @@ infixr 5 .::
-- > , _domain ∷ !String
-- > }
-- >
--- > auth ∷ Functor φ ⇒ (Auth → φ Auth) → HttpURL → φ HttpURL
+-- > auth ∷ Functor f ⇒ (Auth → f Auth) → HttpURL → f HttpURL
-- > auth f s = (\u → s { _auth = u }) <$> f (_auth s)
-- >
--- > domain ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL
+-- > domain ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL
-- > domain f s = (\u → s { _domain = u }) <$> f (_domain s)
-- >
--- > path ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL
+-- > path ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL
-- > path f s = (\u → s { _path = u }) <$> f (_path s)
-- >
-- > -- or with lenses and TemplateHaskell just:
@@ -144,7 +144,7 @@ infixr 5 .::
-- > ⊕ short 'd'
-- > ⊕ help "HTTP domain"
--
-(%::) ∷ (Alternative φ, Applicative φ) ⇒ Lens' α β → φ (β → β) → φ (α → α)
+(%::) ∷ (Alternative f, Applicative f) ⇒ Lens' a b → f (b → b) → f (a → a)
(%::) a opt = over a <$> opt <|> pure id
infixr 5 %::
{-# INLINE (%::) #-}
diff --git a/src/Configuration/Utils/ConfigFile.hs b/src/Configuration/Utils/ConfigFile.hs
index 6a9fc53..1751002 100644
--- a/src/Configuration/Utils/ConfigFile.hs
+++ b/src/Configuration/Utils/ConfigFile.hs
@@ -1,7 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -91,10 +90,10 @@ import Configuration.Utils.Operators
-- > , _pwd ∷ !String
-- > }
-- >
--- > userId ∷ Functor φ ⇒ (Int → φ Int) → Auth → φ Auth
+-- > userId ∷ Functor f ⇒ (Int → f Int) → Auth → f Auth
-- > userId f s = (\u → s { _userId = u }) <$> f (_userId s)
-- >
--- > pwd ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth
+-- > pwd ∷ Functor f ⇒ (String → f String) → Auth → f Auth
-- > pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s)
-- >
-- > -- or with lenses and TemplateHaskell just:
@@ -111,11 +110,11 @@ import Configuration.Utils.Operators
-- > e → fail $ "unrecognized user " ⊕ e
--
setProperty
- ∷ Lens' α β -- ^ a lens into the target that is updated by the parser
+ ∷ Lens' a b -- ^ 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
+ → (Value → Parser b) -- ^ the JSON 'Value' parser that is used to parse the value of the property
→ Object -- ^ the parsed JSON 'Value' 'Object'
- → Parser (α → α)
+ → Parser (a → a)
setProperty s k p o = case H.lookup k o of
Nothing → pure id
Just v → set s <$> p v
@@ -129,10 +128,10 @@ setProperty s k p o = case H.lookup k o of
-- > , _pwd ∷ !String
-- > }
-- >
--- > user ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth
+-- > user ∷ Functor f ⇒ (String → f String) → Auth → f Auth
-- > user f s = (\u → s { _user = u }) <$> f (_user s)
-- >
--- > pwd ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth
+-- > pwd ∷ Functor f ⇒ (String → f String) → Auth → f Auth
-- > pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s)
-- >
-- > -- or with lenses and TemplateHaskell just:
@@ -143,7 +142,7 @@ setProperty s k p o = case H.lookup k o of
-- > <$< user ..: "user" × o
-- > <*< pwd ..: "pwd" × o
--
-(..:) ∷ FromJSON β ⇒ Lens' α β → T.Text → Object → Parser (α → α)
+(..:) ∷ FromJSON b ⇒ Lens' a b → T.Text → Object → Parser (a → a)
(..:) s k = setProperty s k parseJSON
infix 6 ..:
{-# INLINE (..:) #-}
@@ -152,18 +151,22 @@ infix 6 ..:
-- of a given 'Object' and updates a setter with the parsed
-- function.
--
+-- This function is useful when a 'FromJSON' instance isn't available.
+-- When a 'FromJSON' instance exists, the '%.:' provides a more
+-- ideomatic alternative.
+--
-- > data HttpURL = HttpURL
-- > { _auth ∷ !Auth
-- > , _domain ∷ !String
-- > }
-- >
--- > auth ∷ Functor φ ⇒ (Auth → φ Auth) → HttpURL → φ HttpURL
+-- > auth ∷ Functor f ⇒ (Auth → f Auth) → HttpURL → f HttpURL
-- > auth f s = (\u → s { _auth = u }) <$> f (_auth s)
-- >
--- > domain ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL
+-- > domain ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL
-- > domain f s = (\u → s { _domain = u }) <$> f (_domain s)
-- >
--- > path ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL
+-- > path ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL
-- > path f s = (\u → s { _path = u }) <$> f (_path s)
-- >
-- > -- or with lenses and TemplateHaskell just:
@@ -171,21 +174,21 @@ infix 6 ..:
-- >
-- > instance FromJSON (HttpURL → HttpURL) where
-- > parseJSON = withObject "HttpURL" $ \o → id
--- > <$< auth %.: "auth" × o
--- > <*< domain ..: "domain" × o
+-- > <$< updateProperty auth "auth" parseJSON o
+-- > <*< setProperty domain "domain" parseJSON o
--
updateProperty
- ∷ Lens' α β
+ ∷ Lens' a b
→ T.Text
- → (Value → Parser (β → β))
+ → (Value → Parser (b → b))
→ Object
- → Parser (α → α)
+ → Parser (a → a)
updateProperty s k p o = case H.lookup k o of
Nothing → pure id
Just v → over s <$> p v
{-# INLINE updateProperty #-}
--- | A variant of 'updateProperty' that used the 'FromJSON' instance
+-- | A variant of 'updateProperty' that uses the 'FromJSON' instance
-- for the update function. It mimics the aeson operator '.:'.
-- It creates a parser that modifies a setter with a parsed function.
--
@@ -194,13 +197,13 @@ updateProperty s k p o = case H.lookup k o of
-- > , _domain ∷ !String
-- > }
-- >
--- > auth ∷ Functor φ ⇒ (Auth → φ Auth) → HttpURL → φ HttpURL
+-- > auth ∷ Functor f ⇒ (Auth → f Auth) → HttpURL → f HttpURL
-- > auth f s = (\u → s { _auth = u }) <$> f (_auth s)
-- >
--- > domain ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL
+-- > domain ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL
-- > domain f s = (\u → s { _domain = u }) <$> f (_domain s)
-- >
--- > path ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL
+-- > path ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL
-- > path f s = (\u → s { _path = u }) <$> f (_path s)
-- >
-- > -- or with lenses and TemplateHaskell just:
@@ -211,7 +214,7 @@ updateProperty s k p o = case H.lookup k o of
-- > <$< auth %.: "auth" × o
-- > <*< domain ..: "domain" × o
--
-(%.:) ∷ FromJSON (β → β) ⇒ Lens' α β → T.Text → Object → Parser (α → α)
+(%.:) ∷ FromJSON (b → b) ⇒ Lens' a b → T.Text → Object → Parser (a → a)
(%.:) s k = updateProperty s k parseJSON
infix 6 %.:
{-# INLINE (%.:) #-}
@@ -221,11 +224,11 @@ infix 6 %.:
-- Otherwise this operator does the same as '(..:)'.
--
(!..:)
- ∷ FromJSON β
- ⇒ Lens' α β
+ ∷ FromJSON b
+ ⇒ Lens' a b
→ T.Text
→ Object
- → Parser (α → α)
+ → Parser (a → a)
(!..:) l property o = set l <$> (o .: property)
{-# INLINE (!..:) #-}
diff --git a/src/Configuration/Utils/Http.hs b/src/Configuration/Utils/Http.hs
index 5e9147e..5b82aee 100644
--- a/src/Configuration/Utils/Http.hs
+++ b/src/Configuration/Utils/Http.hs
@@ -86,7 +86,7 @@ defaultHttpServiceTLSConfiguration = HttpServiceTLSConfiguration
}
validateHttpServiceTLSConfiguration
- ∷ ConfigValidation HttpServiceTLSConfiguration λ
+ ∷ ConfigValidation HttpServiceTLSConfiguration f
validateHttpServiceTLSConfiguration conf = do
validateFileReadable "cert-file" $ _hstcCertFile conf
validateFileReadable "key-file" $ _hstcKeyFile conf
@@ -237,7 +237,7 @@ defaultHttpClientConfiguration = HttpClientConfiguration
, _hccUseTLS = False
}
-validateHttpClientConfiguration ∷ ConfigValidation HttpClientConfiguration λ
+validateHttpClientConfiguration ∷ ConfigValidation HttpClientConfiguration f
validateHttpClientConfiguration conf = do
validatePort "port" $ _hccPort conf
validateNonEmpty "host" $ _hccHost conf
diff --git a/src/Configuration/Utils/Internal.hs b/src/Configuration/Utils/Internal.hs
index 7ea9582..8d11318 100644
--- a/src/Configuration/Utils/Internal.hs
+++ b/src/Configuration/Utils/Internal.hs
@@ -62,28 +62,28 @@ infixl 1 &, <&>
-- In case it is already import from the lens package this should be hidden
-- from the import.
--
-type Lens σ τ α β = ∀ φ . Functor φ ⇒ (α → φ β) → σ → φ τ
+type Lens s t a b = ∀ f . Functor f ⇒ (a → f b) → s → f t
-- | This is 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 Lens' σ α = Lens σ σ α α
+type Lens' s a = Lens s s a a
-lens ∷ (σ → α) → (σ → β → τ) → Lens σ τ α β
+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 ∷ ((α → Identity β) → σ → Identity τ) → (α → β) → σ → τ
+over ∷ ((a → Identity b) → s → Identity t) → (a → b) → s → t
over s f = runIdentity . s (Identity . f)
{-# INLINE over #-}
-set ∷ ((α → Identity β) → σ → Identity τ) → β → σ → τ
+set ∷ ((a → Identity b) → s → Identity t) → b → s → t
set s a = runIdentity . s (const $ Identity a)
{-# INLINE set #-}
-view ∷ MonadReader σ μ ⇒ ((α → Const α α) → σ → Const α σ) → μ α
+view ∷ MonadReader r m ⇒ ((a → Const a a) → r → Const a r) → m a
view l = asks (getConst #. l Const)
{-# INLINE view #-}
@@ -92,48 +92,48 @@ view l = asks (getConst #. l Const)
-- In case it is already import from the lens package this should be hidden
-- from the import.
--
-type Iso σ τ α β = ∀ π φ . (Profunctor π, Functor φ) ⇒ π α (φ β) → π σ (φ τ)
-type Iso' σ α = Iso σ σ α α
+type Iso s t a b = ∀ p f . (Profunctor p, Functor f) ⇒ p a (f b) → p s (f t)
+type Iso' s a = Iso s s a a
-iso ∷ (σ → α) → (β → τ) → Iso σ τ α β
+iso ∷ (s → a) → (b → t) → Iso s t a b
iso f g = dimap f (fmap g)
{-# INLINE iso #-}
-- -------------------------------------------------------------------------- --
-- Misc Utils
-(&) ∷ α → (α → β) → β
+(&) ∷ a → (a → b) → b
(&) = flip ($)
{-# INLINE (&) #-}
-(<&>) ∷ Functor φ ⇒ φ α → (α → β) → φ β
+(<&>) ∷ Functor f ⇒ f a → (a → b) → f b
(<&>) = flip fmap
{-# INLINE (<&>) #-}
sshow
- ∷ (Show α, IsString τ)
- ⇒ α
- → τ
+ ∷ (Show a, IsString s)
+ ⇒ a
+ → s
sshow = fromString ∘ show
{-# INLINE sshow #-}
exceptT
- ∷ Monad μ
- ⇒ (ε → μ β)
- → (α → μ β)
- → ExceptT ε μ α
- → μ β
+ ∷ Monad m
+ ⇒ (e → m b)
+ → (a → m b)
+ → ExceptT e m a
+ → m b
exceptT a b = runExceptT >=> either a b
{-# INLINE exceptT #-}
errorT
- ∷ Monad μ
- ⇒ ExceptT T.Text μ α
- → μ α
+ ∷ Monad m
+ ⇒ ExceptT T.Text m a
+ → m a
errorT = exceptT (\e → error ∘ T.unpack $ "Error: " ⊕ e) return
{-# INLINE errorT #-}
-fmapL ∷ (α → β) → Either α γ → Either β γ
+fmapL ∷ (a → b) → Either a c → Either b c
fmapL f = either (Left ∘ f) Right
{-# INLINE fmapL #-}
diff --git a/src/Configuration/Utils/Internal/ConfigFileReader.hs b/src/Configuration/Utils/Internal/ConfigFileReader.hs
index 67d3f63..1151f69 100644
--- a/src/Configuration/Utils/Internal/ConfigFileReader.hs
+++ b/src/Configuration/Utils/Internal/ConfigFileReader.hs
@@ -79,39 +79,39 @@ import System.IO
-- Tools for parsing configuration files
#ifdef REMOTE_CONFIGS
-type ConfigFileParser μ =
- ( Functor μ
- , Applicative μ
- , MonadIO μ
- , MonadBaseControl IO μ
- , MonadError T.Text μ
+type ConfigFileParser m =
+ ( Functor m
+ , Applicative m
+ , MonadIO m
+ , MonadBaseControl IO m
+ , MonadError T.Text m
)
#else
-type ConfigFileParser μ =
- ( Functor μ
- , Applicative μ
- , MonadIO μ
- , MonadError T.Text μ
+type ConfigFileParser m =
+ ( Functor m
+ , Applicative m
+ , MonadIO m
+ , MonadError T.Text m
)
#endif
parseConfigFiles
- ∷ (ConfigFileParser μ, FromJSON (α → α))
+ ∷ (ConfigFileParser m, FromJSON (a → a))
⇒ ConfigFilesConfig
- → α
+ → a
-- ^ default configuration value
→ [ConfigFile]
-- ^ list of configuration file paths
- → μ α
+ → m a
parseConfigFiles conf = foldM $ \val file →
readConfigFile conf file <*> pure val
readConfigFile
- ∷ (ConfigFileParser μ, FromJSON (α → α))
+ ∷ (ConfigFileParser m, FromJSON (a → a))
⇒ ConfigFilesConfig
→ ConfigFile
-- ^ file path
- → μ (α → α)
+ → m (a → a)
readConfigFile _conf file =
#ifdef REMOTE_CONFIGS
if isRemote file then loadRemote _conf file else loadLocal file
@@ -128,10 +128,10 @@ fileType f
| otherwise = Other
loadLocal
- ∷ (Functor μ, MonadIO μ, MonadError T.Text μ, FromJSON (α → α))
+ ∷ (Functor m, MonadIO m, MonadError T.Text m, FromJSON (a → a))
⇒ ConfigFile
-- ^ file path
- → μ (α → α)
+ → m (a → a)
loadLocal path = do
validateFilePath "config-file" (T.unpack file)
exists ← (True <$ validateFile "config-file" (T.unpack file)) `catchError` \e → case path of
@@ -182,11 +182,11 @@ contentType headerValue
| otherwise = Other
loadRemote
- ∷ (ConfigFileParser μ, FromJSON (α → α))
+ ∷ (ConfigFileParser m, FromJSON (a → a))
⇒ ConfigFilesConfig
→ ConfigFile
-- ^ URL
- → μ (α → α)
+ → m (a → a)
loadRemote conf path = do
validateHttpOrHttpsUrl "config-file" (T.unpack url)
result ← (Just <$> doHttp) `catchAnyDeep` \e →
diff --git a/src/Configuration/Utils/Monoid.hs b/src/Configuration/Utils/Monoid.hs
index 8260fa7..0c0f0f3 100644
--- a/src/Configuration/Utils/Monoid.hs
+++ b/src/Configuration/Utils/Monoid.hs
@@ -35,6 +35,7 @@ import Configuration.Utils.Internal
import Control.Monad.Writer hiding (mapM_)
import Data.Aeson
+import Data.Semigroup
import qualified Options.Applicative.Types as O
@@ -45,10 +46,10 @@ import Prelude.Unicode
-- circumstances you'll never use this type directly but only
-- its 'FromJSON' instance. See the 'leftMonoidalUpdate' for an example.
--
-newtype LeftMonoidalUpdate α = LeftMonoidalUpdate
- { _getLeftMonoidalUpdate ∷ α
+newtype LeftMonoidalUpdate a = LeftMonoidalUpdate
+ { _getLeftMonoidalUpdate ∷ a
}
- deriving (Monoid)
+ deriving (Semigroup, Monoid)
-- | Update a value by appending on the left.
--
@@ -60,16 +61,16 @@ newtype LeftMonoidalUpdate α = LeftMonoidalUpdate
-- > parseJSON = withObject "RoutingTable" $ \o → id
-- > <$< routingTableMap . from leftMonoidalUpdate %.: "route_map" % o
--
-leftMonoidalUpdate ∷ Iso (LeftMonoidalUpdate α) (LeftMonoidalUpdate β) α β
+leftMonoidalUpdate ∷ Iso (LeftMonoidalUpdate a) (LeftMonoidalUpdate b) a b
leftMonoidalUpdate = iso _getLeftMonoidalUpdate LeftMonoidalUpdate
-- | This is the same as @from leftMonoidalUpdate@ but doesn't depend on
-- the lens Library.
--
-fromLeftMonoidalUpdate ∷ Iso α β (LeftMonoidalUpdate α) (LeftMonoidalUpdate β)
+fromLeftMonoidalUpdate ∷ Iso a b (LeftMonoidalUpdate a) (LeftMonoidalUpdate b)
fromLeftMonoidalUpdate = iso LeftMonoidalUpdate _getLeftMonoidalUpdate
-instance (FromJSON α, Monoid α) ⇒ FromJSON (LeftMonoidalUpdate α → LeftMonoidalUpdate α) where
+instance (FromJSON a, Monoid a) ⇒ FromJSON (LeftMonoidalUpdate a → LeftMonoidalUpdate a) where
parseJSON = fmap (mappend ∘ LeftMonoidalUpdate) ∘ parseJSON
-- | Update a value by appending on the left.
@@ -95,36 +96,36 @@ instance (FromJSON α, Monoid α) ⇒ FromJSON (LeftMonoidalUpdate α → LeftMo
-- >
-- > fmapL f = either (Left . f) Right
--
-pLeftMonoidalUpdate ∷ Monoid α ⇒ O.Parser α → MParser α
+pLeftMonoidalUpdate ∷ Monoid a ⇒ O.Parser a → MParser a
pLeftMonoidalUpdate pElement = mappend ∘ mconcat ∘ reverse <$> many pElement
-- | Update a value by appending on the right. Under normal
-- circumstances you'll never use this type directly but only
-- its 'FromJSON' instance. See the 'leftMonoidalUpdate' for an example.
--
-newtype RightMonoidalUpdate α = RightMonoidalUpdate
- { _getRightMonoidalUpdate ∷ α
+newtype RightMonoidalUpdate a = RightMonoidalUpdate
+ { _getRightMonoidalUpdate ∷ a
}
- deriving (Monoid)
+ deriving (Semigroup, Monoid)
-- | Update a value by appending on the right. See 'leftMonoidalUpdate' for
-- an usage example.
--
-rightMonoidalUpdate ∷ Iso (RightMonoidalUpdate α) (RightMonoidalUpdate β) α β
+rightMonoidalUpdate ∷ Iso (RightMonoidalUpdate a) (RightMonoidalUpdate b) a b
rightMonoidalUpdate = iso _getRightMonoidalUpdate RightMonoidalUpdate
-- | This is the same as @from rightMonoidalUpdate@ but doesn't depend on
-- the lens Library.
--
-fromRightMonoidalUpdate ∷ Iso α β (RightMonoidalUpdate α) (RightMonoidalUpdate β)
+fromRightMonoidalUpdate ∷ Iso a b (RightMonoidalUpdate a) (RightMonoidalUpdate b)
fromRightMonoidalUpdate = iso RightMonoidalUpdate _getRightMonoidalUpdate
-instance (FromJSON α, Monoid α) ⇒ FromJSON (RightMonoidalUpdate α → RightMonoidalUpdate α) where
+instance (FromJSON a, Monoid a) ⇒ FromJSON (RightMonoidalUpdate a → RightMonoidalUpdate a) where
parseJSON = fmap (flip mappend ∘ RightMonoidalUpdate) ∘ parseJSON
-- | Update a value by appending on the right. See 'pLeftMonoidalUpdate'
-- for an usage example.
--
-pRightMonoidalUpdate ∷ Monoid α ⇒ O.Parser α → MParser α
+pRightMonoidalUpdate ∷ Monoid a ⇒ O.Parser a → MParser a
pRightMonoidalUpdate pElement = flip mappend ∘ mconcat <$> many pElement
diff --git a/src/Configuration/Utils/Operators.hs b/src/Configuration/Utils/Operators.hs
index 923a44e..f7313ca 100644
--- a/src/Configuration/Utils/Operators.hs
+++ b/src/Configuration/Utils/Operators.hs
@@ -40,7 +40,7 @@ import Control.Applicative
-- suitable for usage within applicative style code without the need to add
-- parenthesis.
--
-(%) ∷ (α → β) → α → β
+(%) ∷ (a → b) → a → b
(%) = ($)
infixr 5 %
{-# INLINE (%) #-}
@@ -58,14 +58,14 @@ infixr 5 %
--
-- > iabbrev <buffer> >< ×
--
-(×) ∷ (α → β) → α → β
+(×) ∷ (a → b) → a → b
(×) = ($)
infixr 5 ×
{-# INLINE (×) #-}
-- | Functional composition for applicative functors.
--
-(<*<) ∷ Applicative φ ⇒ φ (β → γ) → φ (α → β) → φ (α → γ)
+(<*<) ∷ Applicative f ⇒ f (b → c) → f (a → b) → f (a → c)
(<*<) a b = pure (.) <*> a <*> b
infixr 4 <*<
{-# INLINE (<*<) #-}
@@ -73,7 +73,7 @@ infixr 4 <*<
-- | Functional composition for applicative functors with its arguments
-- flipped.
--
-(>*>) ∷ Applicative φ ⇒ φ (α → β) → φ (β → γ) → φ (α → γ)
+(>*>) ∷ Applicative f ⇒ f (a → b) → f (b → c) → f (a → c)
(>*>) = flip (<*<)
infixr 4 >*>
{-# INLINE (>*>) #-}
@@ -81,7 +81,7 @@ infixr 4 >*>
-- | Applicative functional composition between a pure function
-- and an applicative function.
--
-(<$<) ∷ Functor φ ⇒ (β → γ) → φ (α → β) → φ (α → γ)
+(<$<) ∷ Functor f ⇒ (b → c) → f (a → b) → f (a → c)
(<$<) a b = (a .) <$> b
infixr 4 <$<
{-# INLINE (<$<) #-}
@@ -89,7 +89,7 @@ infixr 4 <$<
-- | Applicative functional composition between a pure function
-- and an applicative function with its arguments flipped.
--
-(>$>) ∷ Functor φ ⇒ φ (α → β) → (β → γ) → φ (α → γ)
+(>$>) ∷ Functor f ⇒ f (a → b) → (b → c) → f (a → c)
(>$>) = flip (<$<)
infixr 4 >$>
{-# INLINE (>$>) #-}
@@ -99,7 +99,7 @@ infixr 4 >$>
-- This is a rather popular operator. Due to conflicts (for instance with the
-- lens package) it may have to be imported qualified.
--
-(<.>) ∷ Applicative φ ⇒ φ (β → γ) → φ (α → β) → φ (α → γ)
+(<.>) ∷ Applicative f ⇒ f (b → c) → f (a → b) → f (a → c)
(<.>) = (<*<)
infixr 4 <.>
{-# INLINE (<.>) #-}
@@ -114,7 +114,7 @@ infixr 4 <.>
--
-- > iabbrev <buffer> ../ ⊙
--
-(⊙) ∷ Applicative φ ⇒ φ (β → γ) → φ (α → β) → φ (α → γ)
+(⊙) ∷ Applicative f ⇒ f (b → c) → f (a → b) → f (a → c)
(⊙) = (<.>)
infixr 4 ⊙
{-# INLINE (⊙) #-}
diff --git a/src/Configuration/Utils/Setup.hs b/src/Configuration/Utils/Setup.hs
index 957f814..98aeb10 100644
--- a/src/Configuration/Utils/Setup.hs
+++ b/src/Configuration/Utils/Setup.hs
@@ -129,6 +129,10 @@ import Distribution.Types.LocalBuildInfo
import Distribution.Types.UnqualComponentName
#endif
+#if MIN_VERSION_Cabal(2,2,0)
+import Distribution.Pretty
+#endif
+
import System.Process
import Control.Applicative
@@ -209,6 +213,8 @@ pkgInfoModuleName (Just cn) = "PkgInfo_" ++ map tr cn
tr '-' = '_'
tr c = c
+-- FIXME: autoModulesDir is deprecated and should be replaced by
+-- autogenComponentModulesDir.
pkgInfoFileName :: Maybe String -> LocalBuildInfo -> FilePath
pkgInfoFileName cn bInfo = autogenModulesDir bInfo ++ "/" ++ pkgInfoModuleName cn ++ ".hs"
@@ -235,6 +241,16 @@ unFlagName :: FlagName -> String
unFlagName (FlagName s) = s
#endif
+#if !MIN_VERSION_Cabal(2,2,0)
+unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)]
+unFlagAssignment = id
+#endif
+
+#if !MIN_VERSION_Cabal(2,2,0)
+prettyShow :: Text a => a -> String
+prettyShow = display
+#endif
+
pkgInfoModule :: Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString
pkgInfoModule cName pkgDesc bInfo = do
(tag, revision, branch) <- getVCS >>= \x -> case x of
@@ -244,7 +260,7 @@ pkgInfoModule cName pkgDesc bInfo = do
let vcsBranch = if branch == "default" || branch == "master" then "" else branch
vcsVersion = intercalate "-" . filter (/= "") $ [tag, revision, vcsBranch]
- flags = map (unFlagName . fst) . filter snd . configConfigurationsFlags . configFlags $ bInfo
+ flags = map (unFlagName . fst) . filter snd . unFlagAssignment . configConfigurationsFlags . configFlags $ bInfo
licenseString <- licenseFilesText pkgDesc
@@ -288,7 +304,7 @@ pkgInfoModule cName pkgDesc bInfo = do
, " arch = \"" <> (pack . display . hostPlatform) bInfo <> "\""
, ""
, " license :: IsString a => a"
- , " license = \"" <> (pack . display . license) pkgDesc <> "\""
+ , " license = \"" <> (pack . prettyShow . license) pkgDesc <> "\""
, ""
, " licenseText :: IsString a => a"
, " licenseText = " <> (pack . show) licenseString
@@ -450,7 +466,11 @@ noVcsInfo = return ("", "", "")
pkgIdWithLicense :: I.InstalledPackageInfo -> String
pkgIdWithLicense a = (display . packageId) a
++ " ["
- ++ (display . I.license) a
+#if MIN_VERSION_Cabal(2,2,0)
+ ++ (either prettyShow prettyShow . I.license) a
+#else
+ ++ (prettyShow . I.license) a
+#endif
++ (if cr /= "" then ", " ++ cr else "")
++ "]"
where
diff --git a/src/Configuration/Utils/Validation.hs b/src/Configuration/Utils/Validation.hs
index 7b096ff..fecd458 100644
--- a/src/Configuration/Utils/Validation.hs
+++ b/src/Configuration/Utils/Validation.hs
@@ -95,7 +95,7 @@ import System.Directory
-- | A validation function. The type in the 'MonadWriter' is excpected to
-- be a 'Foldable' structure for collecting warnings.
--
-type ConfigValidation α λ = ∀ μ . (MonadIO μ, Functor μ, Applicative μ, MonadError T.Text μ, MonadWriter (λ T.Text) μ) ⇒ α → μ ()
+type ConfigValidation a f = ∀ m . (MonadIO m, Functor m, Applicative m, MonadError T.Text m, MonadWriter (f T.Text) m) ⇒ a → m ()
-- -------------------------------------------------------------------------- --
-- Networking
@@ -216,60 +216,60 @@ validatePort configName p =
-- Monoids, Foldables, and Co
validateNonEmpty
- ∷ (MonadError T.Text m, Eq α, Monoid α)
+ ∷ (MonadError T.Text m, Eq a, Monoid a)
⇒ T.Text
-- ^ configuration property name that is used in the error message
- → α
+ → a
→ m ()
validateNonEmpty configName x =
when (x ≡ mempty) ∘ throwError $
"value for " ⊕ configName ⊕ " must not be empty"
validateLength
- ∷ (MonadError T.Text m, F.Foldable φ)
+ ∷ (MonadError T.Text m, F.Foldable f)
⇒ T.Text
-- ^ configuration property name that is used in the error message
→ Int
-- ^ exact length of the validated value
- → φ α
+ → f a
→ m ()
validateLength configName len x =
unless (length (F.toList x) ≡ len) ∘ throwError $
"value for " ⊕ configName ⊕ " must be of length exactly " ⊕ sshow len
validateMaxLength
- ∷ (MonadError T.Text m, F.Foldable φ)
+ ∷ (MonadError T.Text m, F.Foldable f)
⇒ T.Text
-- ^ configuration property name that is used in the error message
→ Int
-- ^ maximum length of the validated value
- → φ α
+ → f a
→ m ()
validateMaxLength configName u x =
unless (length (F.toList x) ≤ u) ∘ throwError $
"value for " ⊕ configName ⊕ " must be of length at most " ⊕ sshow u
validateMinLength
- ∷ (MonadError T.Text m, F.Foldable φ)
+ ∷ (MonadError T.Text m, F.Foldable f)
⇒ T.Text
-- ^ configuration property name that is used in the error message
→ Int
-- ^ minimum length of the validated value
- → φ α
+ → f a
→ m ()
validateMinLength configName l x =
unless (length (F.toList x) ≥ l) ∘ throwError $
"value for " ⊕ configName ⊕ " must be of length at least " ⊕ sshow l
validateMinMaxLength
- ∷ (MonadError T.Text m, F.Foldable φ)
+ ∷ (MonadError T.Text m, F.Foldable f)
⇒ T.Text
-- ^ configuration property name that is used in the error message
→ Int
-- ^ minimum length of the validated value
→ Int
-- ^ maximum length of the validated value
- → φ α
+ → f a
→ m ()
validateMinMaxLength configName l u x =
unless (len ≥ l && len ≤ u) ∘ throwError $
@@ -411,50 +411,50 @@ validateBool configName expected x = unless (x ≡ expected) ∘ throwError $
-- Numeric Values
validateNonNegative
- ∷ (MonadError T.Text m, Ord α, Num α)
+ ∷ (MonadError T.Text m, Ord a, Num a)
⇒ T.Text
-- ^ configuration property name that is used in the error message
- → α
+ → a
→ m ()
validateNonNegative configName x =
when (x < 0) ∘ throwError $
"value for " ⊕ configName ⊕ " must not be negative"
validatePositive
- ∷ (MonadError T.Text m, Ord α, Num α)
+ ∷ (MonadError T.Text m, Ord a, Num a)
⇒ T.Text
-- ^ configuration property name that is used in the error message
- → α
+ → a
→ m ()
validatePositive configName x =
when (x ≤ 0) ∘ throwError $
"value for " ⊕ configName ⊕ " must be positive"
validateNonPositive
- ∷ (MonadError T.Text m, Ord α, Num α)
+ ∷ (MonadError T.Text m, Ord a, Num a)
⇒ T.Text
-- ^ configuration property name that is used in the error message
- → α
+ → a
→ m ()
validateNonPositive configName x =
when (x > 0) ∘ throwError $
"value for " ⊕ configName ⊕ " must not be positive"
validateNegative
- ∷ (MonadError T.Text m, Ord α, Num α)
+ ∷ (MonadError T.Text m, Ord a, Num a)
⇒ T.Text
-- ^ configuration property name that is used in the error message
- → α
+ → a
→ m ()
validateNegative configName x =
when (x ≥ 0) ∘ throwError $
"value for " ⊕ configName ⊕ " must be negative"
validateNonNull
- ∷ (MonadError T.Text m, Eq α, Num α)
+ ∷ (MonadError T.Text m, Eq a, Num a)
⇒ T.Text
-- ^ configuration property name that is used in the error message
- → α
+ → a
→ m ()
validateNonNull configName x = when (x ≡ 0) ∘ throwError $
"value for " ⊕ configName ⊕ " must not be zero"
@@ -463,56 +463,56 @@ validateNonNull configName x = when (x ≡ 0) ∘ throwError $
-- Orders
validateLess
- ∷ (MonadError T.Text m, Ord α, Show α)
+ ∷ (MonadError T.Text m, Ord a, Show a)
⇒ T.Text
-- ^ configuration property name that is used in the error message
- → α
+ → a
-- ^ a strict upper bound for the configuration value
- → α
+ → a
→ m ()
validateLess configName upper x = unless (x < upper) ∘ throwError $
"value for " ⊕ configName ⊕ " must be strictly less than " ⊕ sshow upper ⊕ ", but was " ⊕ sshow x
validateLessEq
- ∷ (MonadError T.Text m, Ord α, Show α)
+ ∷ (MonadError T.Text m, Ord a, Show a)
⇒ T.Text
-- ^ configuration property name that is used in the error message
- → α
+ → a
-- ^ a upper bound for the configuration value
- → α
+ → a
→ m ()
validateLessEq configName upper x = unless (x ≤ upper) ∘ throwError $
"value for " ⊕ configName ⊕ " must be less or equal than " ⊕ sshow upper ⊕ ", but was " ⊕ sshow x
validateGreater
- ∷ (MonadError T.Text m, Ord α, Show α)
+ ∷ (MonadError T.Text m, Ord a, Show a)
⇒ T.Text
-- ^ configuration property name that is used in the error message
- → α
+ → a
-- ^ a strict lower bound for the configuration value
- → α
+ → a
→ m ()
validateGreater configName lower x = unless (x > lower) ∘ throwError $
"value for " ⊕ configName ⊕ " must be strictly greater than " ⊕ sshow lower ⊕ ", but was " ⊕ sshow x
validateGreaterEq
- ∷ (MonadError T.Text m, Ord α, Show α)
+ ∷ (MonadError T.Text m, Ord a, Show a)
⇒ T.Text
-- ^ configuration property name that is used in the error message
- → α
+ → a
-- ^ a lower bound for the configuration value
- → α
+ → a
→ m ()
validateGreaterEq configName lower x = unless (x ≥ lower) ∘ throwError $
"value for " ⊕ configName ⊕ " must be greater or equal than " ⊕ sshow lower ⊕ ", but was " ⊕ sshow x
validateRange
- ∷ (MonadError T.Text m, Ord α, Show α)
+ ∷ (MonadError T.Text m, Ord a, Show a)
⇒ T.Text
-- ^ configuration property name that is used in the error message
- → (α, α)
+ → (a, a)
-- ^ the valid range for the configuration value
- → α
+ → a
→ 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
diff --git a/test/TestTools.hs b/test/TestTools.hs
index 9a4ec19..b9b5c20 100644
--- a/test/TestTools.hs
+++ b/test/TestTools.hs
@@ -102,12 +102,12 @@ debug a
-- 2. lens for the configuration value
-- 3. the expected value
--
-data ConfAssertion β = ∀ α . Eq α ⇒ ConfAssertion [String] (Lens' β α) α
+data ConfAssertion b = ∀ a . Eq a ⇒ ConfAssertion [String] (Lens' b a) a
-trueLens ∷ Lens' β ()
+trueLens ∷ Lens' b ()
trueLens = lens (const ()) const
-trueAssertion ∷ [String] → ConfAssertion β
+trueAssertion ∷ [String] → ConfAssertion b
trueAssertion args = ConfAssertion args trueLens ()
-- -------------------------------------------------------------------------- --
@@ -116,8 +116,8 @@ trueAssertion args = ConfAssertion args trueLens ()
-- Check the given list of assertions for the given configuration value
--
check
- ∷ α
- → [ConfAssertion α]
+ ∷ a
+ → [ConfAssertion a]
→ IO Bool
check conf assertions =
foldM (\a (b,n) → (&& a) <$> go b n) True $ zip assertions [0 ∷ Int ..]
@@ -135,14 +135,14 @@ check conf assertions =
-- for a given that of assertions.
--
runTest
- ∷ (FromJSON (α → α), ToJSON α)
+ ∷ (FromJSON (a → a), ToJSON a)
⇒ PkgInfo
- → ProgramInfoValidate α []
+ → ProgramInfoValidate a []
→ T.Text
-- ^ label for the test case
→ Bool
-- ^ expected outcome
- → [ConfAssertion α]
+ → [ConfAssertion a]
-- ^ test assertions
→ IO Bool
runTest pkgInfo mInfo label succeed assertions = do
@@ -179,11 +179,11 @@ runTest pkgInfo mInfo label succeed assertions = do
--
withConfigFile
- ∷ ToJSON γ
+ ∷ ToJSON b
⇒ ConfigFileFormat
- → γ
- → (T.Text → IO α)
- → IO α
+ → b
+ → (T.Text → IO a)
+ → IO a
withConfigFile format config inner =
withTempFile "." ("tmp_TestExample." ⊕ suffix format) $ \tmpPath tmpHandle → do
B8.hPutStrLn tmpHandle ∘ formatter format $ config
@@ -197,8 +197,8 @@ withConfigFile format config inner =
withConfigFileText
∷ T.Text
- → (T.Text → IO α)
- → IO α
+ → (T.Text → IO a)
+ → IO a
withConfigFileText configText inner =
withTempFile "." "tmp_TestExample.txt" $ \tmpPath tmpHandle → do
T.hPutStrLn tmpHandle configText
@@ -207,7 +207,7 @@ withConfigFileText configText inner =
#ifdef REMOTE_CONFIGS
-data ConfigType = ∀ γ . ToJSON γ ⇒ ConfigType γ
+data ConfigType = ∀ a . ToJSON a ⇒ ConfigType a
instance ToJSON ConfigType where
toJSON (ConfigType a) = toJSON a
@@ -216,8 +216,8 @@ withConfigFileServer
∷ [(T.Text, ConfigType)]
→ [(T.Text, T.Text)]
→ Maybe ConfigFileFormat
- → IO α
- → IO α
+ → IO a
+ → IO a
withConfigFileServer configs configTexts maybeFormat inner = do
w0 ← forkIO $ WARP.run serverPort app
w1 ← forkIO $ WARP.runTLS tlsSettings (warpSettings serverTlsPort) app