summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorfosskers <>2019-05-10 18:41:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-05-10 18:41:00 (GMT)
commit4957095afa84d91ee62c7b8872be1a914dc134ae (patch)
tree691f8d7cc3fc24ba2bfa418f628f139e5df04f0e
parent0dd48f5be838c1b9a8161a9d3e7802f45c5ea760 (diff)
version 0.4.10.4.1
-rw-r--r--CHANGELOG.md6
-rw-r--r--Setup.hs18
-rw-r--r--configuration-tools.cabal163
-rw-r--r--examples/Trivial.hs11
-rw-r--r--src/Configuration/Utils.hs20
-rw-r--r--src/Configuration/Utils/CommandLine.hs8
-rw-r--r--src/Configuration/Utils/ConfigFile.hs11
-rw-r--r--src/Configuration/Utils/Internal/ConfigFileReader.hs7
-rw-r--r--src/Configuration/Utils/Internal/HttpsCertPolicy.hs46
-rw-r--r--src/Configuration/Utils/Monoid.hs49
-rw-r--r--src/Configuration/Utils/Operators.hs3
-rw-r--r--src/Configuration/Utils/Setup.hs33
12 files changed, 179 insertions, 196 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 0ff4da8..38ec7b0 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,8 @@
+0.4.1 (2019-05-10)
+==================
+
+* Added `pLeftSemigroupalUpdate` and `pRightSemigroupalUpdate`.
+
0.4.0 (2018-08-21)
==================
@@ -210,4 +215,3 @@
===
First release.
-
diff --git a/Setup.hs b/Setup.hs
index a41ddb4..c64743a 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,4 +1,5 @@
-- ------------------------------------------------------ --
+-- Copyright © 2019 Colin Woodbury <colin@fosskers.ca>
-- Copyright © 2015-2018 Lars Kuhtz <lakuhtz@gmail.com>
-- Copyright © 2014 AlephCloud Systems, Inc.
-- ------------------------------------------------------ --
@@ -102,13 +103,13 @@ module Main
#define MIN_VERSION_Cabal(a,b,c) 0
#endif
+import qualified Distribution.InstalledPackageInfo as I
import Distribution.PackageDescription
import Distribution.Simple
-import Distribution.Simple.Setup
-import qualified Distribution.InstalledPackageInfo as I
-import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.BuildPaths
+import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex
+import Distribution.Simple.Setup
import Distribution.Text
#if MIN_VERSION_Cabal(2,0,0)
@@ -135,14 +136,10 @@ import Data.Monoid
import Prelude hiding (readFile, writeFile)
import System.Directory
- ( doesFileExist
- , doesDirectoryExist
- , createDirectoryIfMissing
- , getCurrentDirectory
- , canonicalizePath
- )
-import System.FilePath (isDrive, (</>), takeDirectory)
+ (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist,
+ doesFileExist, getCurrentDirectory)
import System.Exit (ExitCode(ExitSuccess))
+import System.FilePath (isDrive, takeDirectory, (</>))
-- | Include this function when your setup doesn't contain any
-- extra functionality.
@@ -466,4 +463,3 @@ pkgIdWithLicense a = (display . packageId) a
++ "]"
where
cr = (unwords . words . I.copyright) a
-
diff --git a/configuration-tools.cabal b/configuration-tools.cabal
index 02a2d75..114016b 100644
--- a/configuration-tools.cabal
+++ b/configuration-tools.cabal
@@ -1,11 +1,8 @@
--- ------------------------------------------------------ --
--- Copyright © 2015-2018 Lars Kuhtz <lakuhtz@gmail.com>
--- Copyright © 2014-2015 AlephCloud Systems, Inc.
--- ------------------------------------------------------ --
-
-Name: configuration-tools
-Version: 0.4.0
-Synopsis: Tools for specifying and parsing configurations
+cabal-version: 1.24
+
+name: configuration-tools
+version: 0.4.1
+synopsis: Tools for specifying and parsing configurations
description:
Tools for specifying and parsing configurations
.
@@ -28,20 +25,21 @@ description:
and in the API documentation of the modules "Configuration.Utils" and
"Configuration.Utils.Setup".
-Homepage: https://github.com/alephcloud/hs-configuration-tools
-Bug-reports: https://github.com/alephcloud/hs-configuration-tools/issues
-License: MIT
-License-file: LICENSE
-Author: Lars Kuhtz <lakuhtz@gmail.com>
-Maintainer: Lars Kuhtz <lakuhtz@gmail.com>
-Copyright:
+homepage: https://github.com/alephcloud/hs-configuration-tools
+bug-reports: https://github.com/alephcloud/hs-configuration-tools/issues
+license: MIT
+license-file: LICENSE
+author: Lars Kuhtz <lakuhtz@gmail.com>
+maintainer: Lars Kuhtz <lakuhtz@gmail.com>
+copyright:
+ (c) 2019 Colin Woodbury <colin@fosskers.ca>,
(c) 2015-2018 Lars Kuhtz <lakuhtz@gmail.com>,
(c) 2014-2015 AlephCloud, Inc.
-Category: Configuration, Console
-Build-type: Custom
-cabal-version: 1.24
+category: Configuration, Console
+build-type: Custom
tested-with:
- GHC==8.4.3
+ GHC==8.6.5
+ , GHC==8.4.3
, GHC==8.2.2
, GHC==8.0.2
, GHC==7.10.3
@@ -64,19 +62,15 @@ source-repository head
location: https://github.com/alephcloud/hs-configuration-tools.git
branch: master
-source-repository this
- type: git
- location: https://github.com/alephcloud/hs-configuration-tools.git
- tag: 0.4.0
-
flag remote-configs
Description: enable loading of configuration files from HTTP URLs
Default: True
Manual: True
-Library
+library
hs-source-dirs: src
default-language: Haskell2010
+ ghc-options: -Wall
exposed-modules:
Configuration.Utils
@@ -95,52 +89,52 @@ Library
Configuration.Utils.Internal.HttpsCertPolicy
build-depends:
- Cabal >= 1.24,
- aeson >= 0.7.0.6,
- ansi-wl-pprint >= 0.6,
- attoparsec >= 0.11.3.4,
- base >= 4.8 && < 5.0,
- base-unicode-symbols >= 0.2.2.4,
- bytestring >= 0.10.0.2,
- case-insensitive >= 1.2,
- deepseq >= 1.3,
- directory >= 1.2.1.0,
- dlist >= 0.7.1,
- filepath >= 1.3.0.1,
- mtl >= 2.2,
- network-uri >= 2.6.0.1,
- optparse-applicative >= 0.11.0.2,
- process >= 1.2.0.0,
- profunctors >= 4.0.4,
- semigroups >= 0.18,
- text >= 1.0,
- transformers >= 0.4,
- unordered-containers >= 0.2.4.0,
- yaml >= 0.8.8.3
+ Cabal >= 1.24
+ , aeson >= 0.7.0.6
+ , ansi-wl-pprint >= 0.6
+ , attoparsec >= 0.11.3.4
+ , base >= 4.8 && < 5
+ , base-unicode-symbols >= 0.2.2.4
+ , bytestring >= 0.10.0.2
+ , case-insensitive >= 1.2
+ , deepseq >= 1.3
+ , directory >= 1.2.1.0
+ , dlist >= 0.7.1
+ , filepath >= 1.3.0.1
+ , mtl >= 2.2
+ , network-uri >= 2.6.0.1
+ , optparse-applicative >= 0.11.0.2
+ , process >= 1.2.0.0
+ , profunctors >= 4.0.4
+ , semigroups >= 0.18
+ , semigroupoids >= 5.0
+ , text >= 1.0
+ , transformers >= 0.4
+ , unordered-containers >= 0.2.4.0
+ , yaml >= 0.8.8.3
if flag(remote-configs)
build-depends:
- base64-bytestring >= 1.0,
- connection >= 0.2,
- data-default >= 0.5,
- enclosed-exceptions >= 1.0,
- http-client >= 0.4,
- http-client-tls >= 0.2,
- http-types >= 0.8,
- monad-control >= 1.0,
- tls >= 1.2,
- x509 >= 1.5,
- x509-system >= 1.5,
- x509-validation >= 1.5.1
+ base64-bytestring >= 1.0
+ , connection >= 0.2
+ , data-default >= 0.5
+ , enclosed-exceptions >= 1.0
+ , http-client >= 0.4.30
+ , http-client-tls >= 0.2
+ , http-types >= 0.8
+ , monad-control >= 1.0
+ , tls >= 1.2
+ , x509 >= 1.5
+ , x509-system >= 1.5
+ , x509-validation >= 1.5.1
if flag(remote-configs)
cpp-options: -DREMOTE_CONFIGS
+test-suite url-example-test
+ default-language: Haskell2010
ghc-options: -Wall
-
-Test-Suite url-example-test
type: exitcode-stdio-1.0
- default-language: Haskell2010
main-is: TestExample.hs
hs-source-dirs: examples, test
@@ -151,39 +145,36 @@ Test-Suite url-example-test
Tests.MonoidConfig
build-depends:
- Cabal >= 1.24,
- base >= 4.8 && < 5.0,
- base-unicode-symbols >= 0.2.2.4,
- bytestring >= 0.10,
- configuration-tools,
- mtl >= 2.2,
- text >= 1.0,
- transformers >= 0.4,
- unordered-containers >= 0.2.4.0,
- yaml >= 0.8.8.3
+ Cabal >= 1.24
+ , base >= 4.8 && < 5
+ , base-unicode-symbols >= 0.2.2.4
+ , bytestring >= 0.10
+ , configuration-tools
+ , mtl >= 2.2
+ , text >= 1.0
+ , transformers >= 0.4
+ , unordered-containers >= 0.2.4.0
+ , yaml >= 0.8.8.3
if flag(remote-configs)
build-depends:
- enclosed-exceptions >= 1.0,
- http-types >= 0.8,
- monad-control >= 1.0,
- wai >= 3.0,
- warp >= 3.0,
- warp-tls >= 3.0
+ enclosed-exceptions >= 1.0
+ , http-types >= 0.8
+ , monad-control >= 1.0
+ , wai >= 3.0
+ , warp >= 3.0
+ , warp-tls >= 3.0
cpp-options: -DREMOTE_CONFIGS
+test-suite trivial
+ default-language: Haskell2010
ghc-options: -Wall
-
-Test-Suite trivial
type: exitcode-stdio-1.0
- default-language: Haskell2010
main-is: Trivial.hs
hs-source-dirs: examples
build-depends:
- base >= 4.8 && < 5.0,
- base-unicode-symbols >= 0.2.2.4,
- configuration-tools
-
- ghc-options: -Wall
+ base >= 4.8 && < 5
+ , base-unicode-symbols >= 0.2.2.4
+ , configuration-tools
diff --git a/examples/Trivial.hs b/examples/Trivial.hs
index f44c786..5cb9110 100644
--- a/examples/Trivial.hs
+++ b/examples/Trivial.hs
@@ -2,13 +2,13 @@
-- Copyright © 2014 AlephCloud Systems, Inc.
-- ------------------------------------------------------ --
-{-# LANGUAGE UnicodeSyntax #-}
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UnicodeSyntax #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Main
-( main
-) where
+module Main ( main ) where
import Configuration.Utils
import PkgInfo_trivial
@@ -21,4 +21,3 @@ mainInfo = programInfo "Hello World" (pure id) ()
main ∷ IO ()
main = runWithPkgInfoConfiguration mainInfo pkgInfo . const $ putStrLn "hello world"
-
diff --git a/src/Configuration/Utils.hs b/src/Configuration/Utils.hs
index a7752ac..423f3c0 100644
--- a/src/Configuration/Utils.hs
+++ b/src/Configuration/Utils.hs
@@ -1,8 +1,7 @@
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}
@@ -125,8 +124,8 @@ module Configuration.Utils
import Configuration.Utils.CommandLine
import Configuration.Utils.ConfigFile
-import qualified Configuration.Utils.Internal.ConfigFileReader as CF
import Configuration.Utils.Internal
+import qualified Configuration.Utils.Internal.ConfigFileReader as CF
import Configuration.Utils.Maybe
import Configuration.Utils.Monoid
import Configuration.Utils.Operators
@@ -148,7 +147,7 @@ import qualified Options.Applicative.Types as O
import qualified Options.Applicative as O
-import Prelude hiding (concatMap, mapM_, any)
+import Prelude hiding (any, concatMap, mapM_)
import Prelude.Unicode
import System.IO
@@ -317,18 +316,6 @@ data AppConfiguration a = AppConfiguration
, _mainConfig ∷ !a
}
--- | A flag that indicates that the application should output the effective
--- configuration and exit.
---
-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 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.
@@ -695,4 +682,3 @@ validateConfig appInfo conf = do
when (any (const True) warnings) $ do
T.hPutStrLn stderr "WARNINGS:"
mapM_ (\w → T.hPutStrLn stderr $ "warning: " ⊕ w) warnings
-
diff --git a/src/Configuration/Utils/CommandLine.hs b/src/Configuration/Utils/CommandLine.hs
index c752b86..95ddd10 100644
--- a/src/Configuration/Utils/CommandLine.hs
+++ b/src/Configuration/Utils/CommandLine.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -68,7 +67,7 @@ import qualified Options.Applicative.Types as O
import qualified Options.Applicative as O
import qualified Options.Applicative.Builder.Internal as O
-import Prelude hiding (concatMap, mapM_, any)
+import Prelude hiding (any, concatMap, mapM_)
import qualified Text.ParserCombinators.ReadP as P hiding (string)
@@ -265,6 +264,5 @@ eitherReadP
eitherReadP label p s =
case [ x | (x,"") ← P.readP_to_S p (T.unpack s) ] of
[x] → Right x
- [] → Left $ "eitherReadP: no parse for " ⊕ label ⊕ " of " ⊕ s
- _ → Left $ "eitherReadP: ambigous parse for " ⊕ label ⊕ " of " ⊕ s
-
+ [] → Left $ "eitherReadP: no parse for " ⊕ label ⊕ " of " ⊕ s
+ _ → Left $ "eitherReadP: ambigous parse for " ⊕ label ⊕ " of " ⊕ s
diff --git a/src/Configuration/Utils/ConfigFile.hs b/src/Configuration/Utils/ConfigFile.hs
index 1751002..eebc90f 100644
--- a/src/Configuration/Utils/ConfigFile.hs
+++ b/src/Configuration/Utils/ConfigFile.hs
@@ -75,7 +75,7 @@ import Data.String
import qualified Data.Text as T
import Data.Typeable
-import Prelude hiding (concatMap, mapM_, any)
+import Prelude hiding (any, concatMap, mapM_)
#ifdef REMOTE_CONFIGS
import Configuration.Utils.Internal.HttpsCertPolicy
@@ -276,8 +276,7 @@ pConfigFilesConfig = pure id
-- Miscellaneous Utilities
dropAndUncaml ∷ Int → String → String
-dropAndUncaml i l
- | length l < i + 1 = l
- | otherwise = let (h:t) = drop i l
- in toLower h : concatMap (\x → if isUpper x then "-" ⊕ [toLower x] else [x]) t
-
+dropAndUncaml _ "" = ""
+dropAndUncaml i l = case drop i l of
+ [] -> l
+ (h:t) -> toLower h : concatMap (\x → if isUpper x then "-" ⊕ [toLower x] else [x]) t
diff --git a/src/Configuration/Utils/Internal/ConfigFileReader.hs b/src/Configuration/Utils/Internal/ConfigFileReader.hs
index 1151f69..c7448f8 100644
--- a/src/Configuration/Utils/Internal/ConfigFileReader.hs
+++ b/src/Configuration/Utils/Internal/ConfigFileReader.hs
@@ -43,8 +43,8 @@ import Configuration.Utils.Validation
import Control.Applicative
import Control.DeepSeq (NFData)
import Control.Monad
-import Control.Monad.IO.Class
import Control.Monad.Error.Class
+import Control.Monad.IO.Class
import qualified Data.ByteString.Char8 as B8
import Data.Monoid.Unicode
@@ -54,7 +54,7 @@ import qualified Data.Yaml as Yaml
import GHC.Generics
-import Prelude hiding (concatMap, mapM_, any)
+import Prelude hiding (any, concatMap, mapM_)
import Prelude.Unicode
#ifdef REMOTE_CONFIGS
@@ -208,7 +208,7 @@ loadRemote conf path = do
url = getConfigFile path
policy = _cfcHttpsPolicy conf
doHttp = liftIO $ do
- request ← (HTTP.parseUrl $ T.unpack url)
+ request ← (HTTP.parseUrlThrow $ T.unpack url)
<&> over requestHeaders ((:) acceptHeader)
resp ← httpWithValidationPolicy request policy
let format = maybe Other contentType ∘ L.lookup HTTP.hContentType $ HTTP.responseHeaders resp
@@ -220,4 +220,3 @@ requestHeaders ∷ Lens' HTTP.Request HTTP.RequestHeaders
requestHeaders = lens HTTP.requestHeaders $ \s a → s { HTTP.requestHeaders = a }
#endif
-
diff --git a/src/Configuration/Utils/Internal/HttpsCertPolicy.hs b/src/Configuration/Utils/Internal/HttpsCertPolicy.hs
index 1dc6ce1..1b9c21a 100644
--- a/src/Configuration/Utils/Internal/HttpsCertPolicy.hs
+++ b/src/Configuration/Utils/Internal/HttpsCertPolicy.hs
@@ -1,7 +1,6 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}
@@ -41,40 +40,41 @@ import Configuration.Utils.Monoid
import Configuration.Utils.Operators
import Configuration.Utils.Validation
-import Control.Exception (catches, Handler(..))
-import Control.Monad.Writer hiding (mapM_)
+import Control.Arrow (second)
+import Control.Exception (Exception, Handler(..), catches, throwIO)
+import Control.Monad.State
+import Control.Monad.Writer
+import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Lazy as LB
+import Data.Default (def)
+import qualified Data.HashMap.Strict as HM
+import Data.IORef
+import qualified Data.List as L
import Data.Maybe
import Data.Monoid.Unicode
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
import qualified Options.Applicative as O
-import Prelude hiding (concatMap, mapM_, any)
+import Prelude hiding (any, concatMap, mapM_)
import Prelude.Unicode
-import Control.Arrow (second)
-import qualified Data.ByteString.Lazy as LB
-import qualified Data.List as L
import qualified Network.Connection as HTTP
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP
-import qualified System.X509 as TLS (getSystemCertificateStore)
-import qualified Data.X509.Validation as TLS (ServiceID, Fingerprint(..), getFingerprint, ValidationCacheQueryCallback)
import qualified Network.TLS as TLS hiding (HashSHA256)
-import Data.Default (def)
-import qualified Network.TLS.Extra as TLS (ciphersuite_all)
+import qualified Network.TLS.Extra as TLS
+
+import qualified System.X509 as TLS
+
import Text.Read (readEither)
-import qualified Data.ByteString.Base64 as B64
-import Control.Monad.State hiding (mapM_)
-import qualified Data.HashMap.Strict as HM
-import Control.Exception (Exception, catch, throwIO, fromException)
-import Data.IORef
-import qualified Data.Text.Encoding as T
-import qualified Data.X509 as TLS (HashALG(HashSHA256), Certificate, SignedExact, CertificateChain(..))
-- -------------------------------------------------------------------------- --
-- HTTPS Certificate Validation Policy
@@ -144,7 +144,7 @@ simpleHttpWithValidationPolicy
→ HttpsCertPolicy
→ IO (HTTP.Response LB.ByteString)
simpleHttpWithValidationPolicy url policy = do
- request ← (HTTP.parseUrl $ T.unpack url)
+ request ← HTTP.parseUrlThrow $ T.unpack url
httpWithValidationPolicy request policy
httpWithValidationPolicy
@@ -154,7 +154,8 @@ httpWithValidationPolicy
httpWithValidationPolicy request policy = do
certVar ← newIORef Nothing
settings ← getSettings policy certVar
- HTTP.withManager settings (HTTP.httpLbs request) `catches`
+ mgr <- HTTP.newManager settings
+ HTTP.httpLbs request mgr `catches`
[ Handler $ \(e ∷ TLS.TLSException) → do
cert ← readIORef certVar
handleTlsException request cert e
@@ -285,7 +286,7 @@ getSettings policy certVar = do
-- and 'TLS.connectTo' are going to overwrite this anyways.
--
tlsSettings certstore = (TLS.defaultParamsClient "" "")
- { TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_all }
+ { TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_default }
, TLS.clientShared = def
{ TLS.sharedCAStore = certstore
, TLS.sharedValidationCache = validationCache
@@ -325,4 +326,3 @@ getSettings policy certVar = do
⊕ " but got fingerprint: " ⊕ printFingerprint fingerprint
where
printFingerprint (TLS.Fingerprint f) = fromString ∘ B8.unpack ∘ B64.encode $ f
-
diff --git a/src/Configuration/Utils/Monoid.hs b/src/Configuration/Utils/Monoid.hs
index 0c0f0f3..6c53a71 100644
--- a/src/Configuration/Utils/Monoid.hs
+++ b/src/Configuration/Utils/Monoid.hs
@@ -1,7 +1,5 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}
@@ -13,33 +11,37 @@
-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>
-- Stability: experimental
--
--- The distinction between appending on the left and appending on
--- the right is important for monoids that are sensitive to ordering
--- such as 'List'. It is also of relevance for monoids with set semantics
--- with non-extensional equality such as `HashMap`.
+-- The distinction between appending on the left and appending on the right is
+-- important for monoids that are sensitive to ordering such as 'List'. It is
+-- also of relevance for monoids with set semantics with non-extensional
+-- equality such as `HashMap`.
--
module Configuration.Utils.Monoid
-( LeftMonoidalUpdate
-, leftMonoidalUpdate
-, fromLeftMonoidalUpdate
-, pLeftMonoidalUpdate
-, RightMonoidalUpdate
-, rightMonoidalUpdate
-, fromRightMonoidalUpdate
-, pRightMonoidalUpdate
-) where
+ ( LeftMonoidalUpdate
+ , leftMonoidalUpdate
+ , fromLeftMonoidalUpdate
+ , pLeftMonoidalUpdate
+ , pLeftSemigroupalUpdate
+ , RightMonoidalUpdate
+ , rightMonoidalUpdate
+ , fromRightMonoidalUpdate
+ , pRightMonoidalUpdate
+ , pRightSemigroupalUpdate
+ ) where
import Configuration.Utils.CommandLine
import Configuration.Utils.Internal
-import Control.Monad.Writer hiding (mapM_)
+import Control.Monad.Writer hiding (mapM_, (<>))
import Data.Aeson
+import qualified Data.List.NonEmpty as NEL
import Data.Semigroup
+import Data.Semigroup.Foldable (fold1)
import qualified Options.Applicative.Types as O
-import Prelude hiding (concatMap, mapM_, any)
+import Prelude hiding (any, concatMap, mapM_)
import Prelude.Unicode
-- | Update a value by appending on the left. Under normal
@@ -99,6 +101,13 @@ instance (FromJSON a, Monoid a) ⇒ FromJSON (LeftMonoidalUpdate a → LeftMonoi
pLeftMonoidalUpdate ∷ Monoid a ⇒ O.Parser a → MParser a
pLeftMonoidalUpdate pElement = mappend ∘ mconcat ∘ reverse <$> many pElement
+-- | Like `pLeftMonoidalUpdate`, but works for `Semigroup`s instead. Using this
+-- parser requires the input to have at least one copy (say, for flags that can
+-- be passed multiple times).
+--
+pLeftSemigroupalUpdate ∷ Semigroup a ⇒ O.Parser a → MParser a
+pLeftSemigroupalUpdate pElement = (<>) ∘ fold1 ∘ NEL.fromList ∘ reverse <$> some 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.
@@ -129,3 +138,9 @@ instance (FromJSON a, Monoid a) ⇒ FromJSON (RightMonoidalUpdate a → RightMon
pRightMonoidalUpdate ∷ Monoid a ⇒ O.Parser a → MParser a
pRightMonoidalUpdate pElement = flip mappend ∘ mconcat <$> many pElement
+-- | Like `pRightMonoidalUpdate`, but works for `Semigroup`s instead. Using this
+-- parser requires the input to have at least one copy (say, for flags that can
+-- be passed multiple times).
+--
+pRightSemigroupalUpdate ∷ Semigroup a ⇒ O.Parser a → MParser a
+pRightSemigroupalUpdate pElement = flip (<>) ∘ fold1 ∘ NEL.fromList <$> some pElement
diff --git a/src/Configuration/Utils/Operators.hs b/src/Configuration/Utils/Operators.hs
index 2b1de53..b60de07 100644
--- a/src/Configuration/Utils/Operators.hs
+++ b/src/Configuration/Utils/Operators.hs
@@ -56,7 +56,7 @@ infixr 5 ×
-- | Functional composition for applicative functors.
--
(<*<) ∷ Applicative f ⇒ f (b → c) → f (a → b) → f (a → c)
-(<*<) a b = pure (.) <*> a <*> b
+(<*<) a b = ((.) <$> a) <*> b
infixr 4 <*<
{-# INLINE (<*<) #-}
@@ -109,4 +109,3 @@ infixr 4 <.>
infixr 4 ⊙
{-# INLINE (⊙) #-}
{-# DEPRECATED (⊙) "use '<*<' instead" #-}
-
diff --git a/src/Configuration/Utils/Setup.hs b/src/Configuration/Utils/Setup.hs
index 7dbe865..1c0e445 100644
--- a/src/Configuration/Utils/Setup.hs
+++ b/src/Configuration/Utils/Setup.hs
@@ -1,9 +1,12 @@
-- ------------------------------------------------------ --
+-- Copyright © 2019 Colin Woodbury <colin@fosskers.ca>
-- Copyright © 2015-2018 Lars Kuhtz <lakuhtz@gmail.com>
-- Copyright © 2014 AlephCloud Systems, Inc.
-- ------------------------------------------------------ --
{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -102,13 +105,13 @@ module Configuration.Utils.Setup
#define MIN_VERSION_Cabal(a,b,c) 0
#endif
+import qualified Distribution.InstalledPackageInfo as I
import Distribution.PackageDescription
import Distribution.Simple
-import Distribution.Simple.Setup
-import qualified Distribution.InstalledPackageInfo as I
-import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.BuildPaths
+import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex
+import Distribution.Simple.Setup
import Distribution.Text
#if MIN_VERSION_Cabal(2,0,0)
@@ -135,14 +138,10 @@ import Data.Monoid
import Prelude hiding (readFile, writeFile)
import System.Directory
- ( doesFileExist
- , doesDirectoryExist
- , createDirectoryIfMissing
- , getCurrentDirectory
- , canonicalizePath
- )
-import System.FilePath (isDrive, (</>), takeDirectory)
+ (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist,
+ doesFileExist, getCurrentDirectory)
import System.Exit (ExitCode(ExitSuccess))
+import System.FilePath (isDrive, takeDirectory, (</>))
-- | Include this function when your setup doesn't contain any
-- extra functionality.
@@ -275,12 +274,11 @@ pkgInfoModuleName = "PkgInfo"
updateFile :: FilePath -> B.ByteString -> IO ()
updateFile fileName content = do
- doesFileExist fileName >>= \x -> if x
- then do
- oldRevisionFile <- B.readFile fileName
- when (oldRevisionFile /= content) update
- else
- update
+ x <- doesFileExist fileName
+ if | not x -> update
+ | otherwise -> do
+ oldRevisionFile <- B.readFile fileName
+ when (oldRevisionFile /= content) update
where
update = B.writeFile fileName content
@@ -311,7 +309,7 @@ getVcsOfDir d = do
pkgInfoModule :: String -> Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString
pkgInfoModule moduleName cName pkgDesc bInfo = do
- (tag, revision, branch) <- getVCS >>= \x -> case x of
+ (tag, revision, branch) <- getVCS >>= \case
Just Mercurial -> hgInfo
Just Git -> gitInfo
_ -> noVcsInfo
@@ -466,4 +464,3 @@ pkgIdWithLicense a = (display . packageId) a
++ "]"
where
cr = (unwords . words . I.copyright) a
-