module Web.Routes.Nested.Types
( Singleton (..)
, Extend (..)
, Extrude (..)
, CatMaybes
, module Web.Routes.Nested.Types.UrlChunks
) where
import Data.Attoparsec.Text
import Text.Regex
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 (eitherToMaybe . parseOnly q) mx xs]
extend ((:*) (i,q)) (RootedPredTrie mx xs) = RootedPredTrie Nothing $
PredTrie mempty $ PredSteps [PredStep i (matchRegex q . T.unpack) 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')
eitherToMaybe :: Either String r -> Maybe r
eitherToMaybe (Right r') = Just r'
eitherToMaybe _ = Nothing