{-# Language OverloadedStrings, DeriveTraversable #-}

{-|
Module      : Client.Commands.Recognizer
Description : Trie for recognizing commands
Copyright   : (c) Dan Doel, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module implements a trie for recognizing valid commands. This
allows entered strings to be classified as either a valid command
(with an associated value), the prefix of a valid command, or invalid.
-}

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)

-- | A map from 'Text' values to 'a' values that is capable of yielding more
-- detailed information when looking up keys that are not actually in the map.
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

-- | Possible results of recognizing text.
data Recognition a
  = Exact a       -- ^ text matched exactly, yielding the given value
  | Prefix [Text] -- ^ text would be recognized if joined to the given suffixes
  | Invalid       -- ^ text could not possibly be recognized
  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)

-- | Match common prefixes of two strings in a more convenient form than
-- available from 'Data.Text'
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

-- | Attempt to recognize a string, yielding a 'Recognition' result.
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

-- | Create a singleton 'Recognizer' associating the given 'Text' and value.
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

-- | Union two 'Recognizers'. The stored values in the result are biased to the
-- left if there is key overlap.
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)
                        ]

-- | Union an arbitrary number of 'Recognizers' as with 'both'.
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

-- | Create a 'Recognizer' from an association list. If a key appears twice, the
-- earliest associated value will be used.
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)

-- | Add a key-value pair to a 'Recognizer'. This will override the value
-- already present if one exists.
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

-- | Compute all strings that will be recognized by a 'Recognizer'.
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)

-- | Auxiliary function for 'keys'.
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