diff --git a/CHANGELOG.md b/CHANGELOG.md --- 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 --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,5 @@ -- ------------------------------------------------------ -- +-- Copyright © 2019 Colin Woodbury -- Copyright © 2015-2018 Lars Kuhtz -- Copyright © 2014 AlephCloud Systems, Inc. -- ------------------------------------------------------ -- @@ -102,13 +103,13 @@ #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 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 @@ ++ "]" where cr = (unwords . words . I.copyright) a - diff --git a/configuration-tools.cabal b/configuration-tools.cabal --- a/configuration-tools.cabal +++ b/configuration-tools.cabal @@ -1,11 +1,8 @@ --- ------------------------------------------------------ -- --- Copyright © 2015-2018 Lars Kuhtz --- Copyright © 2014-2015 AlephCloud Systems, Inc. --- ------------------------------------------------------ -- +cabal-version: 1.24 -Name: configuration-tools -Version: 0.4.0 -Synopsis: Tools for specifying and parsing configurations +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 @@ 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 -Maintainer: Lars Kuhtz -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 +maintainer: Lars Kuhtz +copyright: + (c) 2019 Colin Woodbury , (c) 2015-2018 Lars Kuhtz , (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 @@ 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 @@ 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 @@ 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 --- a/examples/Trivial.hs +++ b/examples/Trivial.hs @@ -2,14 +2,14 @@ -- Copyright © 2014 AlephCloud Systems, Inc. -- ------------------------------------------------------ -- -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UnicodeSyntax #-} -module Main -( main -) where +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Main ( main ) where + import Configuration.Utils import PkgInfo_trivial @@ -21,4 +21,3 @@ main ∷ IO () main = runWithPkgInfoConfiguration mainInfo pkgInfo . const $ putStrLn "hello world" - diff --git a/src/Configuration/Utils.hs b/src/Configuration/Utils.hs --- 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 @@ 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 as O -import Prelude hiding (concatMap, mapM_, any) +import Prelude hiding (any, concatMap, mapM_) import Prelude.Unicode import System.IO @@ -317,18 +316,6 @@ , _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 @@ 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 --- 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 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 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 --- a/src/Configuration/Utils/ConfigFile.hs +++ b/src/Configuration/Utils/ConfigFile.hs @@ -75,7 +75,7 @@ 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 @@ -- 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 --- a/src/Configuration/Utils/Internal/ConfigFileReader.hs +++ b/src/Configuration/Utils/Internal/ConfigFileReader.hs @@ -43,8 +43,8 @@ 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 GHC.Generics -import Prelude hiding (concatMap, mapM_, any) +import Prelude hiding (any, concatMap, mapM_) import Prelude.Unicode #ifdef REMOTE_CONFIGS @@ -208,7 +208,7 @@ 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.requestHeaders $ \s a → s { HTTP.requestHeaders = a } #endif - 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 @@ -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.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 @@ → 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 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 @@ -- 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 @@ ⊕ " 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 --- 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 -- 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 @@ 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 @@ 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 --- a/src/Configuration/Utils/Operators.hs +++ b/src/Configuration/Utils/Operators.hs @@ -56,7 +56,7 @@ -- | 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 ⊙ {-# INLINE (⊙) #-} {-# DEPRECATED (⊙) "use '<*<' instead" #-} - 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 @@ -1,9 +1,12 @@ -- ------------------------------------------------------ -- +-- Copyright © 2019 Colin Woodbury -- Copyright © 2015-2018 Lars Kuhtz -- Copyright © 2014 AlephCloud Systems, Inc. -- ------------------------------------------------------ -- {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -102,13 +105,13 @@ #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 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 @@ 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 @@ 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 @@ ++ "]" where cr = (unwords . words . I.copyright) a -