-- |
-- A map transformer that allows unknown keys to map to a default value.
{-# LANGUAGE FlexibleContexts #-}
module Web.Route.Invertible.Map.Default
  ( DefaultMap(..)
  , defaultingMap
  , defaultingValue
  , withDefaultMap
  , lookupDefault
  ) where

import Control.Applicative ((<|>))
import Data.Semigroup (Semigroup((<>)))

-- |A map that also provides a default value, for when a key is not found in the underlying map, parameterized over the type of the map.
data DefaultMap m v = DefaultMap
  { DefaultMap m v -> m v
defaultMap :: !(m v)
  , DefaultMap m v -> Maybe v
defaultValue :: !(Maybe v)
  } deriving (DefaultMap m v -> DefaultMap m v -> Bool
(DefaultMap m v -> DefaultMap m v -> Bool)
-> (DefaultMap m v -> DefaultMap m v -> Bool)
-> Eq (DefaultMap m v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (m :: * -> *) v.
(Eq v, Eq (m v)) =>
DefaultMap m v -> DefaultMap m v -> Bool
/= :: DefaultMap m v -> DefaultMap m v -> Bool
$c/= :: forall (m :: * -> *) v.
(Eq v, Eq (m v)) =>
DefaultMap m v -> DefaultMap m v -> Bool
== :: DefaultMap m v -> DefaultMap m v -> Bool
$c== :: forall (m :: * -> *) v.
(Eq v, Eq (m v)) =>
DefaultMap m v -> DefaultMap m v -> Bool
Eq, Int -> DefaultMap m v -> ShowS
[DefaultMap m v] -> ShowS
DefaultMap m v -> String
(Int -> DefaultMap m v -> ShowS)
-> (DefaultMap m v -> String)
-> ([DefaultMap m v] -> ShowS)
-> Show (DefaultMap m v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m :: * -> *) v.
(Show v, Show (m v)) =>
Int -> DefaultMap m v -> ShowS
forall (m :: * -> *) v.
(Show v, Show (m v)) =>
[DefaultMap m v] -> ShowS
forall (m :: * -> *) v.
(Show v, Show (m v)) =>
DefaultMap m v -> String
showList :: [DefaultMap m v] -> ShowS
$cshowList :: forall (m :: * -> *) v.
(Show v, Show (m v)) =>
[DefaultMap m v] -> ShowS
show :: DefaultMap m v -> String
$cshow :: forall (m :: * -> *) v.
(Show v, Show (m v)) =>
DefaultMap m v -> String
showsPrec :: Int -> DefaultMap m v -> ShowS
$cshowsPrec :: forall (m :: * -> *) v.
(Show v, Show (m v)) =>
Int -> DefaultMap m v -> ShowS
Show)

instance Functor m => Functor (DefaultMap m) where
  fmap :: (a -> b) -> DefaultMap m a -> DefaultMap m b
fmap a -> b
f (DefaultMap m a
m Maybe a
d) = m b -> Maybe b -> DefaultMap m b
forall (m :: * -> *) v. m v -> Maybe v -> DefaultMap m v
DefaultMap ((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) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Maybe a
d)

instance (Semigroup v, Semigroup (m v)) => Semigroup (DefaultMap m v) where
  DefaultMap m v
m1 Maybe v
d1 <> :: DefaultMap m v -> DefaultMap m v -> DefaultMap m v
<> DefaultMap m v
m2 Maybe v
d2 = m v -> Maybe v -> DefaultMap m v
forall (m :: * -> *) v. m v -> Maybe v -> DefaultMap m v
DefaultMap (m v
m1 m v -> m v -> m v
forall a. Semigroup a => a -> a -> a
<> m v
m2) (Maybe v
d1 Maybe v -> Maybe v -> Maybe v
forall a. Semigroup a => a -> a -> a
<> Maybe v
d2)

instance (Monoid v, Monoid (m v)) => Monoid (DefaultMap m v) where
  mempty :: DefaultMap m v
mempty = m v -> Maybe v -> DefaultMap m v
forall (m :: * -> *) v. m v -> Maybe v -> DefaultMap m v
DefaultMap m v
forall a. Monoid a => a
mempty Maybe v
forall a. Maybe a
Nothing
  mappend :: DefaultMap m v -> DefaultMap m v -> DefaultMap m v
mappend (DefaultMap m v
m1 Maybe v
d1) (DefaultMap m v
m2 Maybe v
d2) = m v -> Maybe v -> DefaultMap m v
forall (m :: * -> *) v. m v -> Maybe v -> DefaultMap m v
DefaultMap (m v -> m v -> m v
forall a. Monoid a => a -> a -> a
mappend m v
m1 m v
m2) (Maybe v -> Maybe v -> Maybe v
forall a. Monoid a => a -> a -> a
mappend Maybe v
d1 Maybe v
d2)

-- |A simple map with no default value.
defaultingMap :: m v -> DefaultMap m v
defaultingMap :: m v -> DefaultMap m v
defaultingMap m v
m = m v -> Maybe v -> DefaultMap m v
forall (m :: * -> *) v. m v -> Maybe v -> DefaultMap m v
DefaultMap m v
m Maybe v
forall a. Maybe a
Nothing

-- |A trivial map with only a default value.
defaultingValue :: Monoid (m v) => v -> DefaultMap m v
defaultingValue :: v -> DefaultMap m v
defaultingValue = m v -> Maybe v -> DefaultMap m v
forall (m :: * -> *) v. m v -> Maybe v -> DefaultMap m v
DefaultMap m v
forall a. Monoid a => a
mempty (Maybe v -> DefaultMap m v)
-> (v -> Maybe v) -> v -> DefaultMap m v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Maybe v
forall a. a -> Maybe a
Just

-- |Transform the underlying map.
withDefaultMap :: (m v -> n v) -> DefaultMap m v -> DefaultMap n v
withDefaultMap :: (m v -> n v) -> DefaultMap m v -> DefaultMap n v
withDefaultMap m v -> n v
f (DefaultMap m v
m Maybe v
v) = n v -> Maybe v -> DefaultMap n v
forall (m :: * -> *) v. m v -> Maybe v -> DefaultMap m v
DefaultMap (m v -> n v
f m v
m) Maybe v
v

-- |Given a lookup function for the underlying map, return the default value instead if the value is not in the map.
lookupDefault :: (m v -> Maybe v) -> DefaultMap m v -> Maybe v
lookupDefault :: (m v -> Maybe v) -> DefaultMap m v -> Maybe v
lookupDefault m v -> Maybe v
l (DefaultMap m v
m Maybe v
d) = m v -> Maybe v
l m v
m Maybe v -> Maybe v -> Maybe v
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe v
d