-- |
-- Hybrid maps keyed on 'Placeholder', using "Data.HashMap.Strict" and "Web.Route.Invertible.Map.ParameterType".
{-# LANGUAGE GADTs #-}
module Web.Route.Invertible.Map.Placeholder
  ( PlaceholderMap(..)
  , emptyPlaceholderMap
  , unionPlaceholderWith
  , singletonPlaceholder
  , singletonPlaceholderState
  , insertPlaceholder
  , lookupPlaceholder
  , lookupPlaceholderWith
  ) where

import Prelude hiding (lookup)

import Control.Arrow (first)
import Data.Dynamic (Dynamic)
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict as M

import Web.Route.Invertible.String
import Web.Route.Invertible.Placeholder
import Web.Route.Invertible.Dynamics
import Web.Route.Invertible.Map.Monoid
import Web.Route.Invertible.Map.ParameterType

-- |A map from 'Placeholder' keys to values, allowing lookups on @s@ strings.
-- 'PlaceholderFixed' keys represent normal keys, always take precedence, and provide /O(log n)/ operations.
-- 'PlaceholderParameter' keys represent types and allow multiple, dynamic parser-based lookups, at most /O(n)/.
data PlaceholderMap s a = PlaceholderMap
  { PlaceholderMap s a -> HashMap s a
placeholderMapFixed :: !(HM.HashMap s a)
  , PlaceholderMap s a -> ParameterTypeMap s a
placeholderMapParameter :: !(ParameterTypeMap s a)
  } deriving (PlaceholderMap s a -> PlaceholderMap s a -> Bool
(PlaceholderMap s a -> PlaceholderMap s a -> Bool)
-> (PlaceholderMap s a -> PlaceholderMap s a -> Bool)
-> Eq (PlaceholderMap s a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s a.
(Eq s, Eq a) =>
PlaceholderMap s a -> PlaceholderMap s a -> Bool
/= :: PlaceholderMap s a -> PlaceholderMap s a -> Bool
$c/= :: forall s a.
(Eq s, Eq a) =>
PlaceholderMap s a -> PlaceholderMap s a -> Bool
== :: PlaceholderMap s a -> PlaceholderMap s a -> Bool
$c== :: forall s a.
(Eq s, Eq a) =>
PlaceholderMap s a -> PlaceholderMap s a -> Bool
Eq, Int -> PlaceholderMap s a -> ShowS
[PlaceholderMap s a] -> ShowS
PlaceholderMap s a -> String
(Int -> PlaceholderMap s a -> ShowS)
-> (PlaceholderMap s a -> String)
-> ([PlaceholderMap s a] -> ShowS)
-> Show (PlaceholderMap s a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s a. (Show s, Show a) => Int -> PlaceholderMap s a -> ShowS
forall s a. (Show s, Show a) => [PlaceholderMap s a] -> ShowS
forall s a. (Show s, Show a) => PlaceholderMap s a -> String
showList :: [PlaceholderMap s a] -> ShowS
$cshowList :: forall s a. (Show s, Show a) => [PlaceholderMap s a] -> ShowS
show :: PlaceholderMap s a -> String
$cshow :: forall s a. (Show s, Show a) => PlaceholderMap s a -> String
showsPrec :: Int -> PlaceholderMap s a -> ShowS
$cshowsPrec :: forall s a. (Show s, Show a) => Int -> PlaceholderMap s a -> ShowS
Show)

instance (RouteString s, Semigroup a) => Semigroup (PlaceholderMap s a) where
  <> :: PlaceholderMap s a -> PlaceholderMap s a -> PlaceholderMap s a
(<>) = (a -> a -> a)
-> PlaceholderMap s a -> PlaceholderMap s a -> PlaceholderMap s a
forall s a.
RouteString s =>
(a -> a -> a)
-> PlaceholderMap s a -> PlaceholderMap s a -> PlaceholderMap s a
unionPlaceholderWith a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

-- |Values are combined using 'mappend'.
instance (RouteString s, Monoid a) => Monoid (PlaceholderMap s a) where
  mempty :: PlaceholderMap s a
mempty = PlaceholderMap s a
forall s a. PlaceholderMap s a
emptyPlaceholderMap
  mappend :: PlaceholderMap s a -> PlaceholderMap s a -> PlaceholderMap s a
mappend = (a -> a -> a)
-> PlaceholderMap s a -> PlaceholderMap s a -> PlaceholderMap s a
forall s a.
RouteString s =>
(a -> a -> a)
-> PlaceholderMap s a -> PlaceholderMap s a -> PlaceholderMap s a
unionPlaceholderWith a -> a -> a
forall a. Monoid a => a -> a -> a
mappend

instance Functor (PlaceholderMap s) where
  fmap :: (a -> b) -> PlaceholderMap s a -> PlaceholderMap s b
fmap a -> b
f (PlaceholderMap HashMap s a
s ParameterTypeMap s a
p) = HashMap s b -> ParameterTypeMap s b -> PlaceholderMap s b
forall s a.
HashMap s a -> ParameterTypeMap s a -> PlaceholderMap s a
PlaceholderMap ((a -> b) -> HashMap s a -> HashMap s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f HashMap s a
s) ((a -> b) -> ParameterTypeMap s a -> ParameterTypeMap s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ParameterTypeMap s a
p)

-- |The empty map.
emptyPlaceholderMap :: PlaceholderMap s a
emptyPlaceholderMap :: PlaceholderMap s a
emptyPlaceholderMap = HashMap s a -> ParameterTypeMap s a -> PlaceholderMap s a
forall s a.
HashMap s a -> ParameterTypeMap s a -> PlaceholderMap s a
PlaceholderMap HashMap s a
forall k v. HashMap k v
HM.empty (Map (ParameterType s) a -> ParameterTypeMap s a
forall k a. Map k a -> MonoidMap k a
MonoidMap Map (ParameterType s) a
forall k a. Map k a
M.empty)

-- |Union with a combining function.
unionPlaceholderWith :: RouteString s => (a -> a -> a) -> PlaceholderMap s a -> PlaceholderMap s a -> PlaceholderMap s a
unionPlaceholderWith :: (a -> a -> a)
-> PlaceholderMap s a -> PlaceholderMap s a -> PlaceholderMap s a
unionPlaceholderWith a -> a -> a
f (PlaceholderMap HashMap s a
s1 (MonoidMap Map (ParameterType s) a
p1)) (PlaceholderMap HashMap s a
s2 (MonoidMap Map (ParameterType s) a
p2)) =
  HashMap s a -> MonoidMap (ParameterType s) a -> PlaceholderMap s a
forall s a.
HashMap s a -> ParameterTypeMap s a -> PlaceholderMap s a
PlaceholderMap ((a -> a -> a) -> HashMap s a -> HashMap s a -> HashMap s a
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HM.unionWith a -> a -> a
f HashMap s a
s1 HashMap s a
s2) (Map (ParameterType s) a -> MonoidMap (ParameterType s) a
forall k a. Map k a -> MonoidMap k a
MonoidMap (Map (ParameterType s) a -> MonoidMap (ParameterType s) a)
-> Map (ParameterType s) a -> MonoidMap (ParameterType s) a
forall a b. (a -> b) -> a -> b
$ (a -> a -> a)
-> Map (ParameterType s) a
-> Map (ParameterType s) a
-> Map (ParameterType s) a
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith a -> a -> a
f Map (ParameterType s) a
p1 Map (ParameterType s) a
p2)

-- |A map with a single element.
singletonPlaceholder :: RouteString s => Placeholder s p -> a -> PlaceholderMap s a
singletonPlaceholder :: Placeholder s p -> a -> PlaceholderMap s a
singletonPlaceholder (PlaceholderFixed s
t) a
v = HashMap s a -> ParameterTypeMap s a -> PlaceholderMap s a
forall s a.
HashMap s a -> ParameterTypeMap s a -> PlaceholderMap s a
PlaceholderMap (s -> a -> HashMap s a
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton s
t a
v) (Map (ParameterType s) a -> ParameterTypeMap s a
forall k a. Map k a -> MonoidMap k a
MonoidMap Map (ParameterType s) a
forall k a. Map k a
M.empty)
singletonPlaceholder t :: Placeholder s p
t@Placeholder s p
PlaceholderParameter a
v = HashMap s a -> ParameterTypeMap s a -> PlaceholderMap s a
forall s a.
HashMap s a -> ParameterTypeMap s a -> PlaceholderMap s a
PlaceholderMap HashMap s a
forall k v. HashMap k v
HM.empty (Placeholder s p -> a -> ParameterTypeMap s a
forall s p (proxy :: * -> *) a.
Parameter s p =>
proxy p -> a -> ParameterTypeMap s a
singletonParameterType Placeholder s p
t a
v)

placeholderState :: Placeholder s a -> DynamicState a
placeholderState :: Placeholder s a -> DynamicState a
placeholderState (PlaceholderFixed s
_) = () -> StateT Dynamics Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
placeholderState Placeholder s a
PlaceholderParameter = DynamicState a
forall a. Typeable a => DynamicState a
getDynamic

singletonPlaceholderState :: RouteString s => Placeholder s a -> PlaceholderMap s (DynamicState a)
singletonPlaceholderState :: Placeholder s a -> PlaceholderMap s (DynamicState a)
singletonPlaceholderState Placeholder s a
p = Placeholder s a
-> DynamicState a -> PlaceholderMap s (DynamicState a)
forall s p a.
RouteString s =>
Placeholder s p -> a -> PlaceholderMap s a
singletonPlaceholder Placeholder s a
p (DynamicState a -> PlaceholderMap s (DynamicState a))
-> DynamicState a -> PlaceholderMap s (DynamicState a)
forall a b. (a -> b) -> a -> b
$ Placeholder s a -> DynamicState a
forall s a. Placeholder s a -> DynamicState a
placeholderState Placeholder s a
p

-- |Insert a new key and value in the map.
insertPlaceholder :: RouteString s => Placeholder s p -> a -> PlaceholderMap s a -> PlaceholderMap s a
insertPlaceholder :: Placeholder s p -> a -> PlaceholderMap s a -> PlaceholderMap s a
insertPlaceholder (PlaceholderFixed s
t) a
v (PlaceholderMap HashMap s a
s ParameterTypeMap s a
p) = HashMap s a -> ParameterTypeMap s a -> PlaceholderMap s a
forall s a.
HashMap s a -> ParameterTypeMap s a -> PlaceholderMap s a
PlaceholderMap (s -> a -> HashMap s a -> HashMap s a
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert s
t a
v HashMap s a
s) ParameterTypeMap s a
p
insertPlaceholder t :: Placeholder s p
t@Placeholder s p
PlaceholderParameter a
v (PlaceholderMap HashMap s a
s ParameterTypeMap s a
p) = HashMap s a -> ParameterTypeMap s a -> PlaceholderMap s a
forall s a.
HashMap s a -> ParameterTypeMap s a -> PlaceholderMap s a
PlaceholderMap HashMap s a
s (Placeholder s p
-> a -> ParameterTypeMap s a -> ParameterTypeMap s a
forall s p (proxy :: * -> *) a.
Parameter s p =>
proxy p -> a -> ParameterTypeMap s a -> ParameterTypeMap s a
insertParameterType Placeholder s p
t a
v ParameterTypeMap s a
p)

-- |Lookup a string in the map, returning either the value associated with a 'PlaceholderFixed' key, or the list of matching 'PlaceholderParameter' keys, parsed into a 'Dynamic' representation (the result of 'parseParameter') and the associated value, if any.
-- If no keys match, the result is @Right []@.
lookupPlaceholder :: RouteString s => s -> PlaceholderMap s a -> Either a [(Dynamic, a)]
lookupPlaceholder :: s -> PlaceholderMap s a -> Either a [(Dynamic, a)]
lookupPlaceholder s
t (PlaceholderMap HashMap s a
s ParameterTypeMap s a
p) =
  Either a [(Dynamic, a)]
-> (a -> Either a [(Dynamic, a)])
-> Maybe a
-> Either a [(Dynamic, a)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([(Dynamic, a)] -> Either a [(Dynamic, a)]
forall a b. b -> Either a b
Right ([(Dynamic, a)] -> Either a [(Dynamic, a)])
-> [(Dynamic, a)] -> Either a [(Dynamic, a)]
forall a b. (a -> b) -> a -> b
$ s -> ParameterTypeMap s a -> [(Dynamic, a)]
forall s a. s -> ParameterTypeMap s a -> [(Dynamic, a)]
lookupParameterType s
t ParameterTypeMap s a
p) a -> Either a [(Dynamic, a)]
forall a b. a -> Either a b
Left (Maybe a -> Either a [(Dynamic, a)])
-> Maybe a -> Either a [(Dynamic, a)]
forall a b. (a -> b) -> a -> b
$ s -> HashMap s a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup s
t HashMap s a
s

lookupPlaceholderWith :: RouteString s => s -> PlaceholderMap s a -> (a -> [DynamicResult b]) -> [DynamicResult b]
lookupPlaceholderWith :: s
-> PlaceholderMap s a
-> (a -> [DynamicResult b])
-> [DynamicResult b]
lookupPlaceholderWith s
t (PlaceholderMap HashMap s a
s ParameterTypeMap s a
p) a -> [DynamicResult b]
f =
  [DynamicResult b]
-> (a -> [DynamicResult b]) -> Maybe a -> [DynamicResult b]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (((Dynamic, a) -> [DynamicResult b])
-> [(Dynamic, a)] -> [DynamicResult b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Dynamic
x,a
n) -> (Dynamics -> Dynamics) -> DynamicResult b -> DynamicResult b
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Dynamic
xDynamic -> Dynamics -> Dynamics
forall a. a -> [a] -> [a]
:) (DynamicResult b -> DynamicResult b)
-> [DynamicResult b] -> [DynamicResult b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [DynamicResult b]
f a
n) ([(Dynamic, a)] -> [DynamicResult b])
-> [(Dynamic, a)] -> [DynamicResult b]
forall a b. (a -> b) -> a -> b
$ s -> ParameterTypeMap s a -> [(Dynamic, a)]
forall s a. s -> ParameterTypeMap s a -> [(Dynamic, a)]
lookupParameterType s
t ParameterTypeMap s a
p) a -> [DynamicResult b]
f (Maybe a -> [DynamicResult b]) -> Maybe a -> [DynamicResult b]
forall a b. (a -> b) -> a -> b
$ s -> HashMap s a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup s
t HashMap s a
s