refactor(utils): code cleaning

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)

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?

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.
+--   If the new value is null/mempty, the first occurrence of the key is removed. (Unlike Data.Map.insert)
---   Note: better use Data.Map instead of association lists, but 
+--   If the key is already present, then the first associated value is replaced by the new one.
---   some libraries use association lists efficiently for a small number of keys.
+--   Note: Avoid association lists, if possible. See GHC.Data.List.SetOps
---   Use in conjunction with Prelude.lookup
+--   Some of our libraries use association lists for very few keys.
-insertAssoc :: Eq k => (k,v) -> [(k,v)] -> [(k,v)]
+insertAssoc :: (Eq k, MonoFoldable v) => k -> v -> [(k,v)] -> [(k,v)]
-insertAssoc kv@(key,_) = aux 
+insertAssoc key val = aux 
-  where 
+  where  
-    aux [] = [kv]    
+    aux [] = mbcons []
-    aux (p@(k,_) : t)
+    aux (p@(k,_) : t)       
-      | key==k    = kv :     t
+      | key == k  = mbcons t
-      | otherwise =  p : aux t
+      | otherwise = p : aux t 
+    mbcons t 
+      | onull val = t
+      | otherwise = (key,val) : t
 
--- | Update a value within an association list.
+insertAssoc' :: (Eq k, Eq v, Monoid v) => k -> v -> [(k,v)] -> [(k,v)]
---   If the key is not present, the update function is applied to mempty.
+insertAssoc' key val = adjustAssoc (const val) key
---   Note: better use Data.Map instead of association lists, but 
+
---   some libraries use association lists efficiently for a small number of keys.
+-- | Update first matching key/value pair within an association list with a function.
---   Use in conjunction with Prelude.lookup
+--   If the key is not present, the update function is applied to mempty. (Unlike Data.Map.adjust)
-updateAssoc :: (Eq k, Monoid v) => (v -> v) -> k -> [(k,v)] -> [(k,v)]
+--   If the result is mempty, the first occurrence of the key is removed.
-updateAssoc upd key = aux 
+--   Note: Avoid association lists, if possible. See GHC.Data.List.SetOps
-  where 
+adjustAssoc :: (Eq k, Eq v, Monoid v) => (v -> v) -> k -> [(k,v)] -> [(k,v)]
-    aux [] = [(key, upd mempty)]
+adjustAssoc upd key = aux
+  where
+    aux []        = mbcons key mempty []
     aux (p@(k,v) : t)
-      | key == k  = (k, upd v) :     t
+      | key == k  = mbcons k   v      t
-      | otherwise =   p        : aux 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])