diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index a45efdc35..cd1d6813e 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -133,4 +133,4 @@ getStatusR = do comptime = $(stringE =<< runIO (show <$> getCurrentTime)) ddays :: UTCTime -> UTCTime -> Double - ddays tstart tstop = (/10) $ fromIntegral $ round $ diffUTCTime tstop tstart / (6 * 60 * 24) + ddays tstart tstop = (/100) $ fromIntegral $ round $ diffUTCTime tstop tstart / (36 * 24) diff --git a/src/Mail.hs b/src/Mail.hs index 3daa89301..f32a66a1f 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -145,7 +145,7 @@ _mailReplyTo' = _mailHeaders . _headerReplyTo' _headerReplyTo' :: Lens' Headers Text -- Functor f => (Text -> f Text) -> [(ByteString, Text)] -> f [(ByteString, Text)] -_headerReplyTo' f hdrs = (\x -> insertAssoc (replyto, x) hdrs) <$> f (maybeMonoid $ lookup replyto hdrs) +_headerReplyTo' f hdrs = (\x -> insertAssoc replyto x hdrs) <$> f (maybeMonoid $ lookup replyto hdrs) where replyto = "Reply-To" @@ -154,7 +154,7 @@ _mailReplyTo = _mailHeaders . _headerReplyTo _headerReplyTo :: Lens' Headers Address -- Functor f => (Address -> f Address) -> [(ByteString, Text)] -> f [(ByteString, Text)] -_headerReplyTo f hdrs = (\x -> insertAssoc (replyto, renderAddress x) hdrs) <$> f (fromString $ unpack $ maybeMonoid $ lookup replyto hdrs) +_headerReplyTo f hdrs = (\x -> insertAssoc replyto (renderAddress x) hdrs) <$> f (fromString $ unpack $ maybeMonoid $ lookup replyto hdrs) where replyto = "Reply-To" -- _addressEmail :: Lens' Address Text might help to simplify this code? diff --git a/src/Utils.hs b/src/Utils.hs index 5ff061458..82f30f157 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -532,33 +532,43 @@ insertAttr attr valu = aux | attr==a = (a, Text.append valu $ Text.cons ' ' v) : t | otherwise = p : aux t -- Could be implemented using updateAssoc like so, but would add superfluous space at the end: --- insertAttr attr valu = updateAssoc (Text.append valu . Text.cons ' ') attr +-- insertAttr attr valu = adjustAssoc (Text.append valu . Text.cons ' ') attr -- | Insert key-value pair into association list. --- If the key is already present, then the old associated values is replaced by the new one. --- Note: better use Data.Map instead of association lists, but --- some libraries use association lists efficiently for a small number of keys. --- Use in conjunction with Prelude.lookup -insertAssoc :: Eq k => (k,v) -> [(k,v)] -> [(k,v)] -insertAssoc kv@(key,_) = aux - where - aux [] = [kv] - aux (p@(k,_) : t) - | key==k = kv : t - | otherwise = p : aux t +-- If the new value is null/mempty, the first occurrence of the key is removed. (Unlike Data.Map.insert) +-- If the key is already present, then the first associated value is replaced by the new one. +-- Note: Avoid association lists, if possible. See GHC.Data.List.SetOps +-- Some of our libraries use association lists for very few keys. +insertAssoc :: (Eq k, MonoFoldable v) => k -> v -> [(k,v)] -> [(k,v)] +insertAssoc key val = aux + where + aux [] = mbcons [] + aux (p@(k,_) : t) + | key == k = mbcons t + | otherwise = p : aux t + mbcons t + | onull val = t + | otherwise = (key,val) : t --- | Update a value within an association list. --- If the key is not present, the update function is applied to mempty. --- Note: better use Data.Map instead of association lists, but --- some libraries use association lists efficiently for a small number of keys. --- Use in conjunction with Prelude.lookup -updateAssoc :: (Eq k, Monoid v) => (v -> v) -> k -> [(k,v)] -> [(k,v)] -updateAssoc upd key = aux - where - aux [] = [(key, upd mempty)] +insertAssoc' :: (Eq k, Eq v, Monoid v) => k -> v -> [(k,v)] -> [(k,v)] +insertAssoc' key val = adjustAssoc (const val) key + +-- | Update first matching key/value pair within an association list with a function. +-- If the key is not present, the update function is applied to mempty. (Unlike Data.Map.adjust) +-- If the result is mempty, the first occurrence of the key is removed. +-- Note: Avoid association lists, if possible. See GHC.Data.List.SetOps +adjustAssoc :: (Eq k, Eq v, Monoid v) => (v -> v) -> k -> [(k,v)] -> [(k,v)] +adjustAssoc upd key = aux + where + aux [] = mbcons key mempty [] aux (p@(k,v) : t) - | key == k = (k, upd v) : t - | otherwise = p : aux t + | key == k = mbcons k v t + | otherwise = p : aux t + mbcons k v t + | v' == mempty = t + | otherwise = (k,v') : t + where + v' = upd v -- | Copied form Util from package ghc partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])