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

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"