Merge branch 'master' into wip/jsem

.github/mergify.yml

@@ -70,4 +70,4 @@ pull_request_rules:
 
 queue_rules:
   - name: default
-    conditions: []
+    update_bot_account: Mikolaj

.hlint.yaml

@@ -12,7 +12,6 @@
 - ignore: {name: "Missing NOINLINE pragma"} # 1 hint
 - ignore: {name: "Monoid law, left identity"} # 3 hints
 - ignore: {name: "Monoid law, right identity"} # 3 hints
-- ignore: {name: "Move brackets to avoid $"} # 25 hints
 - ignore: {name: "Move guards forward"} # 4 hints
 - ignore: {name: "Redundant $"} # 125 hints
 - ignore: {name: "Redundant $!"} # 4 hints
@@ -22,7 +21,6 @@
 - ignore: {name: "Redundant guard"} # 2 hints
 - ignore: {name: "Redundant if"} # 1 hint
 - ignore: {name: "Redundant lambda"} # 22 hints
-- ignore: {name: "Redundant list comprehension"} # 3 hints
 - ignore: {name: "Redundant map"} # 1 hint
 - ignore: {name: "Redundant multi-way if"} # 1 hint
 - ignore: {name: "Redundant return"} # 4 hints

Cabal/src/Distribution/Compat/ResponseFile.hs

@@ -76,7 +76,7 @@ expandResponse = go recursionLimit "."
       | otherwise = const $ hPutStrLn stderr "Error: response file recursion limit exceeded." >> exitFailure
 
     expand :: Int -> FilePath -> String -> IO [String]
-    expand n dir arg@('@' : f) = readRecursively n (dir </> f) `catchIOError` (const $ print "?" >> return [arg])
+    expand n dir arg@('@' : f) = readRecursively n (dir </> f) `catchIOError` const (print "?" >> return [arg])
     expand _n _dir x = return [x]
 
     readRecursively :: Int -> FilePath -> IO [String]

Cabal/src/Distribution/Compat/Time.hs

@@ -155,7 +155,7 @@ posixSecondsToModTime s =
 posixTimeToModTime :: POSIXTime -> ModTime
 posixTimeToModTime p =
   ModTime $
-    (ceiling $ p * 1e7) -- 100 ns precision
+    ceiling (p * 1e7) -- 100 ns precision
       + (secToUnixEpoch * windowsTick)
 
 -- | Return age of given file in days.

