-- |
-- The internal representation for sequences of placeholders, such as paths.
-- For example, the following represents a sequence of @['PlaceholderFixed' "item", 'PlaceholderParameter']@:
--
-- >>> :set -XOverloadedStrings
-- >>> import Control.Invertible.Monoidal
-- >>> import Web.Route.Invertible.Parameter
-- >>> let p = "item" *< parameter :: Sequence String Int
-- >>> parseSequence p ["item", "123"]
-- 123
-- >>> renderSequence p 123
-- ["item","123"]
--
-- These are used as the basis for path routers and other sequential/nested types.
{-# 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 qualified Data.Invertible as I
import           Data.String (IsString(..))

import Web.Route.Invertible.Parameter
import Web.Route.Invertible.Placeholder

-- |A parser/reverse-router isomorphism between sequences of strings (represented as @[s]@) and a value @a@.
-- These can be constructed using:
--
--   * @'fromString' s@ (or simply @s@ with OverloadedStrings), which matches a single literal component.
--   * @'parameter'@ (or @'param' (undefined :: T)@ for an explicit type), which matches a place-holder component for a 'Parameter' type.
--
-- Sequence values can then be composed using 'Monoidal' and 'MonoidalAlt'.
newtype Sequence s a = Sequence { Sequence s a -> Free (Placeholder s) a
freeSequence :: Free (Placeholder s) a }
  deriving ((a <-> b) -> Sequence s a -> Sequence s b
(forall a b. (a <-> b) -> Sequence s a -> Sequence s b)
-> Functor (Sequence s)
forall a b. (a <-> b) -> Sequence s a -> Sequence s b
forall s a b. (a <-> b) -> Sequence s a -> Sequence s b
forall (f :: * -> *).
(forall a b. (a <-> b) -> f a -> f b) -> Functor f
fmap :: (a <-> b) -> Sequence s a -> Sequence s b
$cfmap :: forall s a b. (a <-> b) -> Sequence s a -> Sequence s b
I.Functor, Functor (Sequence s)
Sequence s ()
Functor (Sequence s)
-> Sequence s ()
-> (forall a b. Sequence s a -> Sequence s b -> Sequence s (a, b))
-> Monoidal (Sequence s)
Sequence s a -> Sequence s b -> Sequence s (a, b)
forall s. Functor (Sequence s)
forall s. Sequence s ()
forall a b. Sequence s a -> Sequence s b -> Sequence s (a, b)
forall s a b. Sequence s a -> Sequence s b -> Sequence s (a, b)
forall (f :: * -> *).
Functor f
-> f () -> (forall a b. f a -> f b -> f (a, b)) -> Monoidal f
>*< :: Sequence s a -> Sequence s b -> Sequence s (a, b)
$c>*< :: forall s a b. Sequence s a -> Sequence s b -> Sequence s (a, b)
unit :: Sequence s ()
$cunit :: forall s. Sequence s ()
$cp1Monoidal :: forall s. Functor (Sequence s)
Monoidal, Monoidal (Sequence s)
Sequence s Void
Monoidal (Sequence s)
-> Sequence s Void
-> (forall a b.
    Sequence s a -> Sequence s b -> Sequence s (Either a b))
-> MonoidalAlt (Sequence s)
Sequence s a -> Sequence s b -> Sequence s (Either a b)
forall s. Monoidal (Sequence s)
forall s. Sequence s Void
forall a b. Sequence s a -> Sequence s b -> Sequence s (Either a b)
forall s a b.
Sequence s a -> Sequence s b -> Sequence s (Either a b)
forall (f :: * -> *).
Monoidal f
-> f Void
-> (forall a b. f a -> f b -> f (Either a b))
-> MonoidalAlt f
>|< :: Sequence s a -> Sequence s b -> Sequence s (Either a b)
$c>|< :: forall s a b.
Sequence s a -> Sequence s b -> Sequence s (Either a b)
zero :: Sequence s Void
$czero :: forall s. Sequence s Void
$cp1MonoidalAlt :: forall s. Monoidal (Sequence s)
MonoidalAlt)

instance Show s => Show (Sequence s a) where
  showsPrec :: Int -> Sequence s a -> ShowS
showsPrec Int
d (Sequence Free (Placeholder s) a
s) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
"Sequence " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a'. Placeholder s a' -> ShowS)
-> Free (Placeholder s) a -> ShowS
forall (f :: * -> *) a.
(forall a'. f a' -> ShowS) -> Free f a -> ShowS
showsFree (Int -> Placeholder s a' -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11) Free (Placeholder s) a
s

-- |Make a singleton 'Sequence' out of a 'Placeholder'.
placeholderSequence :: Placeholder s a -> Sequence s a
placeholderSequence :: Placeholder s a -> Sequence s a
placeholderSequence = Free (Placeholder s) a -> Sequence s a
forall s a. Free (Placeholder s) a -> Sequence s a
Sequence (Free (Placeholder s) a -> Sequence s a)
-> (Placeholder s a -> Free (Placeholder s) a)
-> Placeholder s a
-> Sequence s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Placeholder s a -> Free (Placeholder s) a
forall (f :: * -> *) a. f a -> Free f a
Free

instance Parameterized s (Sequence s) where
  parameter :: Sequence s a
parameter = Placeholder s a -> Sequence s a
forall s a. Placeholder s a -> Sequence s a
placeholderSequence Placeholder s a
forall s (p :: * -> *) a. (Parameterized s p, Parameter s a) => p a
parameter

instance IsString s => IsString (Sequence s ()) where
  fromString :: String -> Sequence s ()
fromString = Placeholder s () -> Sequence s ()
forall s a. Placeholder s a -> Sequence s a
placeholderSequence (Placeholder s () -> Sequence s ())
-> (String -> Placeholder s ()) -> String -> Sequence s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Placeholder s ()
forall a. IsString a => String -> a
fromString

-- |Ignore an arbitrary sequence of parameters (usually as a tail), always generating the same thing.
wildcard :: (Parameterized s f, MonoidalAlt f, Parameter s a) => [a] -> f ()
wildcard :: [a] -> f ()
wildcard [a]
d = [a]
d [a] -> f [a] -> f ()
forall (f :: * -> *) a. Functor f => a -> f a -> f ()
>$ f a -> f [a]
forall (f :: * -> *) a. MonoidalAlt f => f a -> f [a]
manyI f a
forall s (p :: * -> *) a. (Parameterized s p, Parameter s a) => p a
parameter

-- |Realize a 'Sequence' as instantiated by a value to a sequence of 'PlaceholderValue's.
sequenceValues :: Sequence s a -> a -> [PlaceholderValue s]
sequenceValues :: Sequence s a -> a -> [PlaceholderValue s]
sequenceValues = (forall a'. Placeholder s a' -> a' -> PlaceholderValue s)
-> Free (Placeholder s) a -> a -> [PlaceholderValue s]
forall (m :: * -> *) (f :: * -> *) b a.
Alternative m =>
(forall a'. f a' -> a' -> b) -> Free f a -> a -> m b
produceFree forall a'. Placeholder s a' -> a' -> PlaceholderValue s
forall s a'. Placeholder s a' -> a' -> PlaceholderValue s
f (Free (Placeholder s) a -> a -> [PlaceholderValue s])
-> (Sequence s a -> Free (Placeholder s) a)
-> Sequence s a
-> a
-> [PlaceholderValue s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sequence s a -> Free (Placeholder s) a
forall s a. Sequence s a -> Free (Placeholder s) a
freeSequence where
  f :: Placeholder s a' -> a' -> PlaceholderValue s
  f :: Placeholder s a' -> a' -> PlaceholderValue s
f (PlaceholderFixed s
t) () = s -> PlaceholderValue s
forall s. s -> PlaceholderValue s
PlaceholderValueFixed s
t
  f Placeholder s a'
PlaceholderParameter a'
a = a' -> PlaceholderValue s
forall s a. Parameter s a => a -> PlaceholderValue s
PlaceholderValueParameter a'
a

-- |Render a 'Sequence' as instantiated by a value to a list of string segments.
renderSequence :: Sequence s a -> a -> [s]
renderSequence :: Sequence s a -> a -> [s]
renderSequence Sequence s a
p = (PlaceholderValue s -> s) -> [PlaceholderValue s] -> [s]
forall a b. (a -> b) -> [a] -> [b]
map PlaceholderValue s -> s
forall s. PlaceholderValue s -> s
renderPlaceholderValue ([PlaceholderValue s] -> [s])
-> (a -> [PlaceholderValue s]) -> a -> [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sequence s a -> a -> [PlaceholderValue s]
forall s a. Sequence s a -> a -> [PlaceholderValue s]
sequenceValues Sequence s a
p

-- |Attempt to parse sequence segments into a value and remaining (unparsed) segments, ala 'reads'.
readsSequence :: forall m s a . (MonadPlus m, Eq s) => Sequence s a -> [s] -> m (a, [s])
readsSequence :: Sequence s a -> [s] -> m (a, [s])
readsSequence = (forall a'. Placeholder s a' -> s -> m a')
-> Free (Placeholder s) a -> [s] -> m (a, [s])
forall (m :: * -> *) (f :: * -> *) b a.
MonadPlus m =>
(forall a'. f a' -> b -> m a') -> Free f a -> [b] -> m (a, [b])
parseFree forall a'. Placeholder s a' -> s -> m a'
f (Free (Placeholder s) a -> [s] -> m (a, [s]))
-> (Sequence s a -> Free (Placeholder s) a)
-> Sequence s a
-> [s]
-> m (a, [s])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sequence s a -> Free (Placeholder s) a
forall s a. Sequence s a -> Free (Placeholder s) a
freeSequence where
  f :: Placeholder s a' -> s -> m a'
  f :: Placeholder s a' -> s -> m a'
f (PlaceholderFixed s
t) s
a = Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (s
a s -> s -> Bool
forall a. Eq a => a -> a -> Bool
== s
t)
  f Placeholder s a'
PlaceholderParameter s
a = m a' -> (a' -> m a') -> Maybe a' -> m a'
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a'
forall (m :: * -> *) a. MonadPlus m => m a
mzero a' -> m a'
forall (m :: * -> *) a. Monad m => a -> m a
return (s -> Maybe a'
forall s a. Parameter s a => s -> Maybe a
parseParameter s
a)

-- |Parse a sequence into possible values.  Can return all possible values as a list or (usually) a single value as 'Maybe'.
parseSequence :: (MonadPlus m, MonadFail m, Eq s) => Sequence s a -> [s] -> m a
parseSequence :: Sequence s a -> [s] -> m a
parseSequence Sequence s a
p [s]
l = do
  (a
a, []) <- Sequence s a -> [s] -> m (a, [s])
forall (m :: * -> *) s a.
(MonadPlus m, Eq s) =>
Sequence s a -> [s] -> m (a, [s])
readsSequence Sequence s a
p [s]
l
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- |Reverse the order of a sequence, such that @reverseSequence p@ parses/produces @reverse l@ iff @p@ parses/produces @l@.
-- Since sequences are matched left-to-right, this lets you match them right-to-left.
-- It probably goes without saying, but this won't work for infinite sequences, such as those produced by 'while'.
reverseSequence :: Sequence s a -> Sequence s a
reverseSequence :: Sequence s a -> Sequence s a
reverseSequence = Free (Placeholder s) a -> Sequence s a
forall s a. Free (Placeholder s) a -> Sequence s a
Sequence (Free (Placeholder s) a -> Sequence s a)
-> (Sequence s a -> Free (Placeholder s) a)
-> Sequence s a
-> Sequence s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Free (Placeholder s) a -> Free (Placeholder s) a
forall (f :: * -> *) a. Free f a -> Free f a
reverseFree (Free (Placeholder s) a -> Free (Placeholder s) a)
-> (Sequence s a -> Free (Placeholder s) a)
-> Sequence s a
-> Free (Placeholder s) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sequence s a -> Free (Placeholder s) a
forall s a. Sequence s a -> Free (Placeholder s) a
freeSequence