{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables, GADTs #-}
module Web.Route.Invertible.Sequence
( Sequence(..)
, placeholderSequence
, wildcard
, sequenceValues
, renderSequence
, readsSequence
, parseSequence
, reverseSequence
) where
import Control.Invertible.Monoidal
import Control.Invertible.Monoidal.Free
import Control.Monad (MonadPlus, mzero, guard)
import Control.Monad.Fail (MonadFail)
import qualified Data.Invertible as I
import Data.String (IsString(..))
import Web.Route.Invertible.Parameter
import Web.Route.Invertible.Placeholder
newtype Sequence s a = Sequence { freeSequence :: Free (Placeholder s) a }
deriving (I.Functor, Monoidal, MonoidalAlt)
instance Show s => Show (Sequence s a) where
showsPrec d (Sequence s) = showParen (d > 10) $
showString "Sequence " . showsFree (showsPrec 11) s
placeholderSequence :: Placeholder s a -> Sequence s a
placeholderSequence = Sequence . Free
instance Parameterized s (Sequence s) where
parameter = placeholderSequence parameter
instance IsString s => IsString (Sequence s ()) where
fromString = placeholderSequence . fromString
wildcard :: (Parameterized s f, MonoidalAlt f, Parameter s a) => [a] -> f ()
wildcard d = d >$ manyI parameter
sequenceValues :: Sequence s a -> a -> [PlaceholderValue s]
sequenceValues = produceFree f . freeSequence where
f :: Placeholder s a' -> a' -> PlaceholderValue s
f (PlaceholderFixed t) () = PlaceholderValueFixed t
f PlaceholderParameter a = PlaceholderValueParameter a
renderSequence :: Sequence s a -> a -> [s]
renderSequence p = map renderPlaceholderValue . sequenceValues p
readsSequence :: forall m s a . (MonadPlus m, Eq s) => Sequence s a -> [s] -> m (a, [s])
readsSequence = parseFree f . freeSequence where
f :: Placeholder s a' -> s -> m a'
f (PlaceholderFixed t) a = guard (a == t)
f PlaceholderParameter a = maybe mzero return (parseParameter a)
parseSequence :: (MonadPlus m, MonadFail m, Eq s) => Sequence s a -> [s] -> m a
parseSequence p l = do
(a, []) <- readsSequence p l
return a
reverseSequence :: Sequence s a -> Sequence s a
reverseSequence = Sequence . reverseFree . freeSequence