module Web.Routes.Nested.Types
( Singleton (..)
, Extend (..)
, Extrude (..)
, CatMaybes
, module Web.Routes.Nested.Types.UrlChunks
) where
import Web.Routes.Nested.Types.UrlChunks
import qualified Data.Text as T
import Data.Trie.Pred
import Data.Trie.Pred.Step
import qualified Data.Trie.Map as MT
import qualified Data.Map as Map
type family CatMaybes (xs :: [Maybe *]) :: [*] where
CatMaybes '[] = '[]
CatMaybes ('Nothing ': xs) = CatMaybes xs
CatMaybes (('Just x) ': xs) = x ': CatMaybes xs
class Singleton chunks a trie | chunks a -> trie where
singleton :: chunks -> a -> trie
instance Singleton (UrlChunks '[]) a (RootedPredTrie T.Text a) where
singleton Root r = RootedPredTrie (Just r) emptyPT
instance ( Singleton (UrlChunks xs) a trie0
, Extend (EitherUrlChunk x) trie0 trie1
) => Singleton (UrlChunks (x ': xs)) a trie1 where
singleton (Cons u us) r = extend u (singleton us r)
class Extend eitherUrlChunk child result | eitherUrlChunk child -> result where
extend :: eitherUrlChunk -> child -> result
instance Extend (EitherUrlChunk 'Nothing) (RootedPredTrie T.Text a) (RootedPredTrie T.Text a) where
extend ((:=) t) (RootedPredTrie mx xs) = RootedPredTrie Nothing $
PredTrie (MT.MapStep $ Map.singleton t (mx, Just xs)) mempty
instance Extend (EitherUrlChunk ('Just r)) (RootedPredTrie T.Text (r -> a)) (RootedPredTrie T.Text a) where
extend ((:~) (i,q)) (RootedPredTrie mx xs) = RootedPredTrie Nothing $
PredTrie mempty (PredSteps [PredStep i q mx xs])
class Extrude chunks start result | chunks start -> result where
extrude :: chunks -> start -> result
instance Extrude (UrlChunks '[]) (RootedPredTrie T.Text a) (RootedPredTrie T.Text a) where
extrude Root r = r
instance ( Extrude (UrlChunks xs) trie0 trie1
, Extend (EitherUrlChunk x) trie1 trie2 ) => Extrude (UrlChunks (x ': xs)) trie0 trie2 where
extrude (Cons u us) r = extend u (extrude us r)