Cabal/src/Distribution/GetOpt.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE NamedFieldPuns #-}
------------------------------------------------------------------------------
 {-# LANGUAGE TupleSections #-}
 
+-----------------------------------------------------------------------------
+
 -- |
 -- Module      :  Distribution.GetOpt
 -- Copyright   :  (c) Sven Panne 2002-2005
@@ -67,12 +68,12 @@ data ArgDescr a
   | -- |   option requires argument
     ReqArg (String -> Either String a) String
   | -- |   optional argument
-    OptArg (Maybe String -> Either String a) String
+    OptArg String (Maybe String -> Either String a) String
 
 instance Functor ArgDescr where
   fmap f (NoArg a) = NoArg (f a)
   fmap f (ReqArg g s) = ReqArg (fmap f . g) s
-  fmap f (OptArg g s) = OptArg (fmap f . g) s
+  fmap f (OptArg dv g s) = OptArg dv (fmap f . g) s
 
 data OptKind a -- kind of cmd line arg (internal use only):
   = Opt a --    an option
@@ -130,17 +131,41 @@ zipDefault _ bd (a : as) [] = (a, bd) : map (,bd) as
 zipDefault ad _ [] (b : bs) = (ad, b) : map (ad,) bs
 zipDefault ad bd (a : as) (b : bs) = (a, b) : zipDefault ad bd as bs
 
+-- | Pretty printing of short options.
+-- * With required arguments can be given as:
+--    @-w PATH or -wPATH (but not -w=PATH)@
+--   This is dislayed as:
+--    @-w PATH or -wPATH@
+-- * With optional but default arguments can be given as:
+--    @-j or -jNUM (but not -j=NUM or -j NUM)@
+--   This is dislayed as:
+--    @-j[NUM]@
 fmtShort :: ArgDescr a -> Char -> String
 fmtShort (NoArg _) so = "-" ++ [so]
-fmtShort (ReqArg _ _) so = "-" ++ [so]
-fmtShort (OptArg _ _) so = "-" ++ [so]
-
--- unlike upstream GetOpt we omit the arg name for short options
-
+fmtShort (ReqArg _ ad) so =
+  let opt = "-" ++ [so]
+   in opt ++ " " ++ ad ++ " or " ++ opt ++ ad
+fmtShort (OptArg _ _ ad) so =
+  let opt = "-" ++ [so]
+   in opt ++ "[" ++ ad ++ "]"
+
+-- | Pretty printing of long options.
+-- * With required arguments can be given as:
+--    @--with-compiler=PATH (but not --with-compiler PATH)@
+--   This is dislayed as:
+--    @--with-compiler=PATH@
+-- * With optional but default arguments can be given as:
+--    @--jobs or --jobs=NUM (but not --jobs NUM)@
+--   This is dislayed as:
+--    @--jobs[=NUM]@
 fmtLong :: ArgDescr a -> String -> String
 fmtLong (NoArg _) lo = "--" ++ lo
-fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
-fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
+fmtLong (ReqArg _ ad) lo =
+  let opt = "--" ++ lo
+   in opt ++ "=" ++ ad
+fmtLong (OptArg _ _ ad) lo =
+  let opt = "--" ++ lo
+   in opt ++ "[=" ++ ad ++ "]"
 
 wrapText :: Int -> String -> [String]
 wrapText width = map unwords . wrap 0 [] . words
@@ -230,8 +255,8 @@ longOpt ls rs optDescr = long ads arg rs
     long [ReqArg _ d] [] [] = (errReq d optStr, [])
     long [ReqArg f _] [] (r : rest) = (fromRes (f r), rest)
     long [ReqArg f _] ('=' : xs) rest = (fromRes (f xs), rest)
-    long [OptArg f _] [] rest = (fromRes (f Nothing), rest)
-    long [OptArg f _] ('=' : xs) rest = (fromRes (f (Just xs)), rest)
+    long [OptArg _ f _] [] rest = (fromRes (f Nothing), rest)
+    long [OptArg _ f _] ('=' : xs) rest = (fromRes (f (Just xs)), rest)
     long _ _ rest = (UnreqOpt ("--" ++ ls), rest)
 
 -- handle short option
@@ -249,8 +274,8 @@ shortOpt y ys rs optDescr = short ads ys rs
     short (ReqArg _ d : _) [] [] = (errReq d optStr, [])
     short (ReqArg f _ : _) [] (r : rest) = (fromRes (f r), rest)
     short (ReqArg f _ : _) xs rest = (fromRes (f xs), rest)
-    short (OptArg f _ : _) [] rest = (fromRes (f Nothing), rest)
-    short (OptArg f _ : _) xs rest = (fromRes (f (Just xs)), rest)
+    short (OptArg _ f _ : _) [] rest = (fromRes (f Nothing), rest)
+    short (OptArg _ f _ : _) xs rest = (fromRes (f (Just xs)), rest)
     short [] [] rest = (UnreqOpt optStr, rest)
     short [] xs rest = (UnreqOpt (optStr ++ xs), rest)
 

Cabal/src/Distribution/ReadE.hs

@@ -55,7 +55,7 @@ runParsecFromString p txt =
 
 parsecToReadE :: (String -> ErrorMsg) -> ParsecParser a -> ReadE a
 parsecToReadE err p = ReadE $ \txt ->
-  (const $ err txt) `Bi.first` runParsecFromString p txt
+  const (err txt) `Bi.first` runParsecFromString p txt
 
 parsecToReadEErr :: (Parsec.ParseError -> ErrorMsg) -> ParsecParser a -> ReadE a
 parsecToReadEErr err p =

Cabal/src/Distribution/Simple/Build.hs

@@ -879,7 +879,7 @@ testSuiteLibV09AsLibAndExe
                 { hsSourceDirs = [unsafeMakeSymbolicPath testDir]
                 , targetBuildDepends =
                     testLibDep
-                      : (targetBuildDepends $ testBuildInfo test)
+                      : targetBuildDepends (testBuildInfo test)
                 }
           }
       -- \| The stub executable needs a new 'ComponentLocalBuildInfo'

