-- |
-- A map transformer that allows all keys to (additionally) map to a constant value.
{-# LANGUAGE FlexibleContexts #-}
module Web.Route.Invertible.Map.Const
  ( ConstMap(..)
  , withConstMap
  , constantMap
  , constantValue
  , lookupConst
  , flattenConstMap
  , ConstDefaultMap
  , flattenConstDefaultMap
  ) where

import Web.Route.Invertible.Map.Default

-- |A monoid map where every key (additionally) maps to the same constant value, parameterized over the type of the map.
data ConstMap m v = ConstMap
  { ConstMap m v -> m v
constMap :: !(m v) -- ^The underlying map.
  , ConstMap m v -> v
constValue :: !v } -- ^The constant value to return for any key.
  deriving (Int -> ConstMap m v -> ShowS
[ConstMap m v] -> ShowS
ConstMap m v -> String
(Int -> ConstMap m v -> ShowS)
-> (ConstMap m v -> String)
-> ([ConstMap m v] -> ShowS)
-> Show (ConstMap m v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m :: * -> *) v.
(Show v, Show (m v)) =>
Int -> ConstMap m v -> ShowS
forall (m :: * -> *) v.
(Show v, Show (m v)) =>
[ConstMap m v] -> ShowS
forall (m :: * -> *) v.
(Show v, Show (m v)) =>
ConstMap m v -> String
showList :: [ConstMap m v] -> ShowS
$cshowList :: forall (m :: * -> *) v.
(Show v, Show (m v)) =>
[ConstMap m v] -> ShowS
show :: ConstMap m v -> String
$cshow :: forall (m :: * -> *) v.
(Show v, Show (m v)) =>
ConstMap m v -> String
showsPrec :: Int -> ConstMap m v -> ShowS
$cshowsPrec :: forall (m :: * -> *) v.
(Show v, Show (m v)) =>
Int -> ConstMap m v -> ShowS
Show)

instance Functor m => Functor (ConstMap m) where
  fmap :: (a -> b) -> ConstMap m a -> ConstMap m b
fmap a -> b
f (ConstMap m a
m a
v) = m b -> b -> ConstMap m b
forall (m :: * -> *) v. m v -> v -> ConstMap m v
ConstMap ((a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f m a
m) (a -> b
f a
v)

instance (Semigroup v, Semigroup (m v)) => Semigroup (ConstMap m v) where
  ConstMap m v
m1 v
v1 <> :: ConstMap m v -> ConstMap m v -> ConstMap m v
<> ConstMap m v
m2 v
v2 = m v -> v -> ConstMap m v
forall (m :: * -> *) v. m v -> v -> ConstMap m v
ConstMap (m v
m1 m v -> m v -> m v
forall a. Semigroup a => a -> a -> a
<> m v
m2) (v
v1 v -> v -> v
forall a. Semigroup a => a -> a -> a
<> v
v2)

instance (Monoid v, Monoid (m v)) => Monoid (ConstMap m v) where
  mempty :: ConstMap m v
mempty = m v -> v -> ConstMap m v
forall (m :: * -> *) v. m v -> v -> ConstMap m v
ConstMap m v
forall a. Monoid a => a
mempty v
forall a. Monoid a => a
mempty
  mappend :: ConstMap m v -> ConstMap m v -> ConstMap m v
mappend (ConstMap m v
m1 v
v1) (ConstMap m v
m2 v
v2) = m v -> v -> ConstMap m v
forall (m :: * -> *) v. m v -> v -> ConstMap m v
ConstMap (m v -> m v -> m v
forall a. Monoid a => a -> a -> a
mappend m v
m1 m v
m2) (v -> v -> v
forall a. Monoid a => a -> a -> a
mappend v
v1 v
v2)

-- |Transform the underlying map.
withConstMap :: (m v -> n v) -> ConstMap m v -> ConstMap n v
withConstMap :: (m v -> n v) -> ConstMap m v -> ConstMap n v
withConstMap m v -> n v
f (ConstMap m v
m v
v) = n v -> v -> ConstMap n v
forall (m :: * -> *) v. m v -> v -> ConstMap m v
ConstMap (m v -> n v
f m v
m) v
v

-- |A simple map that has no constant value (or rather, has a constant value of 'mempty') so acts just like the given monoid map.
constantMap :: Monoid v => m v -> ConstMap m v
constantMap :: m v -> ConstMap m v
constantMap m v
m = m v -> v -> ConstMap m v
forall (m :: * -> *) v. m v -> v -> ConstMap m v
ConstMap m v
m v
forall a. Monoid a => a
mempty

-- |A trivial map that maps all keys to the same value.
constantValue :: Monoid (m v) => v -> ConstMap m v
constantValue :: v -> ConstMap m v
constantValue = m v -> v -> ConstMap m v
forall (m :: * -> *) v. m v -> v -> ConstMap m v
ConstMap m v
forall a. Monoid a => a
mempty

-- |Given a lookup function for the underlying map, add the constant value to the result (using '<>').
lookupConst :: Semigroup v => (m v -> v) -> ConstMap m v -> v
lookupConst :: (m v -> v) -> ConstMap m v -> v
lookupConst m v -> v
l (ConstMap m v
m v
v) = m v -> v
l m v
m v -> v -> v
forall a. Semigroup a => a -> a -> a
<> v
v

-- |Convert a 'ConstMap' to an equivalent but more efficient 'DefaultMap'.
-- Although the resulting map will return the same value for lookups, combining it with other maps will have different results (this operation is not distributive).
flattenConstMap :: (Functor m, Semigroup v) => ConstMap m v -> DefaultMap m v
flattenConstMap :: ConstMap m v -> DefaultMap m v
flattenConstMap (ConstMap m v
m v
v) = m v -> Maybe v -> DefaultMap m v
forall (m :: * -> *) v. m v -> Maybe v -> DefaultMap m v
DefaultMap ((v -> v) -> m v -> m v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (v -> v -> v
forall a. Semigroup a => a -> a -> a
<> v
v) m v
m) (v -> Maybe v
forall a. a -> Maybe a
Just v
v)

-- |A 'DefaultMap' wrapped in a 'ConstMap', for when you want both a constant and default value.
type ConstDefaultMap m = ConstMap (DefaultMap m)

-- |Do the same as 'flattenConstMap' but for 'ConstDefaultMap' by merging the resulting 'DefaultMap' layers.
flattenConstDefaultMap :: (Functor m, Semigroup v) => ConstDefaultMap m v -> DefaultMap m v
flattenConstDefaultMap :: ConstDefaultMap m v -> DefaultMap m v
flattenConstDefaultMap (ConstMap (DefaultMap m v
m Maybe v
d) v
v) = m v -> Maybe v -> DefaultMap m v
forall (m :: * -> *) v. m v -> Maybe v -> DefaultMap m v
DefaultMap ((v -> v) -> m v -> m v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (v -> v -> v
forall a. Semigroup a => a -> a -> a
<> v
v) m v
m) (Maybe v
d Maybe v -> Maybe v -> Maybe v
forall a. Semigroup a => a -> a -> a
<> v -> Maybe v
forall a. a -> Maybe a
Just v
v)