typeable/validationt
1
0
Fork 0
mirror of https://github.com/typeable/validationt.git synced 2024-11-22 01:34:05 +03:00
Code Issues Projects Releases Wiki Activity

Fix review comments

Browse Source
This commit is contained in:
Dmitry Bushev 2018-04-23 10:46:26 +03:00
parent b1ec015761
commit 2a7adf2bdc
No known key found for this signature in database
GPG Key ID: 87C16090D6910E91
1 changed files with 13 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
src/Control/Monad/Validation.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
@ -48,14 +49,14 @@ instance (Ord k) => Ixed (MonoidMap k v) where
instance (Ord k) => At (MonoidMap k v) where
at key = _MonoidMap . at key
#if MIN_VERSION_base(4,11,0)
instance (Ord k, S.Semigroup v) => S.Semigroup (MonoidMap k v) where
(MonoidMap a) <> (MonoidMap b) =
MonoidMap $ M.unionWith (S.<>) a b
(<>) = mmAppend
#endif
instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
mempty = MonoidMap M.empty
mappend (MonoidMap a) (MonoidMap b) =
MonoidMap $ M.unionWith (<>) a b
mappend = mmAppend
instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
@ -75,6 +76,14 @@ instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
val <- obj .: "value"
return (key, val)
#if MIN_VERSION_base(4,11,0)
mmAppend :: (Ord k, S.Semigroup v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (S.<>) a b
#else
mmAppend :: (Ord k, Monoid v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b
#endif
-- | Convenient for 'vZoom' as first artument. Will prevent generation
-- of map with 'mempty' values
mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v