module Data.Trie.Pred.Interface.Types
(
Singleton (..)
, Extend (..)
, Extrude (..)
, ExtrudeSoundly
, CatMaybes
,
only
, pred
, (./)
, nil
,
PathChunk
, PathChunks
) where
import Prelude hiding (pred)
import Data.Trie.Pred.Base (RootedPredTrie (..), PredTrie (..), emptyPT)
import Data.Trie.Pred.Base.Step (Pred (..), PredStep (..))
import qualified Data.Trie.HashMap as HT
import qualified Data.HashMap.Lazy as HM
import Data.Hashable (Hashable)
import Data.Function.Poly (ArityTypeListIso)
import Data.Typeable (Typeable)
import Data.String (IsString (..))
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 (PathChunks k '[]) a (RootedPredTrie k a) where
singleton Nil r = RootedPredTrie (Just r) emptyPT
instance ( Singleton (PathChunks k xs) new trie0
, Extend (PathChunk k x) trie0 trie1
) => Singleton (PathChunks k (x ': xs)) new 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 ( Eq k
, Hashable k
) => Extend (PathChunk k 'Nothing) (RootedPredTrie k a) (RootedPredTrie k a) where
extend (Lit t) (RootedPredTrie mx xs) = RootedPredTrie Nothing $
PredTrie (HT.HashMapStep $! HM.singleton t (HT.HashMapChildren mx $ Just xs)) mempty
instance ( Eq k
, Hashable k
, Typeable r
) => Extend (PathChunk k ('Just r)) (RootedPredTrie k (r -> a)) (RootedPredTrie k a) where
extend (Pred' i q) (RootedPredTrie mx xs) = RootedPredTrie Nothing $
PredTrie mempty (PredStep (HM.singleton i (Pred q mx xs)))
class Extrude chunks start result | chunks start -> result where
extrude :: chunks -> start -> result
instance Extrude (PathChunks k '[]) (RootedPredTrie k a) (RootedPredTrie k a) where
extrude Nil r = r
instance ( Extrude (PathChunks k xs) trie0 trie1
, Extend (PathChunk k x) trie1 trie2
) => Extrude (PathChunks k (x ': xs)) trie0 trie2 where
extrude (Cons u us) r = extend u $! extrude us r
type ExtrudeSoundly k cleanxs xs c r =
( cleanxs ~ CatMaybes xs
, ArityTypeListIso c cleanxs r
, Extrude (PathChunks k xs)
(RootedPredTrie k c)
(RootedPredTrie k r)
)
only :: k -> PathChunk k 'Nothing
only = Lit
pred :: k -> (k -> Maybe r) -> PathChunk k ('Just r)
pred = Pred'
data PathChunk k (mx :: Maybe *) where
Lit :: { litChunk :: !k
} -> PathChunk k 'Nothing
Pred' :: { predTag :: !k
, predPred :: !(k -> Maybe r)
} -> PathChunk k ('Just r)
instance IsString k => IsString (PathChunk k 'Nothing) where
fromString = Lit . fromString
data PathChunks k (xs :: [Maybe *]) where
Cons :: PathChunk k mx
-> PathChunks k xs
-> PathChunks k (mx ': xs)
Nil :: PathChunks k '[]
(./) :: PathChunk k mx -> PathChunks k xs -> PathChunks k (mx ': xs)
(./) = Cons
infixr 9 ./
nil :: PathChunks k '[]
nil = Nil