{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
module Data.MonoidMap where
import Data.Witherable
import Data.Semigroup.Commutative
import Data.Map.Monoidal (MonoidalMap)
import qualified Data.Map.Monoidal as Map
import Data.Semigroup (Semigroup, (<>))
import Reflex (Query, QueryResult, crop, Group(..))
import Data.Monoid.DecidablyEmpty
import GHC.TypeLits
newtype MonoidMap k v = MonoidMap { unMonoidMap :: MonoidalMap k v }
deriving (Show, Eq, Ord, Foldable)
instance TypeError (Text "Use mapMonoidMap instead of fmap; MonoidMap is not a Functor because mempty values would need to be deleted, and Functors cannot change the shape of a datastructure") => Functor (MonoidMap k) where
fmap = error "Impossible"
emptyToNothing :: DecidablyEmpty a => a -> Maybe a
emptyToNothing a = if isEmpty a then Nothing else Just a
mapMonoidMap :: DecidablyEmpty b => (a -> b) -> MonoidMap k a -> MonoidMap k b
mapMonoidMap f (MonoidMap a) = MonoidMap $ mapMaybe (emptyToNothing . f) a
traverseMonoidMap :: (Ord k, DecidablyEmpty b, Applicative f) => (a -> f b) -> MonoidMap k a -> f (MonoidMap k b)
traverseMonoidMap f (MonoidMap a) = MonoidMap <$> wither (fmap emptyToNothing . f) a
instance (Ord k, DecidablyEmpty v) => DecidablyEmpty (MonoidMap k v) where
isEmpty (MonoidMap m) = Map.null m
monoidMap :: (Ord k, DecidablyEmpty v) => MonoidalMap k v -> MonoidMap k v
monoidMap = MonoidMap . Map.filter (not . isEmpty)
instance (DecidablyEmpty (QueryResult q), Ord k, Query q) => Query (MonoidMap k q) where
type QueryResult (MonoidMap k q) = MonoidMap k (QueryResult q)
crop (MonoidMap q) (MonoidMap qr) =
monoidMap $ Map.intersectionWith crop q qr
instance (Monoid a, DecidablyEmpty a, Ord k) => Semigroup (MonoidMap k a) where
MonoidMap a <> MonoidMap b =
let combine _ a' b' =
let c = a' `mappend` b'
in if isEmpty c
then Nothing
else Just c
in MonoidMap $ Map.mergeWithKey combine id id a b
instance (Ord k, DecidablyEmpty a) => Monoid (MonoidMap k a) where
mempty = MonoidMap Map.empty
mappend = (<>)
instance (Ord k, DecidablyEmpty a, Group a) => Group (MonoidMap k a) where
negateG (MonoidMap a) = MonoidMap $ fmap negateG a
instance (Ord k, DecidablyEmpty a, Group a, Commutative a) => Commutative (MonoidMap k a)