{-# LANGUAGE BangPatterns #-}
module Webby.Route where
import qualified Data.HashMap.Strict as H
import Webby.Types
import WebbyPrelude
data HashTrie a = HashTrie { handlerMay :: Maybe a
, litSubtree :: H.HashMap Text (HashTrie a)
, capMay :: Maybe (Text, HashTrie a)
}
deriving (Eq, Show)
emptyHashTrie :: HashTrie a
emptyHashTrie = HashTrie Nothing H.empty Nothing
addItem :: ([PathSegment], a) -> HashTrie a -> Maybe (HashTrie a)
addItem ([], !handler) !trie =
case handlerMay trie of
Nothing -> Just $ trie { handlerMay = Just handler }
Just _ -> Nothing
addItem (b:bs, !handler) !trie =
case b of
Literal p ->
let ltrie = litSubtree trie
child = H.lookupDefault emptyHashTrie p ltrie
in do nchild <- addItem (bs, handler) child
let nltrie = H.insert p nchild ltrie
return $ trie { litSubtree = nltrie }
Capture p ->
case capMay trie of
Nothing -> do ntrie <- addItem (bs, handler) emptyHashTrie
return $ trie { capMay = Just (p, ntrie) }
Just _ -> Nothing
lookupItem :: [Text] -> HashTrie a
-> Maybe (Captures, a)
lookupItem !bs' !trie' = lookupItemWithCaptures bs' trie' H.empty
where
lookupItemWithCaptures [] !trie !h = do hdlr <- handlerMay trie
return (h, hdlr)
lookupItemWithCaptures (b:bs) !trie !h =
let litChildMay = H.lookup b $ litSubtree trie
captureLookup = do (capKey, childTrie) <- capMay trie
lookupItemWithCaptures bs childTrie $
H.insert capKey b h
in
maybe captureLookup
(\childTrie -> lookupItemWithCaptures bs childTrie h)
litChildMay
routePattern2PathSegments :: RoutePattern -> [PathSegment]
routePattern2PathSegments (RoutePattern mthd ps) =
(Literal $ decodeUtf8Lenient mthd) : ps
mkRoutesHashTrie :: Routes a -> Maybe (HashTrie (WebbyM a ()))
mkRoutesHashTrie rs = foldl combine (Just emptyHashTrie) rs
where
combine Nothing _ = Nothing
combine (Just h) (rpat, handler) =
let pathSegments = routePattern2PathSegments rpat
in addItem (pathSegments, handler) h