{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Web.Routing.Combinators where

import Data.HVect
import Data.Maybe (fromMaybe)
import Data.String
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Typeable (Typeable)
import Network.HTTP.Types.URI (urlEncode)
import Web.HttpApiData
import Web.Routing.SafeRouting

data PathState = Open | Closed

data Path (as :: [*]) (pathState :: PathState) where
  Empty :: Path '[] 'Open
  StaticCons :: T.Text -> Path as ps -> Path as ps
  VarCons :: (FromHttpApiData a, Typeable a) => Path as ps -> Path (a ': as) ps
  Wildcard :: Path as 'Open -> Path (T.Text ': as) 'Closed
  WithExtension :: Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
  AppendPath :: Path as 'Open -> Path bs ps -> Path (Append as bs) ps

toInternalPath :: Path as pathState -> PathInternal as
toInternalPath :: forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path as pathState
Empty = PathInternal as
PathInternal '[]
PI_Empty
toInternalPath (StaticCons Text
t Path as pathState
p) = Text -> PathInternal as -> PathInternal as
forall (as :: [*]). Text -> PathInternal as -> PathInternal as
PI_StaticCons Text
t (Path as pathState -> PathInternal as
forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path as pathState
p)
toInternalPath (VarCons Path as pathState
p) = PathInternal as -> PathInternal (a : as)
forall a (as1 :: [*]).
(FromHttpApiData a, Typeable a) =>
PathInternal as1 -> PathInternal (a : as1)
PI_VarCons (Path as pathState -> PathInternal as
forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path as pathState
p)
toInternalPath (Wildcard Path as 'Open
p) = PathInternal as -> PathInternal (Text : as)
forall (as1 :: [*]). PathInternal as1 -> PathInternal (Text : as1)
PI_Wildcard (Path as 'Open -> PathInternal as
forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path as 'Open
p)
toInternalPath (WithExtension Path as 'Open
left Path bs 'Open
right) = PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
forall (as1 :: [*]) (bs :: [*]).
PathInternal as1 -> PathInternal bs -> PathInternal (Append as1 bs)
PI_Extension (Path as 'Open -> PathInternal as
forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path as 'Open
left) (Path bs 'Open -> PathInternal bs
forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path bs 'Open
right)
toInternalPath (AppendPath Path as 'Open
left Path bs pathState
right) = PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
forall (as1 :: [*]) (bs :: [*]).
PathInternal as1 -> PathInternal bs -> PathInternal (Append as1 bs)
PI_Append (Path as 'Open -> PathInternal as
forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path as 'Open
left) (Path bs pathState -> PathInternal bs
forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path bs pathState
right)

type Var a = Path (a ': '[]) 'Open

-- | A variant of 'Either' with a 'FromHttpApiData' definition that tries both branches without a prefix.
-- Useful to define routes with 'var's that should work with different types.
data AltVar a b = AvLeft a | AvRight b
  deriving (Int -> AltVar a b -> ShowS
[AltVar a b] -> ShowS
AltVar a b -> String
(Int -> AltVar a b -> ShowS)
-> (AltVar a b -> String)
-> ([AltVar a b] -> ShowS)
-> Show (AltVar a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> AltVar a b -> ShowS
forall a b. (Show a, Show b) => [AltVar a b] -> ShowS
forall a b. (Show a, Show b) => AltVar a b -> String
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> AltVar a b -> ShowS
showsPrec :: Int -> AltVar a b -> ShowS
$cshow :: forall a b. (Show a, Show b) => AltVar a b -> String
show :: AltVar a b -> String
$cshowList :: forall a b. (Show a, Show b) => [AltVar a b] -> ShowS
showList :: [AltVar a b] -> ShowS
Show, AltVar a b -> AltVar a b -> Bool
(AltVar a b -> AltVar a b -> Bool)
-> (AltVar a b -> AltVar a b -> Bool) -> Eq (AltVar a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => AltVar a b -> AltVar a b -> Bool
$c== :: forall a b. (Eq a, Eq b) => AltVar a b -> AltVar a b -> Bool
== :: AltVar a b -> AltVar a b -> Bool
$c/= :: forall a b. (Eq a, Eq b) => AltVar a b -> AltVar a b -> Bool
/= :: AltVar a b -> AltVar a b -> Bool
Eq, ReadPrec [AltVar a b]
ReadPrec (AltVar a b)
Int -> ReadS (AltVar a b)
ReadS [AltVar a b]
(Int -> ReadS (AltVar a b))
-> ReadS [AltVar a b]
-> ReadPrec (AltVar a b)
-> ReadPrec [AltVar a b]
-> Read (AltVar a b)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a b. (Read a, Read b) => ReadPrec [AltVar a b]
forall a b. (Read a, Read b) => ReadPrec (AltVar a b)
forall a b. (Read a, Read b) => Int -> ReadS (AltVar a b)
forall a b. (Read a, Read b) => ReadS [AltVar a b]
$creadsPrec :: forall a b. (Read a, Read b) => Int -> ReadS (AltVar a b)
readsPrec :: Int -> ReadS (AltVar a b)
$creadList :: forall a b. (Read a, Read b) => ReadS [AltVar a b]
readList :: ReadS [AltVar a b]
$creadPrec :: forall a b. (Read a, Read b) => ReadPrec (AltVar a b)
readPrec :: ReadPrec (AltVar a b)
$creadListPrec :: forall a b. (Read a, Read b) => ReadPrec [AltVar a b]
readListPrec :: ReadPrec [AltVar a b]
Read, Eq (AltVar a b)
Eq (AltVar a b) =>
(AltVar a b -> AltVar a b -> Ordering)
-> (AltVar a b -> AltVar a b -> Bool)
-> (AltVar a b -> AltVar a b -> Bool)
-> (AltVar a b -> AltVar a b -> Bool)
-> (AltVar a b -> AltVar a b -> Bool)
-> (AltVar a b -> AltVar a b -> AltVar a b)
-> (AltVar a b -> AltVar a b -> AltVar a b)
-> Ord (AltVar a b)
AltVar a b -> AltVar a b -> Bool
AltVar a b -> AltVar a b -> Ordering
AltVar a b -> AltVar a b -> AltVar a b
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a b. (Ord a, Ord b) => Eq (AltVar a b)
forall a b. (Ord a, Ord b) => AltVar a b -> AltVar a b -> Bool
forall a b. (Ord a, Ord b) => AltVar a b -> AltVar a b -> Ordering
forall a b.
(Ord a, Ord b) =>
AltVar a b -> AltVar a b -> AltVar a b
$ccompare :: forall a b. (Ord a, Ord b) => AltVar a b -> AltVar a b -> Ordering
compare :: AltVar a b -> AltVar a b -> Ordering
$c< :: forall a b. (Ord a, Ord b) => AltVar a b -> AltVar a b -> Bool
< :: AltVar a b -> AltVar a b -> Bool
$c<= :: forall a b. (Ord a, Ord b) => AltVar a b -> AltVar a b -> Bool
<= :: AltVar a b -> AltVar a b -> Bool
$c> :: forall a b. (Ord a, Ord b) => AltVar a b -> AltVar a b -> Bool
> :: AltVar a b -> AltVar a b -> Bool
$c>= :: forall a b. (Ord a, Ord b) => AltVar a b -> AltVar a b -> Bool
>= :: AltVar a b -> AltVar a b -> Bool
$cmax :: forall a b.
(Ord a, Ord b) =>
AltVar a b -> AltVar a b -> AltVar a b
max :: AltVar a b -> AltVar a b -> AltVar a b
$cmin :: forall a b.
(Ord a, Ord b) =>
AltVar a b -> AltVar a b -> AltVar a b
min :: AltVar a b -> AltVar a b -> AltVar a b
Ord)

instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (AltVar a b) where
  parseUrlPiece :: Text -> Either Text (AltVar a b)
parseUrlPiece Text
val =
    case Text -> Either Text a
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
val of
      Left Text
err ->
        case Text -> Either Text b
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
val of
          Left Text
err2 -> Text -> Either Text (AltVar a b)
forall a b. a -> Either a b
Left (Text
err Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err2)
          Right b
ok -> AltVar a b -> Either Text (AltVar a b)
forall a b. b -> Either a b
Right (b -> AltVar a b
forall a b. b -> AltVar a b
AvRight b
ok)
      Right a
ok -> AltVar a b -> Either Text (AltVar a b)
forall a b. b -> Either a b
Right (a -> AltVar a b
forall a b. a -> AltVar a b
AvLeft a
ok)

-- | A route parameter
var :: (Typeable a, FromHttpApiData a) => Path (a ': '[]) 'Open
var :: forall a. (Typeable a, FromHttpApiData a) => Path '[a] 'Open
var = Path '[] 'Open -> Path '[a] 'Open
forall as (bs :: [*]) (ps :: PathState).
(FromHttpApiData as, Typeable as) =>
Path bs ps -> Path (as : bs) ps
VarCons Path '[] 'Open
Empty

-- | A static route piece. One leading slash is optional. Empty internal and
-- trailing pieces are retained for strict routing; compatibility routing and
-- 'renderRoute' ignore them. Use 'renderRouteWith' with the application's policy.
static :: String -> Path '[] 'Open
static :: String -> Path '[] 'Open
static String
s =
  let relative :: Text
relative = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (String -> Text
T.pack String
s) (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
"/" (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
      pieces :: [Text]
pieces = if Text -> Bool
T.null Text
relative then [] else HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" Text
relative
   in (Text -> Path '[] 'Open -> Path '[] 'Open)
-> Path '[] 'Open -> [Text] -> Path '[] 'Open
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> Path '[] 'Open -> Path '[] 'Open
forall (as :: [*]) (ps :: PathState).
Text -> Path as ps -> Path as ps
StaticCons Path '[] 'Open
Empty [Text]
pieces

instance (a ~ '[], pathState ~ 'Open) => IsString (Path a pathState) where
  fromString :: String -> Path a pathState
fromString = String -> Path a pathState
String -> Path '[] 'Open
static

-- | The root of a path piece. Use to define a handler for "/"
root :: Path '[] 'Open
root :: Path '[] 'Open
root = Path '[] 'Open
Empty

-- | Require a trailing slash in strict routing, including after a capture.
-- Root remains root, and a path already ending in a slash is unchanged.
trailingSlash :: Path as 'Open -> Path as 'Open
trailingSlash :: forall (as :: [*]). Path as 'Open -> Path as 'Open
trailingSlash Path as 'Open
Empty = Path as 'Open
Path '[] 'Open
Empty
trailingSlash Path as 'Open
path = Path as 'Open -> Path as 'Open
forall (as :: [*]). Path as 'Open -> Path as 'Open
appendSlash Path as 'Open
path
  where
    appendSlash :: Path xs 'Open -> Path xs 'Open
    appendSlash :: forall (as :: [*]). Path as 'Open -> Path as 'Open
appendSlash Path xs 'Open
Empty = Text -> Path xs 'Open -> Path xs 'Open
forall (as :: [*]) (ps :: PathState).
Text -> Path as ps -> Path as ps
StaticCons Text
"" Path xs 'Open
Path '[] 'Open
Empty
    appendSlash (StaticCons Text
"" Path xs 'Open
Empty) = Text -> Path xs 'Open -> Path xs 'Open
forall (as :: [*]) (ps :: PathState).
Text -> Path as ps -> Path as ps
StaticCons Text
"" Path xs 'Open
Path '[] 'Open
Empty
    appendSlash (StaticCons Text
piece Path xs 'Open
rest) = Text -> Path xs 'Open -> Path xs 'Open
forall (as :: [*]) (ps :: PathState).
Text -> Path as ps -> Path as ps
StaticCons Text
piece (Path xs 'Open -> Path xs 'Open
forall (as :: [*]). Path as 'Open -> Path as 'Open
appendSlash Path xs 'Open
rest)
    appendSlash (VarCons Path as 'Open
rest) = Path as 'Open -> Path (a : as) 'Open
forall as (bs :: [*]) (ps :: PathState).
(FromHttpApiData as, Typeable as) =>
Path bs ps -> Path (as : bs) ps
VarCons (Path as 'Open -> Path as 'Open
forall (as :: [*]). Path as 'Open -> Path as 'Open
appendSlash Path as 'Open
rest)
    appendSlash (WithExtension Path as 'Open
left Path bs 'Open
Empty) = Path as 'Open -> Path '[] 'Open -> Path (Append as '[]) 'Open
forall (as :: [*]) (bs :: [*]).
Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
WithExtension Path as 'Open
left (Text -> Path '[] 'Open -> Path '[] 'Open
forall (as :: [*]) (ps :: PathState).
Text -> Path as ps -> Path as ps
StaticCons Text
"" (Path '[] 'Open -> Path '[] 'Open)
-> Path '[] 'Open -> Path '[] 'Open
forall a b. (a -> b) -> a -> b
$ Text -> Path '[] 'Open -> Path '[] 'Open
forall (as :: [*]) (ps :: PathState).
Text -> Path as ps -> Path as ps
StaticCons Text
"" Path '[] 'Open
Empty)
    appendSlash (WithExtension Path as 'Open
left Path bs 'Open
right) = Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
forall (as :: [*]) (bs :: [*]).
Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
WithExtension Path as 'Open
left (Path bs 'Open -> Path bs 'Open
forall (as :: [*]). Path as 'Open -> Path as 'Open
appendSlash Path bs 'Open
right)
    appendSlash (AppendPath Path as 'Open
left Path bs 'Open
right) = Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
forall (as :: [*]) (bs :: [*]) (ps :: PathState).
Path as 'Open -> Path bs ps -> Path (Append as bs) ps
AppendPath Path as 'Open
left (Path bs 'Open -> Path bs 'Open
forall (as :: [*]). Path as 'Open -> Path as 'Open
appendSlash Path bs 'Open
right)

-- | Matches the rest of the route. Should be the last part of the path.
wildcard :: Path '[T.Text] 'Closed
wildcard :: Path '[Text] 'Closed
wildcard = Path '[] 'Open -> Path '[Text] 'Closed
forall (as :: [*]). Path as 'Open -> Path (Text : as) 'Closed
Wildcard Path '[] 'Open
Empty

(</>) :: Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
</> :: forall (as :: [*]) (bs :: [*]) (ps :: PathState).
Path as 'Open -> Path bs ps -> Path (Append as bs) ps
(</>) Path as 'Open
Empty Path bs ps2
xs = Path bs ps2
Path (Append as bs) ps2
xs
(</>) (StaticCons Text
pathPiece Path as 'Open
xs) Path bs ps2
ys = Text -> Path (Append as bs) ps2 -> Path (Append as bs) ps2
forall (as :: [*]) (ps :: PathState).
Text -> Path as ps -> Path as ps
StaticCons Text
pathPiece (Path as 'Open
xs Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
forall (as :: [*]) (bs :: [*]) (ps :: PathState).
Path as 'Open -> Path bs ps -> Path (Append as bs) ps
</> Path bs ps2
ys)
(</>) (VarCons Path as 'Open
xs) Path bs ps2
ys = Path (Append as bs) ps2 -> Path (a : Append as bs) ps2
forall as (bs :: [*]) (ps :: PathState).
(FromHttpApiData as, Typeable as) =>
Path bs ps -> Path (as : bs) ps
VarCons (Path as 'Open
xs Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
forall (as :: [*]) (bs :: [*]) (ps :: PathState).
Path as 'Open -> Path bs ps -> Path (Append as bs) ps
</> Path bs ps2
ys)
(</>) path :: Path as 'Open
path@(WithExtension Path as 'Open
_ Path bs 'Open
_) Path bs ps2
ys = Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
forall (as :: [*]) (bs :: [*]) (ps :: PathState).
Path as 'Open -> Path bs ps -> Path (Append as bs) ps
AppendPath Path as 'Open
path Path bs ps2
ys
(</>) path :: Path as 'Open
path@(AppendPath Path as 'Open
_ Path bs 'Open
_) Path bs ps2
ys = Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
forall (as :: [*]) (bs :: [*]) (ps :: PathState).
Path as 'Open -> Path bs ps -> Path (Append as bs) ps
AppendPath Path as 'Open
path Path bs ps2
ys

-- | Join the last segment on the left and the first on the right with a dot.
-- Both sides may contain typed captures: @var <.> "txt"@ or @var <.> var@.
-- Matching tries the rightmost dot first and accepts the first split whose
-- typed parsers and literals succeed. Use a custom capture type to restrict
-- extensions; a Text capture accepts any text, including an empty extension.
-- Static routes take precedence over extensions, then plain captures and
-- wildcards. More literal characters give an extension pattern priority.
(<.>) :: Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
<.> :: forall (as :: [*]) (bs :: [*]).
Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
(<.>) (StaticCons Text
base Path as 'Open
Empty) (StaticCons Text
extension Path bs 'Open
rest) = Text -> Path bs 'Open -> Path bs 'Open
forall (as :: [*]) (ps :: PathState).
Text -> Path as ps -> Path as ps
StaticCons (Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
extension) Path bs 'Open
rest
(<.>) path :: Path as 'Open
path@(StaticCons Text
piece Path as 'Open
rest) Path bs 'Open
right = case Path as 'Open
rest of
  Path as 'Open
Empty -> Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
forall (as :: [*]) (bs :: [*]).
Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
WithExtension Path as 'Open
path Path bs 'Open
right
  Path as 'Open
_ -> Text -> Path (Append as bs) 'Open -> Path (Append as bs) 'Open
forall (as :: [*]) (ps :: PathState).
Text -> Path as ps -> Path as ps
StaticCons Text
piece (Path as 'Open
rest Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
forall (as :: [*]) (bs :: [*]).
Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
<.> Path bs 'Open
right)
(<.>) path :: Path as 'Open
path@(VarCons Path as 'Open
rest) Path bs 'Open
right = case Path as 'Open
rest of
  Path as 'Open
Empty -> Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
forall (as :: [*]) (bs :: [*]).
Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
WithExtension Path as 'Open
path Path bs 'Open
right
  Path as 'Open
_ -> Path (Append as bs) 'Open -> Path (a : Append as bs) 'Open
forall as (bs :: [*]) (ps :: PathState).
(FromHttpApiData as, Typeable as) =>
Path bs ps -> Path (as : bs) ps
VarCons (Path as 'Open
rest Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
forall (as :: [*]) (bs :: [*]).
Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
<.> Path bs 'Open
right)
(<.>) Path as 'Open
left Path bs 'Open
right = Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
forall (as :: [*]) (bs :: [*]).
Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
WithExtension Path as 'Open
left Path bs 'Open
right
infixl 8 <.>

pathToRep :: Path as ps -> Rep as
pathToRep :: forall (as :: [*]) (ps :: PathState). Path as ps -> Rep as
pathToRep Path as ps
Empty = Rep as
Rep '[]
RNil
pathToRep (StaticCons Text
_ Path as ps
p) = Path as ps -> Rep as
forall (as :: [*]) (ps :: PathState). Path as ps -> Rep as
pathToRep Path as ps
p
pathToRep (VarCons Path as ps
p) = Rep as -> Rep (a : as)
forall (ts1 :: [*]) t. Rep ts1 -> Rep (t : ts1)
RCons (Path as ps -> Rep as
forall (as :: [*]) (ps :: PathState). Path as ps -> Rep as
pathToRep Path as ps
p)
pathToRep (Wildcard Path as 'Open
p) = Rep as -> Rep (Text : as)
forall (ts1 :: [*]) t. Rep ts1 -> Rep (t : ts1)
RCons (Path as 'Open -> Rep as
forall (as :: [*]) (ps :: PathState). Path as ps -> Rep as
pathToRep Path as 'Open
p)
pathToRep (WithExtension Path as 'Open
left Path bs 'Open
right) = Rep as -> Rep bs -> Rep (Append as bs)
forall (as :: [*]) (bs :: [*]).
Rep as -> Rep bs -> Rep (Append as bs)
appendRep (Path as 'Open -> Rep as
forall (as :: [*]) (ps :: PathState). Path as ps -> Rep as
pathToRep Path as 'Open
left) (Path bs 'Open -> Rep bs
forall (as :: [*]) (ps :: PathState). Path as ps -> Rep as
pathToRep Path bs 'Open
right)
pathToRep (AppendPath Path as 'Open
left Path bs ps
right) = Rep as -> Rep bs -> Rep (Append as bs)
forall (as :: [*]) (bs :: [*]).
Rep as -> Rep bs -> Rep (Append as bs)
appendRep (Path as 'Open -> Rep as
forall (as :: [*]) (ps :: PathState). Path as ps -> Rep as
pathToRep Path as 'Open
left) (Path bs ps -> Rep bs
forall (as :: [*]) (ps :: PathState). Path as ps -> Rep as
pathToRep Path bs ps
right)

appendRep :: Rep as -> Rep bs -> Rep (Append as bs)
appendRep :: forall (as :: [*]) (bs :: [*]).
Rep as -> Rep bs -> Rep (Append as bs)
appendRep Rep as
RNil Rep bs
right = Rep bs
Rep (Append as bs)
right
appendRep (RCons Rep ts1
left) Rep bs
right = Rep (Append ts1 bs) -> Rep (t : Append ts1 bs)
forall (ts1 :: [*]) t. Rep ts1 -> Rep (t : ts1)
RCons (Rep ts1 -> Rep bs -> Rep (Append ts1 bs)
forall (as :: [*]) (bs :: [*]).
Rep as -> Rep bs -> Rep (Append as bs)
appendRep Rep ts1
left Rep bs
right)

renderRoute :: AllHave ToHttpApiData as => Path as 'Open -> HVect as -> T.Text
renderRoute :: forall (as :: [*]).
AllHave ToHttpApiData as =>
Path as 'Open -> HVect as -> Text
renderRoute = SlashPolicy -> Path as 'Open -> HVect as -> Text
forall (as :: [*]).
AllHave ToHttpApiData as =>
SlashPolicy -> Path as 'Open -> HVect as -> Text
renderRouteWith SlashPolicy
IgnoreSlashes

-- | Render with the same empty-segment policy used by the registry. Values are
-- URL pieces, as with 'renderRoute'; this function does not percent-encode them.
renderRouteWith :: AllHave ToHttpApiData as => SlashPolicy -> Path as 'Open -> HVect as -> T.Text
renderRouteWith :: forall (as :: [*]).
AllHave ToHttpApiData as =>
SlashPolicy -> Path as 'Open -> HVect as -> Text
renderRouteWith SlashPolicy
policy Path as 'Open
p = [Text] -> Text
combineRoutePieces ([Text] -> Text) -> (HVect as -> [Text]) -> HVect as -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path as 'Open -> HVect as -> [Text]
forall (as :: [*]).
AllHave ToHttpApiData as =>
Path as 'Open -> HVect as -> [Text]
renderRoute' (SlashPolicy -> Path as 'Open -> Path as 'Open
forall (as :: [*]) (ps :: PathState).
SlashPolicy -> Path as ps -> Path as ps
normalizePath SlashPolicy
policy Path as 'Open
p)

normalizePath :: SlashPolicy -> Path as ps -> Path as ps
normalizePath :: forall (as :: [*]) (ps :: PathState).
SlashPolicy -> Path as ps -> Path as ps
normalizePath SlashPolicy
IgnoreSlashes (StaticCons Text
"" Path as ps
rest) = SlashPolicy -> Path as ps -> Path as ps
forall (as :: [*]) (ps :: PathState).
SlashPolicy -> Path as ps -> Path as ps
normalizePath SlashPolicy
IgnoreSlashes Path as ps
rest
normalizePath SlashPolicy
policy (StaticCons Text
piece Path as ps
rest) = Text -> Path as ps -> Path as ps
forall (as :: [*]) (ps :: PathState).
Text -> Path as ps -> Path as ps
StaticCons Text
piece (SlashPolicy -> Path as ps -> Path as ps
forall (as :: [*]) (ps :: PathState).
SlashPolicy -> Path as ps -> Path as ps
normalizePath SlashPolicy
policy Path as ps
rest)
normalizePath SlashPolicy
policy (VarCons Path as ps
rest) = Path as ps -> Path (a : as) ps
forall as (bs :: [*]) (ps :: PathState).
(FromHttpApiData as, Typeable as) =>
Path bs ps -> Path (as : bs) ps
VarCons (SlashPolicy -> Path as ps -> Path as ps
forall (as :: [*]) (ps :: PathState).
SlashPolicy -> Path as ps -> Path as ps
normalizePath SlashPolicy
policy Path as ps
rest)
normalizePath SlashPolicy
policy (Wildcard Path as 'Open
rest) = Path as 'Open -> Path (Text : as) 'Closed
forall (as :: [*]). Path as 'Open -> Path (Text : as) 'Closed
Wildcard (SlashPolicy -> Path as 'Open -> Path as 'Open
forall (as :: [*]) (ps :: PathState).
SlashPolicy -> Path as ps -> Path as ps
normalizePath SlashPolicy
policy Path as 'Open
rest)
normalizePath SlashPolicy
policy (WithExtension Path as 'Open
left Path bs 'Open
right) = Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
forall (as :: [*]) (bs :: [*]).
Path as 'Open -> Path bs 'Open -> Path (Append as bs) 'Open
WithExtension (SlashPolicy -> Path as 'Open -> Path as 'Open
forall (as :: [*]) (ps :: PathState).
SlashPolicy -> Path as ps -> Path as ps
normalizePath SlashPolicy
policy Path as 'Open
left) (SlashPolicy -> Path bs 'Open -> Path bs 'Open
forall (as :: [*]) (ps :: PathState).
SlashPolicy -> Path as ps -> Path as ps
normalizePath SlashPolicy
policy Path bs 'Open
right)
normalizePath SlashPolicy
policy (AppendPath Path as 'Open
left Path bs ps
right) = Path as 'Open -> Path bs ps -> Path (Append as bs) ps
forall (as :: [*]) (bs :: [*]) (ps :: PathState).
Path as 'Open -> Path bs ps -> Path (Append as bs) ps
AppendPath (SlashPolicy -> Path as 'Open -> Path as 'Open
forall (as :: [*]) (ps :: PathState).
SlashPolicy -> Path as ps -> Path as ps
normalizePath SlashPolicy
policy Path as 'Open
left) (SlashPolicy -> Path bs ps -> Path bs ps
forall (as :: [*]) (ps :: PathState).
SlashPolicy -> Path as ps -> Path as ps
normalizePath SlashPolicy
policy Path bs ps
right)
normalizePath SlashPolicy
_ Path as ps
Empty = Path as ps
Path '[] 'Open
Empty

renderRoute' :: AllHave ToHttpApiData as => Path as 'Open -> HVect as -> [T.Text]
renderRoute' :: forall (as :: [*]).
AllHave ToHttpApiData as =>
Path as 'Open -> HVect as -> [Text]
renderRoute' Path as 'Open
path = ([Text], [Text]) -> [Text]
forall a b. (a, b) -> a
fst (([Text], [Text]) -> [Text])
-> (HVect as -> ([Text], [Text])) -> HVect as -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path as 'Open -> [Text] -> ([Text], [Text])
forall (as :: [*]). Path as 'Open -> [Text] -> ([Text], [Text])
renderPieces Path as 'Open
path ([Text] -> ([Text], [Text]))
-> (HVect as -> [Text]) -> HVect as -> ([Text], [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HVect as -> [Text]
forall (as :: [*]). AllHave ToHttpApiData as => HVect as -> [Text]
captureTexts

captureTexts :: AllHave ToHttpApiData as => HVect as -> [T.Text]
captureTexts :: forall (as :: [*]). AllHave ToHttpApiData as => HVect as -> [Text]
captureTexts HVect as
HNil = []
captureTexts (t
value :&: HVect ts1
rest) = t -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece t
value Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: HVect ts1 -> [Text]
forall (as :: [*]). AllHave ToHttpApiData as => HVect as -> [Text]
captureTexts HVect ts1
rest

renderPieces :: Path as 'Open -> [T.Text] -> ([T.Text], [T.Text])
renderPieces :: forall (as :: [*]). Path as 'Open -> [Text] -> ([Text], [Text])
renderPieces Path as 'Open
Empty [Text]
values = ([], [Text]
values)
renderPieces (StaticCons Text
piece Path as 'Open
rest) [Text]
values = let ([Text]
pieces, [Text]
remaining) = Path as 'Open -> [Text] -> ([Text], [Text])
forall (as :: [*]). Path as 'Open -> [Text] -> ([Text], [Text])
renderPieces Path as 'Open
rest [Text]
values in (Text
piece Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
pieces, [Text]
remaining)
renderPieces (VarCons Path as 'Open
rest) (Text
value : [Text]
values) = let ([Text]
pieces, [Text]
remaining) = Path as 'Open -> [Text] -> ([Text], [Text])
forall (as :: [*]). Path as 'Open -> [Text] -> ([Text], [Text])
renderPieces Path as 'Open
rest [Text]
values in (Text
value Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
pieces, [Text]
remaining)
renderPieces (VarCons Path as 'Open
_) [] = String -> ([Text], [Text])
forall a. HasCallStack => String -> a
error String
"renderPieces: internal capture arity mismatch"
renderPieces (WithExtension Path as 'Open
left Path bs 'Open
right) [Text]
values =
  let ([Text]
leftPieces, [Text]
rest) = Path as 'Open -> [Text] -> ([Text], [Text])
forall (as :: [*]). Path as 'Open -> [Text] -> ([Text], [Text])
renderPieces Path as 'Open
left [Text]
values
      ([Text]
rightPieces, [Text]
remaining) = Path bs 'Open -> [Text] -> ([Text], [Text])
forall (as :: [*]). Path as 'Open -> [Text] -> ([Text], [Text])
renderPieces Path bs 'Open
right [Text]
rest
  in ([Text] -> [Text] -> [Text]
joinWithDot [Text]
leftPieces [Text]
rightPieces, [Text]
remaining)
renderPieces (AppendPath Path as 'Open
left Path bs 'Open
right) [Text]
values =
  let ([Text]
leftPieces, [Text]
rest) = Path as 'Open -> [Text] -> ([Text], [Text])
forall (as :: [*]). Path as 'Open -> [Text] -> ([Text], [Text])
renderPieces Path as 'Open
left [Text]
values
      ([Text]
rightPieces, [Text]
remaining) = Path bs 'Open -> [Text] -> ([Text], [Text])
forall (as :: [*]). Path as 'Open -> [Text] -> ([Text], [Text])
renderPieces Path bs 'Open
right [Text]
rest
  in ([Text]
leftPieces [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
rightPieces, [Text]
remaining)

joinWithDot :: [T.Text] -> [T.Text] -> [T.Text]
joinWithDot :: [Text] -> [Text] -> [Text]
joinWithDot [] [] = [Text
"."]
joinWithDot [] (Text
first : [Text]
rest) = (Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
first) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
rest
joinWithDot [Text
lastPiece] [] = [Text
lastPiece Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."]
joinWithDot [Text
lastPiece] (Text
first : [Text]
rest) = (Text
lastPiece Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
first) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
rest
joinWithDot (Text
piece : [Text]
rest) [Text]
right = Text
piece Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text] -> [Text]
joinWithDot [Text]
rest [Text]
right

-- | Percent-encode each complete segment after joining extension pieces.
-- This protects slashes, spaces, percent signs, query delimiters and Unicode
-- in captures. The unencoded 'renderRoute' remains available for compatibility.
renderRouteEncoded :: AllHave ToHttpApiData as => Path as 'Open -> HVect as -> T.Text
renderRouteEncoded :: forall (as :: [*]).
AllHave ToHttpApiData as =>
Path as 'Open -> HVect as -> Text
renderRouteEncoded = SlashPolicy -> Path as 'Open -> HVect as -> Text
forall (as :: [*]).
AllHave ToHttpApiData as =>
SlashPolicy -> Path as 'Open -> HVect as -> Text
renderRouteEncodedWith SlashPolicy
IgnoreSlashes

renderRouteEncodedWith :: AllHave ToHttpApiData as => SlashPolicy -> Path as 'Open -> HVect as -> T.Text
renderRouteEncodedWith :: forall (as :: [*]).
AllHave ToHttpApiData as =>
SlashPolicy -> Path as 'Open -> HVect as -> Text
renderRouteEncodedWith SlashPolicy
policy Path as 'Open
path = [Text] -> Text
combineRoutePieces ([Text] -> Text) -> (HVect as -> [Text]) -> HVect as -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ByteString -> ByteString
urlEncode Bool
True (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8)
  ([Text] -> [Text]) -> (HVect as -> [Text]) -> HVect as -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path as 'Open -> HVect as -> [Text]
forall (as :: [*]).
AllHave ToHttpApiData as =>
Path as 'Open -> HVect as -> [Text]
renderRoute' (SlashPolicy -> Path as 'Open -> Path as 'Open
forall (as :: [*]) (ps :: PathState).
SlashPolicy -> Path as ps -> Path as ps
normalizePath SlashPolicy
policy Path as 'Open
path)