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