{-# Language OverloadedStrings, DeriveTraversable #-}
module Client.Commands.Recognizer
( Recognizer
, recognize
, Recognition(..)
, fromCommands
, addCommand
, keys
) where
import Control.Applicative hiding (empty)
import Control.Monad (guard)
import Data.HashMap.Strict (lookup,insertWith,HashMap,empty,unionWith,fromList,toList)
import Data.Maybe (fromMaybe, maybeToList)
import Data.Text (Text)
import Data.Text qualified as Text
import Prelude hiding (all,lookup)
data Recognizer a
= Branch !Text !(Maybe a) !(HashMap Char (Recognizer a))
deriving (Int -> Recognizer a -> ShowS
forall a. Show a => Int -> Recognizer a -> ShowS
forall a. Show a => [Recognizer a] -> ShowS
forall a. Show a => Recognizer a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Recognizer a] -> ShowS
$cshowList :: forall a. Show a => [Recognizer a] -> ShowS
show :: Recognizer a -> String
$cshow :: forall a. Show a => Recognizer a -> String
showsPrec :: Int -> Recognizer a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Recognizer a -> ShowS
Show, forall a b. a -> Recognizer b -> Recognizer a
forall a b. (a -> b) -> Recognizer a -> Recognizer b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Recognizer b -> Recognizer a
$c<$ :: forall a b. a -> Recognizer b -> Recognizer a
fmap :: forall a b. (a -> b) -> Recognizer a -> Recognizer b
$cfmap :: forall a b. (a -> b) -> Recognizer a -> Recognizer b
Functor, forall a. Eq a => a -> Recognizer a -> Bool
forall a. Num a => Recognizer a -> a
forall a. Ord a => Recognizer a -> a
forall m. Monoid m => Recognizer m -> m
forall a. Recognizer a -> Bool
forall a. Recognizer a -> Int
forall a. Recognizer a -> [a]
forall a. (a -> a -> a) -> Recognizer a -> a
forall m a. Monoid m => (a -> m) -> Recognizer a -> m
forall b a. (b -> a -> b) -> b -> Recognizer a -> b
forall a b. (a -> b -> b) -> b -> Recognizer a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Recognizer a -> a
$cproduct :: forall a. Num a => Recognizer a -> a
sum :: forall a. Num a => Recognizer a -> a
$csum :: forall a. Num a => Recognizer a -> a
minimum :: forall a. Ord a => Recognizer a -> a
$cminimum :: forall a. Ord a => Recognizer a -> a
maximum :: forall a. Ord a => Recognizer a -> a
$cmaximum :: forall a. Ord a => Recognizer a -> a
elem :: forall a. Eq a => a -> Recognizer a -> Bool
$celem :: forall a. Eq a => a -> Recognizer a -> Bool
length :: forall a. Recognizer a -> Int
$clength :: forall a. Recognizer a -> Int
null :: forall a. Recognizer a -> Bool
$cnull :: forall a. Recognizer a -> Bool
toList :: forall a. Recognizer a -> [a]
$ctoList :: forall a. Recognizer a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Recognizer a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Recognizer a -> a
foldr1 :: forall a. (a -> a -> a) -> Recognizer a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Recognizer a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Recognizer a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Recognizer a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Recognizer a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Recognizer a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Recognizer a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Recognizer a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Recognizer a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Recognizer a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Recognizer a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Recognizer a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Recognizer a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Recognizer a -> m
fold :: forall m. Monoid m => Recognizer m -> m
$cfold :: forall m. Monoid m => Recognizer m -> m
Foldable)
instance Monoid (Recognizer a) where
mempty :: Recognizer a
mempty = forall a.
Text -> Maybe a -> HashMap Char (Recognizer a) -> Recognizer a
Branch Text
"" forall a. Maybe a
Nothing forall k v. HashMap k v
empty
instance Semigroup (Recognizer a) where
<> :: Recognizer a -> Recognizer a -> Recognizer a
(<>) = forall a. Recognizer a -> Recognizer a -> Recognizer a
both
data Recognition a
= Exact a
| Prefix [Text]
| Invalid
deriving (Int -> Recognition a -> ShowS
forall a. Show a => Int -> Recognition a -> ShowS
forall a. Show a => [Recognition a] -> ShowS
forall a. Show a => Recognition a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Recognition a] -> ShowS
$cshowList :: forall a. Show a => [Recognition a] -> ShowS
show :: Recognition a -> String
$cshow :: forall a. Show a => Recognition a -> String
showsPrec :: Int -> Recognition a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Recognition a -> ShowS
Show, forall a b. a -> Recognition b -> Recognition a
forall a b. (a -> b) -> Recognition a -> Recognition b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Recognition b -> Recognition a
$c<$ :: forall a b. a -> Recognition b -> Recognition a
fmap :: forall a b. (a -> b) -> Recognition a -> Recognition b
$cfmap :: forall a b. (a -> b) -> Recognition a -> Recognition b
Functor)
splitCommon :: Text -> Text -> (Text, Text, Text)
splitCommon :: Text -> Text -> (Text, Text, Text)
splitCommon Text
l Text
r = forall a. a -> Maybe a -> a
fromMaybe (Text
"", Text
l, Text
r) forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe (Text, Text, Text)
Text.commonPrefixes Text
l Text
r
recognize :: Text -> Recognizer a -> Recognition a
recognize :: forall a. Text -> Recognizer a -> Recognition a
recognize Text
tx (Branch Text
pf Maybe a
contained HashMap Char (Recognizer a)
children)
= case Text -> Text -> (Text, Text, Text)
splitCommon Text
pf Text
tx of
(Text
_, Text
pfsfx, Text
txsfx) -> case Text -> Maybe (Char, Text)
Text.uncons Text
txsfx of
Maybe (Char, Text)
Nothing
| Text -> Bool
Text.null Text
pfsfx
, Just a
a <- Maybe a
contained -> forall a. a -> Recognition a
Exact a
a
| Bool
otherwise -> forall a. [Text] -> Recognition a
Prefix forall a b. (a -> b) -> a -> b
$ forall a. Recognizer a -> [Text]
keys (forall a.
Text -> Maybe a -> HashMap Char (Recognizer a) -> Recognizer a
Branch Text
pfsfx Maybe a
contained HashMap Char (Recognizer a)
children)
Just (Char
c, Text
txrest)
| Text -> Bool
Text.null Text
pfsfx
, Just Recognizer a
rec <- forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
lookup Char
c HashMap Char (Recognizer a)
children
-> forall a. Text -> Recognizer a -> Recognition a
recognize Text
txrest Recognizer a
rec
Maybe (Char, Text)
_ -> forall a. Recognition a
Invalid
single :: Text -> a -> Recognizer a
single :: forall a. Text -> a -> Recognizer a
single Text
tx a
v = forall a.
Text -> Maybe a -> HashMap Char (Recognizer a) -> Recognizer a
Branch Text
tx (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! a
v) forall k v. HashMap k v
empty
both :: Recognizer a -> Recognizer a -> Recognizer a
both :: forall a. Recognizer a -> Recognizer a -> Recognizer a
both l :: Recognizer a
l@(Branch Text
pfl Maybe a
conl HashMap Char (Recognizer a)
chil) r :: Recognizer a
r@(Branch Text
pfr Maybe a
conr HashMap Char (Recognizer a)
chir)
| Text -> Bool
Text.null Text
pfl Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe a
conl Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null HashMap Char (Recognizer a)
chil = Recognizer a
r
| Text -> Bool
Text.null Text
pfr Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe a
conr Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null HashMap Char (Recognizer a)
chir = Recognizer a
l
| Bool
otherwise
= case Text -> Text -> (Text, Text, Text)
splitCommon Text
pfl Text
pfr of
(Text
common, Text
lsfx, Text
rsfx) -> forall a.
Text -> Maybe a -> HashMap Char (Recognizer a) -> Recognizer a
Branch Text
common Maybe a
contained HashMap Char (Recognizer a)
children
where
contained :: Maybe a
contained = (forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> Bool
Text.null Text
lsfx) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe a
conl)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> Bool
Text.null Text
rsfx) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe a
conr)
children :: HashMap Char (Recognizer a)
children = case (Text -> Maybe (Char, Text)
Text.uncons Text
lsfx, Text -> Maybe (Char, Text)
Text.uncons Text
rsfx) of
(Maybe (Char, Text)
Nothing, Maybe (Char, Text)
Nothing)
-> forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
unionWith forall a. Recognizer a -> Recognizer a -> Recognizer a
both HashMap Char (Recognizer a)
chil HashMap Char (Recognizer a)
chir
(Just (Char
l',Text
lest), Maybe (Char, Text)
Nothing)
-> forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
insertWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Recognizer a -> Recognizer a -> Recognizer a
both) Char
l' (forall a.
Text -> Maybe a -> HashMap Char (Recognizer a) -> Recognizer a
Branch Text
lest Maybe a
conl HashMap Char (Recognizer a)
chil) HashMap Char (Recognizer a)
chir
(Maybe (Char, Text)
Nothing, Just (Char
r',Text
rest))
-> forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
insertWith forall a. Recognizer a -> Recognizer a -> Recognizer a
both Char
r' (forall a.
Text -> Maybe a -> HashMap Char (Recognizer a) -> Recognizer a
Branch Text
rest Maybe a
conr HashMap Char (Recognizer a)
chir) HashMap Char (Recognizer a)
chil
(Just (Char
l',Text
lest), Just (Char
r',Text
rest))
-> forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
fromList [ (Char
l', forall a.
Text -> Maybe a -> HashMap Char (Recognizer a) -> Recognizer a
Branch Text
lest Maybe a
conl HashMap Char (Recognizer a)
chil)
, (Char
r', forall a.
Text -> Maybe a -> HashMap Char (Recognizer a) -> Recognizer a
Branch Text
rest Maybe a
conr HashMap Char (Recognizer a)
chir)
]
all :: [Recognizer a] -> Recognizer a
all :: forall a. [Recognizer a] -> Recognizer a
all [] = forall a. Monoid a => a
mempty
all [Recognizer a
r] = Recognizer a
r
all [Recognizer a]
rs = forall a. [Recognizer a] -> Recognizer a
all forall a b. (a -> b) -> a -> b
$ forall {a}. [Recognizer a] -> [Recognizer a]
pair [Recognizer a]
rs
where
pair :: [Recognizer a] -> [Recognizer a]
pair (Recognizer a
l:Recognizer a
r:[Recognizer a]
rest) = forall a. Recognizer a -> Recognizer a -> Recognizer a
both Recognizer a
l Recognizer a
r forall a. a -> [a] -> [a]
: [Recognizer a] -> [Recognizer a]
pair [Recognizer a]
rest
pair [Recognizer a]
rest = [Recognizer a]
rest
fromCommands :: [(Text, a)] -> Recognizer a
fromCommands :: forall a. [(Text, a)] -> Recognizer a
fromCommands = forall a. [Recognizer a] -> Recognizer a
all forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Text -> a -> Recognizer a
single)
addCommand :: Text -> a -> Recognizer a -> Recognizer a
addCommand :: forall a. Text -> a -> Recognizer a -> Recognizer a
addCommand Text
tx a
v = forall a. Recognizer a -> Recognizer a -> Recognizer a
both forall a b. (a -> b) -> a -> b
$ forall a. Text -> a -> Recognizer a
single Text
tx a
v
keys :: Recognizer a -> [Text]
keys :: forall a. Recognizer a -> [Text]
keys (Branch Text
pf Maybe a
contained HashMap Char (Recognizer a)
children)
= forall a. Maybe a -> [a]
maybeToList (Text
pf forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe a
contained)
forall a. [a] -> [a] -> [a]
++ (forall a. Monoid a => a -> a -> a
mappend Text
pf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HashMap Char (Recognizer a) -> [Text]
childKeys HashMap Char (Recognizer a)
children)
childKeys :: HashMap Char (Recognizer a) -> [Text]
childKeys :: forall a. HashMap Char (Recognizer a) -> [Text]
childKeys HashMap Char (Recognizer a)
children = forall k v. HashMap k v -> [(k, v)]
toList HashMap Char (Recognizer a)
children forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Char
c,Recognizer a
rec) -> Char -> Text -> Text
Text.cons Char
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Recognizer a -> [Text]
keys Recognizer a
rec