{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Web.Routing.SafeRouting where

#if MIN_VERSION_base(4,11,0)
#elif MIN_VERSION_base(4,9,0)
import Data.Semigroup
#elif MIN_VERSION_base(4,8,0)
import Data.Monoid ((<>))
#else
import Control.Applicative ((<$>))
import Data.Monoid (Monoid (..), (<>))
#endif
import Control.DeepSeq (NFData (..))
import Data.HVect hiding (length, null, reverse)
import qualified Data.HVect as HV
#if defined(javascript_HOST_ARCH)
-- hashable's Text instance calls CApiFFI symbols absent from the JS runtime.
-- Ordered lookup is portable and preserves the registry's matching order.
import qualified Data.Map.Strict as HM
#else
import qualified Data.HashMap.Strict as HM
#endif
import Data.List (findIndices, sortBy)
import Data.Maybe
import qualified Data.PolyMap as PM
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Web.HttpApiData

-- | How empty path segments are treated. The compatibility default ignores
-- every empty segment. Strict policies preserve internal and trailing slashes.
-- Redirects are performed by the HTTP adapter, using strict registry matching.
data SlashPolicy = IgnoreSlashes | StrictSlashes | RedirectTrailingSlashes
  deriving (SlashPolicy -> SlashPolicy -> Bool
(SlashPolicy -> SlashPolicy -> Bool)
-> (SlashPolicy -> SlashPolicy -> Bool) -> Eq SlashPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SlashPolicy -> SlashPolicy -> Bool
== :: SlashPolicy -> SlashPolicy -> Bool
$c/= :: SlashPolicy -> SlashPolicy -> Bool
/= :: SlashPolicy -> SlashPolicy -> Bool
Eq, Int -> SlashPolicy -> ShowS
[SlashPolicy] -> ShowS
SlashPolicy -> String
(Int -> SlashPolicy -> ShowS)
-> (SlashPolicy -> String)
-> ([SlashPolicy] -> ShowS)
-> Show SlashPolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SlashPolicy -> ShowS
showsPrec :: Int -> SlashPolicy -> ShowS
$cshow :: SlashPolicy -> String
show :: SlashPolicy -> String
$cshowList :: [SlashPolicy] -> ShowS
showList :: [SlashPolicy] -> ShowS
Show, ReadPrec [SlashPolicy]
ReadPrec SlashPolicy
Int -> ReadS SlashPolicy
ReadS [SlashPolicy]
(Int -> ReadS SlashPolicy)
-> ReadS [SlashPolicy]
-> ReadPrec SlashPolicy
-> ReadPrec [SlashPolicy]
-> Read SlashPolicy
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS SlashPolicy
readsPrec :: Int -> ReadS SlashPolicy
$creadList :: ReadS [SlashPolicy]
readList :: ReadS [SlashPolicy]
$creadPrec :: ReadPrec SlashPolicy
readPrec :: ReadPrec SlashPolicy
$creadListPrec :: ReadPrec [SlashPolicy]
readListPrec :: ReadPrec [SlashPolicy]
Read)

normalizeInternalPath :: SlashPolicy -> PathInternal as -> PathInternal as
normalizeInternalPath :: forall (as :: [*]).
SlashPolicy -> PathInternal as -> PathInternal as
normalizeInternalPath SlashPolicy
IgnoreSlashes (PI_StaticCons Text
"" PathInternal as
rest) = SlashPolicy -> PathInternal as -> PathInternal as
forall (as :: [*]).
SlashPolicy -> PathInternal as -> PathInternal as
normalizeInternalPath SlashPolicy
IgnoreSlashes PathInternal as
rest
normalizeInternalPath SlashPolicy
policy (PI_StaticCons Text
piece PathInternal as
rest) = Text -> PathInternal as -> PathInternal as
forall (as :: [*]). Text -> PathInternal as -> PathInternal as
PI_StaticCons Text
piece (SlashPolicy -> PathInternal as -> PathInternal as
forall (as :: [*]).
SlashPolicy -> PathInternal as -> PathInternal as
normalizeInternalPath SlashPolicy
policy PathInternal as
rest)
normalizeInternalPath SlashPolicy
policy (PI_VarCons PathInternal as
rest) = PathInternal as -> PathInternal (a : as)
forall as (bs :: [*]).
(FromHttpApiData as, Typeable as) =>
PathInternal bs -> PathInternal (as : bs)
PI_VarCons (SlashPolicy -> PathInternal as -> PathInternal as
forall (as :: [*]).
SlashPolicy -> PathInternal as -> PathInternal as
normalizeInternalPath SlashPolicy
policy PathInternal as
rest)
normalizeInternalPath SlashPolicy
policy (PI_Wildcard PathInternal as
rest) = PathInternal as -> PathInternal (Text : as)
forall (as :: [*]). PathInternal as -> PathInternal (Text : as)
PI_Wildcard (SlashPolicy -> PathInternal as -> PathInternal as
forall (as :: [*]).
SlashPolicy -> PathInternal as -> PathInternal as
normalizeInternalPath SlashPolicy
policy PathInternal as
rest)
normalizeInternalPath SlashPolicy
policy (PI_Extension PathInternal as
left PathInternal bs
right) = PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
forall (as :: [*]) (bs :: [*]).
PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
PI_Extension (SlashPolicy -> PathInternal as -> PathInternal as
forall (as :: [*]).
SlashPolicy -> PathInternal as -> PathInternal as
normalizeInternalPath SlashPolicy
policy PathInternal as
left) (SlashPolicy -> PathInternal bs -> PathInternal bs
forall (as :: [*]).
SlashPolicy -> PathInternal as -> PathInternal as
normalizeInternalPath SlashPolicy
policy PathInternal bs
right)
normalizeInternalPath SlashPolicy
policy (PI_Append PathInternal as
left PathInternal bs
right) = PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
forall (as :: [*]) (bs :: [*]).
PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
PI_Append (SlashPolicy -> PathInternal as -> PathInternal as
forall (as :: [*]).
SlashPolicy -> PathInternal as -> PathInternal as
normalizeInternalPath SlashPolicy
policy PathInternal as
left) (SlashPolicy -> PathInternal bs -> PathInternal bs
forall (as :: [*]).
SlashPolicy -> PathInternal as -> PathInternal as
normalizeInternalPath SlashPolicy
policy PathInternal bs
right)
normalizeInternalPath SlashPolicy
_ PathInternal as
PI_Empty = PathInternal as
PathInternal '[]
PI_Empty

data RouteHandle m a
  = forall as. RouteHandle (PathInternal as) (HVectElim as (m a))

newtype HVectElim' x ts = HVectElim' {forall x (ts :: [*]). HVectElim' x ts -> HVectElim ts x
flipHVectElim :: HVectElim ts x}

type Registry m a = (PathMap (m a), [[T.Text] -> m a])

emptyRegistry :: Registry m a
emptyRegistry :: forall (m :: * -> *) a. Registry m a
emptyRegistry = (PathMap (m a)
forall x. PathMap x
emptyPathMap, [])

defRoute :: PathInternal xs -> HVectElim' (m a) xs -> Registry m a -> Registry m a
defRoute :: forall (xs :: [*]) (m :: * -> *) a.
PathInternal xs
-> HVectElim' (m a) xs -> Registry m a -> Registry m a
defRoute PathInternal xs
path HVectElim' (m a) xs
action (PathMap (m a)
m, [[Text] -> m a]
call) =
  ( RouteHandle m a -> PathMap (m a) -> PathMap (m a)
forall (m :: * -> *) a.
RouteHandle m a -> PathMap (m a) -> PathMap (m a)
insertPathMap (PathInternal xs -> HVectElim xs (m a) -> RouteHandle m a
forall (m :: * -> *) a (as :: [*]).
PathInternal as -> HVectElim as (m a) -> RouteHandle m a
RouteHandle PathInternal xs
path (HVectElim' (m a) xs -> HVectElim xs (m a)
forall x (ts :: [*]). HVectElim' x ts -> HVectElim ts x
flipHVectElim HVectElim' (m a) xs
action)) PathMap (m a)
m,
    [[Text] -> m a]
call
  )

fallbackRoute :: ([T.Text] -> m a) -> Registry m a -> Registry m a
fallbackRoute :: forall (m :: * -> *) a.
([Text] -> m a) -> Registry m a -> Registry m a
fallbackRoute [Text] -> m a
routeDef (PathMap (m a)
m, [[Text] -> m a]
call) = (PathMap (m a)
m, [[Text] -> m a]
call [[Text] -> m a] -> [[Text] -> m a] -> [[Text] -> m a]
forall a. [a] -> [a] -> [a]
++ [[Text] -> m a
routeDef])

matchRoute :: Registry m a -> [T.Text] -> [m a]
matchRoute :: forall (m :: * -> *) a. Registry m a -> [Text] -> [m a]
matchRoute (PathMap (m a)
m, [[Text] -> m a]
cAll) [Text]
pathPieces =
  let matches :: [m a]
matches = PathMap (m a) -> [Text] -> [m a]
forall x. PathMap x -> [Text] -> [x]
match PathMap (m a)
m [Text]
pathPieces
      matches' :: [m a]
matches' =
        if [m a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [m a]
matches
          then [m a]
matches [m a] -> [m a] -> [m a]
forall a. [a] -> [a] -> [a]
++ ((([Text] -> m a) -> m a) -> [[Text] -> m a] -> [m a]
forall a b. (a -> b) -> [a] -> [b]
map (\[Text] -> m a
f -> [Text] -> m a
f [Text]
pathPieces) [[Text] -> m a]
cAll)
          else [m a]
matches
   in [m a]
matches'

data PathInternal (as :: [*]) where
  PI_Empty :: PathInternal '[] -- the empty path
  PI_StaticCons :: T.Text -> PathInternal as -> PathInternal as -- append a static path piece to path
  PI_VarCons :: (FromHttpApiData a, Typeable a) => PathInternal as -> PathInternal (a ': as) -- append a param to path
  PI_Wildcard :: PathInternal as -> PathInternal (T.Text ': as) -- append the rest of the route
  PI_Extension :: PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
  PI_Append :: PathInternal as -> PathInternal bs -> PathInternal (Append as bs)

data PathMap x = PathMap
  { forall x. PathMap x -> [[Text] -> x]
pm_subComponents :: [[T.Text] -> x],
    forall x. PathMap x -> [x]
pm_here :: [x],
#if defined(javascript_HOST_ARCH)
    pm_staticMap :: HM.Map T.Text (PathMap x),
#else
    forall x. PathMap x -> HashMap Text (PathMap x)
pm_staticMap :: HM.HashMap T.Text (PathMap x),
#endif
    forall x. PathMap x -> PolyMap FromHttpApiData PathMap x
pm_polyMap :: PM.PolyMap FromHttpApiData PathMap x,
    forall x. PathMap x -> [Text -> x]
pm_wildcards :: [T.Text -> x],
    forall x. PathMap x -> [(Int, [Text] -> [x])]
pm_patterns :: [(Int, [T.Text] -> [x])]
  }

instance Functor PathMap where
  fmap :: forall a b. (a -> b) -> PathMap a -> PathMap b
fmap a -> b
f (PathMap [[Text] -> a]
c [a]
h HashMap Text (PathMap a)
s PolyMap FromHttpApiData PathMap a
p [Text -> a]
w [(Int, [Text] -> [a])]
e) =
    [[Text] -> b]
-> [b]
-> HashMap Text (PathMap b)
-> PolyMap FromHttpApiData PathMap b
-> [Text -> b]
-> [(Int, [Text] -> [b])]
-> PathMap b
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
PathMap ((a -> b) -> ([Text] -> a) -> [Text] -> b
forall a b. (a -> b) -> ([Text] -> a) -> [Text] -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (([Text] -> a) -> [Text] -> b) -> [[Text] -> a] -> [[Text] -> b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Text] -> a]
c) (a -> b
f (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
h) ((a -> b) -> PathMap a -> PathMap b
forall a b. (a -> b) -> PathMap a -> PathMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (PathMap a -> PathMap b)
-> HashMap Text (PathMap a) -> HashMap Text (PathMap b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Text (PathMap a)
s) (a -> b
f (a -> b)
-> PolyMap FromHttpApiData PathMap a
-> PolyMap FromHttpApiData PathMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PolyMap FromHttpApiData PathMap a
p) ((a -> b) -> (Text -> a) -> Text -> b
forall a b. (a -> b) -> (Text -> a) -> Text -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ((Text -> a) -> Text -> b) -> [Text -> a] -> [Text -> b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text -> a]
w)
      [(Int
priority, (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ([a] -> [b]) -> ([Text] -> [a]) -> [Text] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [a]
matcher) | (Int
priority, [Text] -> [a]
matcher) <- [(Int, [Text] -> [a])]
e]

instance NFData x => NFData (PathMap x) where
  rnf :: PathMap x -> ()
rnf (PathMap [[Text] -> x]
c [x]
h HashMap Text (PathMap x)
s PolyMap FromHttpApiData PathMap x
p [Text -> x]
w [(Int, [Text] -> [x])]
e) =
    [[Text] -> x] -> ()
forall a. NFData a => a -> ()
rnf [[Text] -> x]
c () -> () -> ()
forall a b. a -> b -> b
`seq` [x] -> ()
forall a. NFData a => a -> ()
rnf [x]
h () -> () -> ()
forall a b. a -> b -> b
`seq` HashMap Text (PathMap x) -> ()
forall a. NFData a => a -> ()
rnf HashMap Text (PathMap x)
s () -> () -> ()
forall a b. a -> b -> b
`seq` (forall p. FromHttpApiData p => PathMap (p -> x) -> ())
-> PolyMap FromHttpApiData PathMap x -> ()
forall (c :: * -> Constraint) (f :: * -> *) a.
(forall p. c p => f (p -> a) -> ()) -> PolyMap c f a -> ()
PM.rnfHelper PathMap (p -> x) -> ()
forall a. NFData a => a -> ()
forall p. FromHttpApiData p => PathMap (p -> x) -> ()
rnf PolyMap FromHttpApiData PathMap x
p () -> () -> ()
forall a b. a -> b -> b
`seq` [Text -> x] -> ()
forall a. NFData a => a -> ()
rnf [Text -> x]
w () -> () -> ()
forall a b. a -> b -> b
`seq` [(Int, [Text] -> [x])] -> ()
forall a. NFData a => a -> ()
rnf [(Int, [Text] -> [x])]
e

emptyPathMap :: PathMap x
emptyPathMap :: forall x. PathMap x
emptyPathMap = [[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
PathMap [[Text] -> x]
forall a. Monoid a => a
mempty [x]
forall a. Monoid a => a
mempty HashMap Text (PathMap x)
forall a. Monoid a => a
mempty PolyMap FromHttpApiData PathMap x
forall (c :: * -> Constraint) (f :: * -> *) a. PolyMap c f a
PM.empty [Text -> x]
forall a. Monoid a => a
mempty [(Int, [Text] -> [x])]
forall a. Monoid a => a
mempty

instance Semigroup (PathMap x) where
  (PathMap [[Text] -> x]
c1 [x]
h1 HashMap Text (PathMap x)
s1 PolyMap FromHttpApiData PathMap x
p1 [Text -> x]
w1 [(Int, [Text] -> [x])]
e1) <> :: PathMap x -> PathMap x -> PathMap x
<> (PathMap [[Text] -> x]
c2 [x]
h2 HashMap Text (PathMap x)
s2 PolyMap FromHttpApiData PathMap x
p2 [Text -> x]
w2 [(Int, [Text] -> [x])]
e2) =
    [[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
PathMap ([[Text] -> x]
c1 [[Text] -> x] -> [[Text] -> x] -> [[Text] -> x]
forall a. Semigroup a => a -> a -> a
<> [[Text] -> x]
c2) ([x]
h1 [x] -> [x] -> [x]
forall a. Semigroup a => a -> a -> a
<> [x]
h2) ((PathMap x -> PathMap x -> PathMap x)
-> HashMap Text (PathMap x)
-> HashMap Text (PathMap x)
-> HashMap Text (PathMap x)
forall k v.
Eq k =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HM.unionWith PathMap x -> PathMap x -> PathMap x
forall a. Semigroup a => a -> a -> a
(<>) HashMap Text (PathMap x)
s1 HashMap Text (PathMap x)
s2) ((forall p.
 FromHttpApiData p =>
 PathMap (p -> x) -> PathMap (p -> x) -> PathMap (p -> x))
-> PolyMap FromHttpApiData PathMap x
-> PolyMap FromHttpApiData PathMap x
-> PolyMap FromHttpApiData PathMap x
forall (c :: * -> Constraint) (f :: * -> *) a.
(forall p. c p => f (p -> a) -> f (p -> a) -> f (p -> a))
-> PolyMap c f a -> PolyMap c f a -> PolyMap c f a
PM.unionWith PathMap (p -> x) -> PathMap (p -> x) -> PathMap (p -> x)
forall a. Semigroup a => a -> a -> a
forall p.
FromHttpApiData p =>
PathMap (p -> x) -> PathMap (p -> x) -> PathMap (p -> x)
(<>) PolyMap FromHttpApiData PathMap x
p1 PolyMap FromHttpApiData PathMap x
p2) ([Text -> x]
w1 [Text -> x] -> [Text -> x] -> [Text -> x]
forall a. Semigroup a => a -> a -> a
<> [Text -> x]
w2)
      ([(Int, [Text] -> [x])] -> [(Int, [Text] -> [x])]
forall a. [(Int, a)] -> [(Int, a)]
orderPatterns ([(Int, [Text] -> [x])] -> [(Int, [Text] -> [x])])
-> [(Int, [Text] -> [x])] -> [(Int, [Text] -> [x])]
forall a b. (a -> b) -> a -> b
$ [(Int, [Text] -> [x])]
e1 [(Int, [Text] -> [x])]
-> [(Int, [Text] -> [x])] -> [(Int, [Text] -> [x])]
forall a. Semigroup a => a -> a -> a
<> [(Int, [Text] -> [x])]
e2)

orderPatterns :: [(Int, a)] -> [(Int, a)]
orderPatterns :: forall a. [(Int, a)] -> [(Int, a)]
orderPatterns = ((Int, a) -> (Int, a) -> Ordering) -> [(Int, a)] -> [(Int, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Int
a, a
_) (Int
b, a
_) -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
b Int
a)

instance Monoid (PathMap x) where
  mempty :: PathMap x
mempty = PathMap x
forall x. PathMap x
emptyPathMap
  mappend :: PathMap x -> PathMap x -> PathMap x
mappend = PathMap x -> PathMap x -> PathMap x
forall a. Semigroup a => a -> a -> a
(<>)

updatePathMap ::
  (forall y. (ctx -> y) -> PathMap y -> PathMap y) ->
  PathInternal ts ->
  (HVect ts -> ctx -> x) ->
  PathMap x ->
  PathMap x
updatePathMap :: forall ctx (ts :: [*]) x.
(forall y. (ctx -> y) -> PathMap y -> PathMap y)
-> PathInternal ts
-> (HVect ts -> ctx -> x)
-> PathMap x
-> PathMap x
updatePathMap forall y. (ctx -> y) -> PathMap y -> PathMap y
updateFn PathInternal ts
path HVect ts -> ctx -> x
action pm :: PathMap x
pm@(PathMap [[Text] -> x]
c [x]
h HashMap Text (PathMap x)
s PolyMap FromHttpApiData PathMap x
p [Text -> x]
w [(Int, [Text] -> [x])]
e) =
  case PathInternal ts
path of
    PathInternal ts
PI_Empty -> (ctx -> x) -> PathMap x -> PathMap x
forall y. (ctx -> y) -> PathMap y -> PathMap y
updateFn (HVect ts -> ctx -> x
action HVect ts
HVect '[]
HNil) PathMap x
pm
    PI_StaticCons Text
pathPiece PathInternal ts
path' ->
      let subPathMap :: PathMap x
subPathMap = PathMap x -> Maybe (PathMap x) -> PathMap x
forall a. a -> Maybe a -> a
fromMaybe PathMap x
forall x. PathMap x
emptyPathMap (Text -> HashMap Text (PathMap x) -> Maybe (PathMap x)
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HM.lookup Text
pathPiece HashMap Text (PathMap x)
s)
       in [[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
PathMap [[Text] -> x]
c [x]
h (Text
-> PathMap x
-> HashMap Text (PathMap x)
-> HashMap Text (PathMap x)
forall k v. Hashable k => k -> v -> HashMap k v -> HashMap k v
HM.insert Text
pathPiece ((forall y. (ctx -> y) -> PathMap y -> PathMap y)
-> PathInternal ts
-> (HVect ts -> ctx -> x)
-> PathMap x
-> PathMap x
forall ctx (ts :: [*]) x.
(forall y. (ctx -> y) -> PathMap y -> PathMap y)
-> PathInternal ts
-> (HVect ts -> ctx -> x)
-> PathMap x
-> PathMap x
updatePathMap (ctx -> y) -> PathMap y -> PathMap y
forall y. (ctx -> y) -> PathMap y -> PathMap y
updateFn PathInternal ts
path' HVect ts -> ctx -> x
action PathMap x
subPathMap) HashMap Text (PathMap x)
s) PolyMap FromHttpApiData PathMap x
p [Text -> x]
w [(Int, [Text] -> [x])]
e
    PI_VarCons PathInternal as
path' ->
      let alterFn :: Maybe (PathMap (a -> x)) -> Maybe (PathMap (a -> x))
alterFn =
            PathMap (a -> x) -> Maybe (PathMap (a -> x))
forall a. a -> Maybe a
Just (PathMap (a -> x) -> Maybe (PathMap (a -> x)))
-> (Maybe (PathMap (a -> x)) -> PathMap (a -> x))
-> Maybe (PathMap (a -> x))
-> Maybe (PathMap (a -> x))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall y. (ctx -> y) -> PathMap y -> PathMap y)
-> PathInternal as
-> (HVect as -> ctx -> a -> x)
-> PathMap (a -> x)
-> PathMap (a -> x)
forall ctx (ts :: [*]) x.
(forall y. (ctx -> y) -> PathMap y -> PathMap y)
-> PathInternal ts
-> (HVect ts -> ctx -> x)
-> PathMap x
-> PathMap x
updatePathMap (ctx -> y) -> PathMap y -> PathMap y
forall y. (ctx -> y) -> PathMap y -> PathMap y
updateFn PathInternal as
path' (\HVect as
vs ctx
ctx a
v -> HVect ts -> ctx -> x
action (a
v a -> HVect as -> HVect (a : as)
forall t (ts1 :: [*]). t -> HVect ts1 -> HVect (t : ts1)
:&: HVect as
vs) ctx
ctx)
              (PathMap (a -> x) -> PathMap (a -> x))
-> (Maybe (PathMap (a -> x)) -> PathMap (a -> x))
-> Maybe (PathMap (a -> x))
-> PathMap (a -> x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathMap (a -> x) -> Maybe (PathMap (a -> x)) -> PathMap (a -> x)
forall a. a -> Maybe a -> a
fromMaybe PathMap (a -> x)
forall x. PathMap x
emptyPathMap
       in [[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
PathMap [[Text] -> x]
c [x]
h HashMap Text (PathMap x)
s ((Maybe (PathMap (a -> x)) -> Maybe (PathMap (a -> x)))
-> PolyMap FromHttpApiData PathMap x
-> PolyMap FromHttpApiData PathMap x
forall p (c :: * -> Constraint) (f :: * -> *) a.
(Typeable p, c p) =>
(Maybe (f (p -> a)) -> Maybe (f (p -> a)))
-> PolyMap c f a -> PolyMap c f a
PM.alter Maybe (PathMap (a -> x)) -> Maybe (PathMap (a -> x))
alterFn PolyMap FromHttpApiData PathMap x
p) [Text -> x]
w [(Int, [Text] -> [x])]
e
    PI_Wildcard PathInternal as
PI_Empty ->
      let (PathMap [[Text] -> Text -> x]
_ (Text -> x
action' : [Text -> x]
_) HashMap Text (PathMap (Text -> x))
_ PolyMap FromHttpApiData PathMap (Text -> x)
_ [Text -> Text -> x]
_ [(Int, [Text] -> [Text -> x])]
_) = (ctx -> Text -> x) -> PathMap (Text -> x) -> PathMap (Text -> x)
forall y. (ctx -> y) -> PathMap y -> PathMap y
updateFn (\ctx
ctx Text
rest -> HVect ts -> ctx -> x
action (Text
rest Text -> HVect '[] -> HVect '[Text]
forall t (ts1 :: [*]). t -> HVect ts1 -> HVect (t : ts1)
:&: HVect '[]
HNil) ctx
ctx) PathMap (Text -> x)
forall x. PathMap x
emptyPathMap
       in [[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
PathMap [[Text] -> x]
c [x]
h HashMap Text (PathMap x)
s PolyMap FromHttpApiData PathMap x
p (Text -> x
action' (Text -> x) -> [Text -> x] -> [Text -> x]
forall a. a -> [a] -> [a]
: [Text -> x]
w) [(Int, [Text] -> [x])]
e
    PI_Wildcard PathInternal as
_ -> String -> PathMap x
forall a. HasCallStack => String -> a
error String
"Shouldn't happen"
    PI_Extension PathInternal as
_ PathInternal bs
_ -> PathMap x
patternMap
    PI_Append PathInternal as
_ PathInternal bs
_ -> PathMap x
patternMap
  where
    patternMap :: PathMap x
patternMap = PathMap x
pm { pm_patterns = orderPatterns $ (pathSpecificity path, matcher) : e }
    matcher :: [Text] -> [x]
matcher [Text]
pieces = case PathInternal ts -> [Text] -> Maybe (HVect ts, [Text])
forall (as :: [*]).
PathInternal as -> [Text] -> Maybe (HVect as, [Text])
parsePrefix PathInternal ts
path [Text]
pieces of
      Maybe (HVect ts, [Text])
Nothing -> []
      Just (HVect ts
args, [Text]
remaining) -> PathMap x -> [Text] -> [x]
forall x. PathMap x -> [Text] -> [x]
match ((ctx -> x) -> PathMap x -> PathMap x
forall y. (ctx -> y) -> PathMap y -> PathMap y
updateFn (HVect ts -> ctx -> x
action HVect ts
args) PathMap x
forall x. PathMap x
emptyPathMap) [Text]
remaining

insertPathMap' :: PathInternal ts -> (HVect ts -> x) -> PathMap x -> PathMap x
insertPathMap' :: forall (ts :: [*]) x.
PathInternal ts -> (HVect ts -> x) -> PathMap x -> PathMap x
insertPathMap' PathInternal ts
path HVect ts -> x
action =
  let updateHeres :: (() -> x) -> PathMap x -> PathMap x
updateHeres () -> x
y (PathMap [[Text] -> x]
c [x]
h HashMap Text (PathMap x)
s PolyMap FromHttpApiData PathMap x
p [Text -> x]
w [(Int, [Text] -> [x])]
e) = [[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
PathMap [[Text] -> x]
c (() -> x
y () x -> [x] -> [x]
forall a. a -> [a] -> [a]
: [x]
h) HashMap Text (PathMap x)
s PolyMap FromHttpApiData PathMap x
p [Text -> x]
w [(Int, [Text] -> [x])]
e
   in (forall y. (() -> y) -> PathMap y -> PathMap y)
-> PathInternal ts
-> (HVect ts -> () -> x)
-> PathMap x
-> PathMap x
forall ctx (ts :: [*]) x.
(forall y. (ctx -> y) -> PathMap y -> PathMap y)
-> PathInternal ts
-> (HVect ts -> ctx -> x)
-> PathMap x
-> PathMap x
updatePathMap (() -> y) -> PathMap y -> PathMap y
forall y. (() -> y) -> PathMap y -> PathMap y
updateHeres PathInternal ts
path (x -> () -> x
forall a b. a -> b -> a
const (x -> () -> x) -> (HVect ts -> x) -> HVect ts -> () -> x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HVect ts -> x
action)

singleton :: PathInternal ts -> HVectElim ts x -> PathMap x
singleton :: forall (ts :: [*]) x.
PathInternal ts -> HVectElim ts x -> PathMap x
singleton PathInternal ts
path HVectElim ts x
action = PathInternal ts -> (HVect ts -> x) -> PathMap x -> PathMap x
forall (ts :: [*]) x.
PathInternal ts -> (HVect ts -> x) -> PathMap x -> PathMap x
insertPathMap' PathInternal ts
path (HVectElim ts x -> HVect ts -> x
forall (ts :: [*]) a. HVectElim ts a -> HVect ts -> a
HV.uncurry HVectElim ts x
action) PathMap x
forall a. Monoid a => a
mempty

insertPathMap :: RouteHandle m a -> PathMap (m a) -> PathMap (m a)
insertPathMap :: forall (m :: * -> *) a.
RouteHandle m a -> PathMap (m a) -> PathMap (m a)
insertPathMap (RouteHandle PathInternal as
path HVectElim as (m a)
action) = PathInternal as
-> (HVect as -> m a) -> PathMap (m a) -> PathMap (m a)
forall (ts :: [*]) x.
PathInternal ts -> (HVect ts -> x) -> PathMap x -> PathMap x
insertPathMap' PathInternal as
path (HVectElim as (m a) -> HVect as -> m a
forall (ts :: [*]) a. HVectElim ts a -> HVect ts -> a
HV.uncurry HVectElim as (m a)
action)

insertSubComponent' :: PathInternal ts -> (HVect ts -> [T.Text] -> x) -> PathMap x -> PathMap x
insertSubComponent' :: forall (ts :: [*]) x.
PathInternal ts
-> (HVect ts -> [Text] -> x) -> PathMap x -> PathMap x
insertSubComponent' PathInternal ts
path HVect ts -> [Text] -> x
subComponent =
  let updateSubComponents :: ([Text] -> x) -> PathMap x -> PathMap x
updateSubComponents [Text] -> x
y (PathMap [[Text] -> x]
c [x]
h HashMap Text (PathMap x)
s PolyMap FromHttpApiData PathMap x
p [Text -> x]
w [(Int, [Text] -> [x])]
e) = [[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> [(Int, [Text] -> [x])]
-> PathMap x
PathMap ([Text] -> x
y ([Text] -> x) -> [[Text] -> x] -> [[Text] -> x]
forall a. a -> [a] -> [a]
: [[Text] -> x]
c) [x]
h HashMap Text (PathMap x)
s PolyMap FromHttpApiData PathMap x
p [Text -> x]
w [(Int, [Text] -> [x])]
e
   in (forall y. ([Text] -> y) -> PathMap y -> PathMap y)
-> PathInternal ts
-> (HVect ts -> [Text] -> x)
-> PathMap x
-> PathMap x
forall ctx (ts :: [*]) x.
(forall y. (ctx -> y) -> PathMap y -> PathMap y)
-> PathInternal ts
-> (HVect ts -> ctx -> x)
-> PathMap x
-> PathMap x
updatePathMap ([Text] -> y) -> PathMap y -> PathMap y
forall y. ([Text] -> y) -> PathMap y -> PathMap y
updateSubComponents PathInternal ts
path HVect ts -> [Text] -> x
subComponent

insertSubComponent :: Functor m => RouteHandle m ([T.Text] -> a) -> PathMap (m a) -> PathMap (m a)
insertSubComponent :: forall (m :: * -> *) a.
Functor m =>
RouteHandle m ([Text] -> a) -> PathMap (m a) -> PathMap (m a)
insertSubComponent (RouteHandle PathInternal as
path HVectElim as (m ([Text] -> a))
comp) =
  PathInternal as
-> (HVect as -> [Text] -> m a) -> PathMap (m a) -> PathMap (m a)
forall (ts :: [*]) x.
PathInternal ts
-> (HVect ts -> [Text] -> x) -> PathMap x -> PathMap x
insertSubComponent' PathInternal as
path ((m ([Text] -> a) -> [Text] -> m a)
-> (HVect as -> m ([Text] -> a)) -> HVect as -> [Text] -> m a
forall a b. (a -> b) -> (HVect as -> a) -> HVect as -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\m ([Text] -> a)
m [Text]
ps -> (([Text] -> a) -> a) -> m ([Text] -> a) -> m a
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Text] -> a) -> [Text] -> a
forall a b. (a -> b) -> a -> b
$ [Text]
ps) m ([Text] -> a)
m) (HVectElim as (m ([Text] -> a)) -> HVect as -> m ([Text] -> a)
forall (ts :: [*]) a. HVectElim ts a -> HVect ts -> a
HV.uncurry HVectElim as (m ([Text] -> a))
comp))

match :: PathMap x -> [T.Text] -> [x]
match :: forall x. PathMap x -> [Text] -> [x]
match (PathMap [[Text] -> x]
c [x]
h HashMap Text (PathMap x)
s PolyMap FromHttpApiData PathMap x
p [Text -> x]
w [(Int, [Text] -> [x])]
e) [Text]
pieces =
  (([Text] -> x) -> x) -> [[Text] -> x] -> [x]
forall a b. (a -> b) -> [a] -> [b]
map (([Text] -> x) -> [Text] -> x
forall a b. (a -> b) -> a -> b
$ [Text]
pieces) [[Text] -> x]
c
    [x] -> [x] -> [x]
forall a. [a] -> [a] -> [a]
++ case [Text]
pieces of
      [] -> [x]
h [x] -> [x] -> [x]
forall a. [a] -> [a] -> [a]
++ ((Int, [Text] -> [x]) -> [x]) -> [(Int, [Text] -> [x])] -> [x]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((([Text] -> [x]) -> [Text] -> [x]
forall a b. (a -> b) -> a -> b
$ [Text]
pieces) (([Text] -> [x]) -> [x])
-> ((Int, [Text] -> [x]) -> [Text] -> [x])
-> (Int, [Text] -> [x])
-> [x]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [Text] -> [x]) -> [Text] -> [x]
forall a b. (a, b) -> b
snd) [(Int, [Text] -> [x])]
e [x] -> [x] -> [x]
forall a. [a] -> [a] -> [a]
++ ((Text -> x) -> x) -> [Text -> x] -> [x]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> x) -> Text -> x
forall a b. (a -> b) -> a -> b
$ Text
"") [Text -> x]
w
      (Text
pp : [Text]
pps) ->
        let staticMatches :: [x]
staticMatches = Maybe (PathMap x) -> [PathMap x]
forall a. Maybe a -> [a]
maybeToList (Text -> HashMap Text (PathMap x) -> Maybe (PathMap x)
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HM.lookup Text
pp HashMap Text (PathMap x)
s) [PathMap x] -> (PathMap x -> [x]) -> [x]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PathMap x -> [Text] -> [x]) -> [Text] -> PathMap x -> [x]
forall a b c. (a -> b -> c) -> b -> a -> c
flip PathMap x -> [Text] -> [x]
forall x. PathMap x -> [Text] -> [x]
match [Text]
pps
            varMatches :: [x]
varMatches =
              (forall p. FromHttpApiData p => Maybe p)
-> (forall p. FromHttpApiData p => p -> PathMap (p -> x) -> [x])
-> PolyMap FromHttpApiData PathMap x
-> [x]
forall m (f :: * -> *) (c :: * -> Constraint) a.
(Monoid m, Functor f) =>
(forall p. c p => Maybe p)
-> (forall p. c p => p -> f (p -> a) -> m) -> PolyMap c f a -> m
PM.lookupConcat
                ((Text -> Maybe p) -> (p -> Maybe p) -> Either Text p -> Maybe p
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe p -> Text -> Maybe p
forall a b. a -> b -> a
const Maybe p
forall a. Maybe a
Nothing) p -> Maybe p
forall a. a -> Maybe a
Just (Either Text p -> Maybe p) -> Either Text p -> Maybe p
forall a b. (a -> b) -> a -> b
$ Text -> Either Text p
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
pp)
                (\p
piece PathMap (p -> x)
pathMap' -> ((p -> x) -> x) -> [p -> x] -> [x]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((p -> x) -> p -> x
forall a b. (a -> b) -> a -> b
$ p
piece) (PathMap (p -> x) -> [Text] -> [p -> x]
forall x. PathMap x -> [Text] -> [x]
match PathMap (p -> x)
pathMap' [Text]
pps))
                PolyMap FromHttpApiData PathMap x
p
            routeRest :: Text
routeRest = [Text] -> Text
combineRoutePieces [Text]
pieces
            wildcardMatches :: [x]
wildcardMatches = ((Text -> x) -> x) -> [Text -> x] -> [x]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> x) -> Text -> x
forall a b. (a -> b) -> a -> b
$ Text
routeRest) [Text -> x]
w
            extensionMatches :: [x]
extensionMatches = ((Int, [Text] -> [x]) -> [x]) -> [(Int, [Text] -> [x])] -> [x]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((([Text] -> [x]) -> [Text] -> [x]
forall a b. (a -> b) -> a -> b
$ [Text]
pieces) (([Text] -> [x]) -> [x])
-> ((Int, [Text] -> [x]) -> [Text] -> [x])
-> (Int, [Text] -> [x])
-> [x]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [Text] -> [x]) -> [Text] -> [x]
forall a b. (a, b) -> b
snd) [(Int, [Text] -> [x])]
e
         in [x]
staticMatches [x] -> [x] -> [x]
forall a. [a] -> [a] -> [a]
++ [x]
extensionMatches [x] -> [x] -> [x]
forall a. [a] -> [a] -> [a]
++ [x]
varMatches [x] -> [x] -> [x]
forall a. [a] -> [a] -> [a]
++ [x]
wildcardMatches

(</!>) :: PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
</!> :: forall (as :: [*]) (bs :: [*]).
PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
(</!>) PathInternal as
PI_Empty PathInternal bs
xs = PathInternal bs
PathInternal (Append as bs)
xs
(</!>) (PI_StaticCons Text
pathPiece PathInternal as
xs) PathInternal bs
ys = Text -> PathInternal (Append as bs) -> PathInternal (Append as bs)
forall (as :: [*]). Text -> PathInternal as -> PathInternal as
PI_StaticCons Text
pathPiece (PathInternal as
xs PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
forall (as :: [*]) (bs :: [*]).
PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
</!> PathInternal bs
ys)
(</!>) (PI_VarCons PathInternal as
xs) PathInternal bs
ys = PathInternal (Append as bs) -> PathInternal (a : Append as bs)
forall as (bs :: [*]).
(FromHttpApiData as, Typeable as) =>
PathInternal bs -> PathInternal (as : bs)
PI_VarCons (PathInternal as
xs PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
forall (as :: [*]) (bs :: [*]).
PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
</!> PathInternal bs
ys)
(</!>) (PI_Wildcard PathInternal as
_) PathInternal bs
_ = String -> PathInternal (Text : Append as bs)
forall a. HasCallStack => String -> a
error String
"Shouldn't happen"
(</!>) path :: PathInternal as
path@(PI_Extension PathInternal as
_ PathInternal bs
_) PathInternal bs
ys = PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
forall (as :: [*]) (bs :: [*]).
PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
PI_Append PathInternal as
path PathInternal bs
ys
(</!>) path :: PathInternal as
path@(PI_Append PathInternal as
_ PathInternal bs
_) PathInternal bs
ys = PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
forall (as :: [*]) (bs :: [*]).
PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
PI_Append PathInternal as
path PathInternal bs
ys

combineRoutePieces :: [T.Text] -> T.Text
combineRoutePieces :: [Text] -> Text
combineRoutePieces = Text -> [Text] -> Text
T.intercalate Text
"/"

parse :: PathInternal as -> [T.Text] -> Maybe (HVect as)
parse :: forall (as :: [*]). PathInternal as -> [Text] -> Maybe (HVect as)
parse PathInternal as
path [Text]
pieces = do
  (args, remaining) <- PathInternal as -> [Text] -> Maybe (HVect as, [Text])
forall (as :: [*]).
PathInternal as -> [Text] -> Maybe (HVect as, [Text])
parsePrefix PathInternal as
path [Text]
pieces
  if null remaining then Just args else Nothing

parsePrefix :: PathInternal as -> [T.Text] -> Maybe (HVect as, [T.Text])
parsePrefix :: forall (as :: [*]).
PathInternal as -> [Text] -> Maybe (HVect as, [Text])
parsePrefix PathInternal as
PI_Empty [Text]
pieces = (HVect as, [Text]) -> Maybe (HVect as, [Text])
forall a. a -> Maybe a
Just (HVect as
HVect '[]
HNil, [Text]
pieces)
parsePrefix (PI_Wildcard PathInternal as
PI_Empty) [Text]
pieces = (HVect as, [Text]) -> Maybe (HVect as, [Text])
forall a. a -> Maybe a
Just ([Text] -> Text
combineRoutePieces [Text]
pieces Text -> HVect '[] -> HVect '[Text]
forall t (ts1 :: [*]). t -> HVect ts1 -> HVect (t : ts1)
:&: HVect '[]
HNil, [])
parsePrefix (PI_Wildcard PathInternal as
_) [Text]
_ = String -> Maybe (HVect as, [Text])
forall a. HasCallStack => String -> a
error String
"Shouldn't happen"
parsePrefix (PI_Append PathInternal as
left PathInternal bs
right) [Text]
pieces = do
  (leftArgs, rest) <- PathInternal as -> [Text] -> Maybe (HVect as, [Text])
forall (as :: [*]).
PathInternal as -> [Text] -> Maybe (HVect as, [Text])
parsePrefix PathInternal as
left [Text]
pieces
  (rightArgs, remaining) <- parsePrefix right rest
  pure (leftArgs <++> rightArgs, remaining)
parsePrefix (PI_Extension PathInternal as
left PathInternal bs
right) [Text]
pieces =
  case Int -> [Text] -> ([Text], [Text])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ PathInternal as -> Int
forall (as :: [*]). PathInternal as -> Int
pathPieceCount PathInternal as
left Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Text]
pieces of
    ([Text]
prefix, Text
joined : [Text]
rest) -> [(HVect as, [Text])] -> Maybe (HVect as, [Text])
forall a. [a] -> Maybe a
listToMaybe
      [ (HVect as
leftArgs HVect as -> HVect bs -> HVect (Append as bs)
forall (as :: [*]) (bs :: [*]).
HVect as -> HVect bs -> HVect (Append as bs)
<++> HVect bs
rightArgs, [Text]
remaining)
      | (Text
base, Text
extension) <- PathInternal bs -> Text -> [(Text, Text)]
forall (as :: [*]). PathInternal as -> Text -> [(Text, Text)]
extensionSplits PathInternal bs
right Text
joined,
        Just HVect as
leftArgs <- [PathInternal as -> [Text] -> Maybe (HVect as)
forall (as :: [*]). PathInternal as -> [Text] -> Maybe (HVect as)
parse PathInternal as
left (if PathInternal as -> Int
forall (as :: [*]). PathInternal as -> Int
pathPieceCount PathInternal as
left Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [] else [Text]
prefix [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
base])],
        PathInternal as -> Int
forall (as :: [*]). PathInternal as -> Int
pathPieceCount PathInternal as
left Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
|| Text -> Bool
T.null Text
base,
        PathInternal bs -> Int
forall (as :: [*]). PathInternal as -> Int
pathPieceCount PathInternal bs
right Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
|| Text -> Bool
T.null Text
extension,
        Just (HVect bs
rightArgs, [Text]
remaining) <- [PathInternal bs -> [Text] -> Maybe (HVect bs, [Text])
forall (as :: [*]).
PathInternal as -> [Text] -> Maybe (HVect as, [Text])
parsePrefix PathInternal bs
right (if PathInternal bs -> Int
forall (as :: [*]). PathInternal as -> Int
pathPieceCount PathInternal bs
right Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [Text]
rest else Text
extension Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
rest)]
      ]
    ([Text], [Text])
_ -> Maybe (HVect as, [Text])
forall a. Maybe a
Nothing
parsePrefix PathInternal as
_ [] = Maybe (HVect as, [Text])
forall a. Maybe a
Nothing
parsePrefix (PI_StaticCons Text
expected PathInternal as
rest) (Text
piece : [Text]
pieces)
  | Text
expected Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
piece = PathInternal as -> [Text] -> Maybe (HVect as, [Text])
forall (as :: [*]).
PathInternal as -> [Text] -> Maybe (HVect as, [Text])
parsePrefix PathInternal as
rest [Text]
pieces
  | Bool
otherwise = Maybe (HVect as, [Text])
forall a. Maybe a
Nothing
parsePrefix (PI_VarCons PathInternal as
rest) (Text
piece : [Text]
pieces) = do
  value <- (Text -> Maybe a) -> (a -> Maybe a) -> Either Text a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> Text -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (Either Text a -> Maybe a) -> Either Text a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Text -> Either Text a
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
piece
  (args, remaining) <- parsePrefix rest pieces
  pure (value :&: args, remaining)

-- Fixed suffixes have one possible split; avoid trying every dot in a long
-- filename when the literal extension is absent.
extensionSplits :: PathInternal as -> T.Text -> [(T.Text, T.Text)]
extensionSplits :: forall (as :: [*]). PathInternal as -> Text -> [(Text, Text)]
extensionSplits (PI_StaticCons Text
extension PathInternal as
_) Text
piece =
  [(Text
base, Text
extension) | Just Text
base <- [Text -> Text -> Maybe Text
T.stripSuffix (Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
extension) Text
piece]]
extensionSplits PathInternal as
PI_Empty Text
piece = [(Text
base, Text
"") | Just Text
base <- [Text -> Text -> Maybe Text
T.stripSuffix Text
"." Text
piece]]
extensionSplits PathInternal as
_ Text
piece = Text -> [(Text, Text)]
dotSplits Text
piece

-- Rightmost valid split keeps dots in a basename, while allowing a fixed
-- multi-dot suffix such as tar.gz or a custom typed extension parser.
dotSplits :: T.Text -> [(T.Text, T.Text)]
dotSplits :: Text -> [(Text, Text)]
dotSplits Text
piece = [(Int -> Text -> Text
T.take Int
i Text
piece, Int -> Text -> Text
T.drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
piece) | Int
i <- [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
findIndices (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') (String -> [Int]) -> String -> [Int]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
piece]

pathPieceCount :: PathInternal as -> Int
pathPieceCount :: forall (as :: [*]). PathInternal as -> Int
pathPieceCount PathInternal as
PI_Empty = Int
0
pathPieceCount (PI_StaticCons Text
_ PathInternal as
rest) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PathInternal as -> Int
forall (as :: [*]). PathInternal as -> Int
pathPieceCount PathInternal as
rest
pathPieceCount (PI_VarCons PathInternal as
rest) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PathInternal as -> Int
forall (as :: [*]). PathInternal as -> Int
pathPieceCount PathInternal as
rest
pathPieceCount (PI_Wildcard PathInternal as
_) = Int
1
pathPieceCount (PI_Append PathInternal as
left PathInternal bs
right) = PathInternal as -> Int
forall (as :: [*]). PathInternal as -> Int
pathPieceCount PathInternal as
left Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PathInternal bs -> Int
forall (as :: [*]). PathInternal as -> Int
pathPieceCount PathInternal bs
right
pathPieceCount (PI_Extension PathInternal as
left PathInternal bs
right) = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (PathInternal as -> Int
forall (as :: [*]). PathInternal as -> Int
pathPieceCount PathInternal as
left) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (PathInternal bs -> Int
forall (as :: [*]). PathInternal as -> Int
pathPieceCount PathInternal bs
right) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

pathSpecificity :: PathInternal as -> Int
pathSpecificity :: forall (as :: [*]). PathInternal as -> Int
pathSpecificity PathInternal as
PI_Empty = Int
0
pathSpecificity (PI_StaticCons Text
piece PathInternal as
rest) = Text -> Int
T.length Text
piece Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PathInternal as -> Int
forall (as :: [*]). PathInternal as -> Int
pathSpecificity PathInternal as
rest
pathSpecificity (PI_VarCons PathInternal as
rest) = PathInternal as -> Int
forall (as :: [*]). PathInternal as -> Int
pathSpecificity PathInternal as
rest
pathSpecificity (PI_Wildcard PathInternal as
rest) = PathInternal as -> Int
forall (as :: [*]). PathInternal as -> Int
pathSpecificity PathInternal as
rest
pathSpecificity (PI_Append PathInternal as
left PathInternal bs
right) = PathInternal as -> Int
forall (as :: [*]). PathInternal as -> Int
pathSpecificity PathInternal as
left Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PathInternal bs -> Int
forall (as :: [*]). PathInternal as -> Int
pathSpecificity PathInternal bs
right
pathSpecificity (PI_Extension PathInternal as
left PathInternal bs
right) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PathInternal as -> Int
forall (as :: [*]). PathInternal as -> Int
pathSpecificity PathInternal as
left Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PathInternal bs -> Int
forall (as :: [*]). PathInternal as -> Int
pathSpecificity PathInternal bs
right