Cabal/src/Distribution/Simple/Command.hs

@@ -74,6 +74,7 @@ module Distribution.Simple.Command
   , reqArg'
   , optArg
   , optArg'
+  , optArgDef'
   , noArg
   , boolOpt
   , boolOpt'
@@ -138,7 +139,7 @@ data OptDescr a
       OptFlags
       ArgPlaceHolder
       (ReadE (a -> a))
-      (a -> a)
+      (String, a -> a)
       (a -> [Maybe String])
   | ChoiceOpt [(Description, OptFlags, a -> a, a -> Bool)]
   | BoolOpt
@@ -231,16 +232,16 @@ optArg
   :: Monoid b
   => ArgPlaceHolder
   -> ReadE b
-  -> b
+  -> (String, b)
   -> (b -> [Maybe String])
   -> MkOptDescr (a -> b) (b -> a -> a) a
-optArg ad mkflag def showflag sf lf d get set =
+optArg ad mkflag (dv, mkDef) showflag sf lf d get set =
   OptArg
     d
     (sf, lf)
     ad
     (fmap (\a b -> set (get b `mappend` a) b) mkflag)
-    (\b -> set (get b `mappend` def) b)
+    (dv, \b -> set (get b `mappend` mkDef) b)
     (showflag . get)
 
 -- | (String -> a) variant of "reqArg"
@@ -261,9 +262,16 @@ optArg'
   -> (b -> [Maybe String])
   -> MkOptDescr (a -> b) (b -> a -> a) a
 optArg' ad mkflag showflag =
-  optArg ad (succeedReadE (mkflag . Just)) def showflag
-  where
-    def = mkflag Nothing
+  optArg ad (succeedReadE (mkflag . Just)) ("", mkflag Nothing) showflag
+
+optArgDef'
+  :: Monoid b
+  => ArgPlaceHolder
+  -> (String, Maybe String -> b)
+  -> (b -> [Maybe String])
+  -> MkOptDescr (a -> b) (b -> a -> a) a
+optArgDef' ad (dv, mkflag) showflag =
+  optArg ad (succeedReadE (mkflag . Just)) (dv, mkflag Nothing) showflag
 
 noArg :: Eq b => b -> MkOptDescr (a -> b) (b -> a -> a) a
 noArg flag sf lf d = choiceOpt [(flag, (sf, lf), d)] sf lf d
@@ -339,8 +347,8 @@ viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa
   where
     optDescrToGetOpt (ReqArg d (cs, ss) arg_desc set _) =
       [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d]
-    optDescrToGetOpt (OptArg d (cs, ss) arg_desc set def _) =
-      [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d]
+    optDescrToGetOpt (OptArg d (cs, ss) arg_desc set (dv, def) _) =
+      [GetOpt.Option cs ss (GetOpt.OptArg dv set' arg_desc) d]
       where
         set' Nothing = Right def
         set' (Just txt) = runReadE set txt
@@ -374,13 +382,13 @@ liftOptDescr get' set' (ChoiceOpt opts) =
     [ (d, ff, liftSet get' set' set, (get . get'))
     | (d, ff, set, get) <- opts
     ]
-liftOptDescr get' set' (OptArg d ff ad set def get) =
+liftOptDescr get' set' (OptArg d ff ad set (dv, mkDef) get) =
   OptArg
     d
     ff
     ad
     (liftSet get' set' `fmap` set)
-    (liftSet get' set' def)
+    (dv, liftSet get' set' mkDef)
     (get . get')
 liftOptDescr get' set' (ReqArg d ff ad set get) =
   ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get')