{-# LANGUAGE GADTs, ScopedTypeVariables #-}
module Web.Route.Invertible.Map.Sequence
( SequenceMap(..)
, singletonSequence
, lookupSequence
, SequenceMapApp
, singletonSequenceApp
, lookupSequenceApp
) where
import Prelude hiding (lookup)
import Control.Applicative (Alternative(..))
import Control.Invertible.Monoidal.Free
import Control.Monad (MonadPlus(..))
import Control.Monad.Trans.State (evalState)
import Web.Route.Invertible.String
import Web.Route.Invertible.Placeholder
import Web.Route.Invertible.Sequence
import Web.Route.Invertible.Dynamics
import Web.Route.Invertible.Map.Placeholder
data SequenceMap s a = SequenceMap
{ sequenceMapPlaceholder :: PlaceholderMap s (SequenceMap s a)
, sequenceMapValue :: !(Maybe a)
} deriving (Eq, Show)
unionSequenceWith :: RouteString s => (Maybe a -> Maybe a -> Maybe a) -> SequenceMap s a -> SequenceMap s a -> SequenceMap s a
unionSequenceWith f (SequenceMap m1 v1) (SequenceMap m2 v2) =
SequenceMap (unionPlaceholderWith (unionSequenceWith f) m1 m2) (f v1 v2)
instance (RouteString s, Monoid a) => Monoid (SequenceMap s a) where
mempty = empty
mappend = unionSequenceWith mappend
instance Functor (SequenceMap s) where
fmap f (SequenceMap m v) = SequenceMap (fmap f <$> m) (f <$> v)
leaf :: Maybe a -> SequenceMap s a
leaf = SequenceMap emptyPlaceholderMap
instance RouteString s => Applicative (SequenceMap s) where
pure = leaf . Just
SequenceMap fm fv <*> a = maybe id (\f -> (f <$> a <|>)) fv
$ SequenceMap ((<*> a) <$> fm) Nothing
SequenceMap am Nothing *> b =
SequenceMap ((*> b) <$> am) Nothing
SequenceMap am (Just _) *> b = b <|>
SequenceMap ((*> b) <$> am) Nothing
instance RouteString s => Alternative (SequenceMap s) where
empty = leaf Nothing
(<|>) = unionSequenceWith (<|>)
instance RouteString s => Monad (SequenceMap s) where
SequenceMap mm mv >>= f = maybe id ((<|>) . f) mv
$ SequenceMap ((>>= f) <$> mm) Nothing
(>>) = (*>)
instance RouteString s => MonadPlus (SequenceMap s)
newtype SequenceMapP s a = SequenceMapP { sequenceMapP :: SequenceMap s (DynamicState a) }
instance Functor (SequenceMapP s) where
fmap f (SequenceMapP m) = SequenceMapP $ fmap (fmap f) m
instance RouteString s => Applicative (SequenceMapP s) where
pure = SequenceMapP . pure . pure
SequenceMapP f <*> SequenceMapP m = SequenceMapP $ ((<*>) <$> f) <*> m
SequenceMapP a *> SequenceMapP b = SequenceMapP $ ( (*>) <$> a) *> b
instance RouteString s => Alternative (SequenceMapP s) where
empty = SequenceMapP empty
SequenceMapP a <|> SequenceMapP b = SequenceMapP $ a <|> b
placeholderMap :: RouteString s => Placeholder s a -> SequenceMapP s a
placeholderMap p = SequenceMapP $
SequenceMap (pure <$> singletonPlaceholderState p) Nothing
singletonSequenceP :: RouteString s => Sequence s a -> SequenceMapP s a
singletonSequenceP = runFree . mapFree placeholderMap . freeSequence
singletonSequence :: RouteString s => Sequence s a -> SequenceMap s (DynamicState a)
singletonSequence = sequenceMapP . singletonSequenceP
lookupSequence :: RouteString s => [s] -> SequenceMap s a -> [DynamicResult a]
lookupSequence (s:l) (SequenceMap m _) = lookupPlaceholderWith s m $ lookupSequence l
lookupSequence [] (SequenceMap _ Nothing) = mzero
lookupSequence [] (SequenceMap _ (Just x)) = return ([], x)
type SequenceMapApp s m a = SequenceMap s (m (Dynamics -> a))
singletonSequenceApp :: (RouteString s, Functor m) => Sequence s a -> m (a -> b) -> SequenceMapApp s m b
singletonSequenceApp p m = (\f -> fmap (. evalState f) m) <$> singletonSequence p
lookupSequenceApp :: (RouteString s, Functor m, Monoid (m a)) => [s] -> SequenceMapApp s m a -> m a
lookupSequenceApp l = foldMap (\(x, f) -> fmap ($ x) f) . lookupSequence l