{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Web.Routing.SafeRouting where

import Data.HVect hiding (null, length)
import qualified Data.HVect as HV
import qualified Data.PolyMap as PM

import Data.Maybe
#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.Typeable (Typeable)
import Web.HttpApiData
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T

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

newtype HVectElim' x ts = HVectElim' { 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 :: 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 :: 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 :: ([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 :: 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 (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

data PathMap x =
  PathMap
  { PathMap x -> [[Text] -> x]
pm_subComponents :: [[T.Text] -> x]
  , PathMap x -> [x]
pm_here :: [x]
  , PathMap x -> HashMap Text (PathMap x)
pm_staticMap :: HM.HashMap T.Text (PathMap x)
  , PathMap x -> PolyMap FromHttpApiData PathMap x
pm_polyMap :: PM.PolyMap FromHttpApiData PathMap x
  , PathMap x -> [Text -> x]
pm_wildcards :: [T.Text -> x]
  }

instance Functor PathMap where
  fmap :: (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) =
      [[Text] -> b]
-> [b]
-> HashMap Text (PathMap b)
-> PolyMap FromHttpApiData PathMap b
-> [Text -> b]
-> PathMap b
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> PathMap x
PathMap ((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 (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 (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)

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) =
      [[Text] -> x] -> ()
forall a. NFData a => a -> ()
rnf [[Text] -> x]
c () -> () -> ()
`seq` [x] -> ()
forall a. NFData a => a -> ()
rnf [x]
h () -> () -> ()
`seq` HashMap Text (PathMap x) -> ()
forall a. NFData a => a -> ()
rnf HashMap Text (PathMap x)
s () -> () -> ()
`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 forall a. NFData a => a -> ()
forall p. FromHttpApiData p => PathMap (p -> x) -> ()
rnf PolyMap FromHttpApiData PathMap x
p () -> () -> ()
`seq` [Text -> x] -> ()
forall a. NFData a => a -> ()
rnf [Text -> x]
w

emptyPathMap :: PathMap x
emptyPathMap :: PathMap x
emptyPathMap = [[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> PathMap x
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [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

instance Semigroup (PathMap x) where
  (PathMap [[Text] -> x]
c1 [x]
h1 HashMap Text (PathMap x)
s1 PolyMap FromHttpApiData PathMap x
p1 [Text -> x]
w1) <> :: 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) =
    [[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> PathMap x
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [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, Hashable 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 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)

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 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) =
  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. (Eq k, 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]
-> PathMap x
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> PathMap x
PathMap [[Text] -> x]
c [x]
h (Text
-> PathMap x
-> HashMap Text (PathMap x)
-> HashMap Text (PathMap x)
forall k v.
(Eq k, 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 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
    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 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]
-> PathMap x
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [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
    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]
_) = (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]
-> PathMap x
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> PathMap x
PathMap [[Text] -> x]
c [x]
h HashMap Text (PathMap x)
s PolyMap FromHttpApiData PathMap x
p ([Text -> x] -> PathMap x) -> [Text -> x] -> PathMap x
forall a b. (a -> b) -> a -> b
$ Text -> x
action' (Text -> x) -> [Text -> x] -> [Text -> x]
forall a. a -> [a] -> [a]
: [Text -> x]
w
    PI_Wildcard PathInternal as
_ -> [Char] -> PathMap x
forall a. HasCallStack => [Char] -> a
error [Char]
"Shouldn't happen"

insertPathMap' :: PathInternal ts -> (HVect ts -> x) -> PathMap x -> PathMap x
insertPathMap' :: PathInternal ts -> (HVect ts -> x) -> PathMap x -> PathMap x
insertPathMap' PathInternal ts
path HVect ts -> x
action =
  let updateHeres :: (() -> a) -> PathMap a -> PathMap a
updateHeres () -> a
y (PathMap [[Text] -> a]
c [a]
h HashMap Text (PathMap a)
s PolyMap FromHttpApiData PathMap a
p [Text -> a]
w) = [[Text] -> a]
-> [a]
-> HashMap Text (PathMap a)
-> PolyMap FromHttpApiData PathMap a
-> [Text -> a]
-> PathMap a
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> PathMap x
PathMap [[Text] -> a]
c (() -> a
y () a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
h) HashMap Text (PathMap a)
s PolyMap FromHttpApiData PathMap a
p [Text -> a]
w
  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 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 :: 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 :: 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' :: 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) = [[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [Text -> x]
-> PathMap x
forall x.
[[Text] -> x]
-> [x]
-> HashMap Text (PathMap x)
-> PolyMap FromHttpApiData PathMap x
-> [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
  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 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 :: 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 (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 (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 :: PathMap x -> [Text] -> [x]
match (PathMap [[Text] -> x]
c [x]
h HashMap Text (PathMap x)
s PolyMap FromHttpApiData PathMap x
p [Text -> x]
w) [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]
++ ((Text -> x) -> x) -> [Text -> x] -> [x]
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. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
pp HashMap Text (PathMap x)
s) [PathMap x] -> (PathMap x -> [x]) -> [x]
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 (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 (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
      in [x]
staticMatches [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)
</!> :: 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 a (as :: [*]).
(FromHttpApiData a, Typeable a) =>
PathInternal as -> PathInternal (a : as)
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
_ = [Char] -> PathInternal (Text : Append as bs)
forall a. HasCallStack => [Char] -> a
error [Char]
"Shouldn't happen"

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

parse :: PathInternal as -> [T.Text] -> Maybe (HVect as)
parse :: PathInternal as -> [Text] -> Maybe (HVect as)
parse PathInternal as
PI_Empty [] = HVect '[] -> Maybe (HVect '[])
forall a. a -> Maybe a
Just HVect '[]
HNil
parse PathInternal as
_ [] = Maybe (HVect as)
forall a. Maybe a
Nothing
parse PathInternal as
path pathComps :: [Text]
pathComps@(Text
pathComp : [Text]
xs) =
    case PathInternal as
path of
      PathInternal as
PI_Empty -> Maybe (HVect as)
forall a. Maybe a
Nothing
      PI_StaticCons Text
pathPiece PathInternal as
pathXs ->
          if Text
pathPiece Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
pathComp
          then PathInternal as -> [Text] -> Maybe (HVect as)
forall (as :: [*]). PathInternal as -> [Text] -> Maybe (HVect as)
parse PathInternal as
pathXs [Text]
xs
          else Maybe (HVect as)
forall a. Maybe a
Nothing
      PI_VarCons PathInternal as
pathXs ->
          case Text -> Either Text a
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
pathComp of
            Left Text
_ -> Maybe (HVect as)
forall a. Maybe a
Nothing
            Right a
val ->
                let finish :: Maybe (HVect as)
finish = PathInternal as -> [Text] -> Maybe (HVect as)
forall (as :: [*]). PathInternal as -> [Text] -> Maybe (HVect as)
parse PathInternal as
pathXs [Text]
xs
                in (HVect as -> HVect (a : as))
-> Maybe (HVect as) -> Maybe (HVect (a : as))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HVect as
parsedXs -> a
val a -> HVect as -> HVect (a : as)
forall t (ts1 :: [*]). t -> HVect ts1 -> HVect (t : ts1)
:&: HVect as
parsedXs) Maybe (HVect as)
finish
      PI_Wildcard PathInternal as
PI_Empty ->
        HVect '[Text] -> Maybe (HVect '[Text])
forall a. a -> Maybe a
Just (HVect '[Text] -> Maybe (HVect '[Text]))
-> HVect '[Text] -> Maybe (HVect '[Text])
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
combineRoutePieces [Text]
pathComps Text -> HVect '[] -> HVect '[Text]
forall t (ts1 :: [*]). t -> HVect ts1 -> HVect (t : ts1)
:&: HVect '[]
HNil
      PI_Wildcard PathInternal as
_ ->
        [Char] -> Maybe (HVect as)
forall a. HasCallStack => [Char] -> a
error [Char]
"Shouldn't happen"