{-# 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.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)

-- | 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
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

-- | 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
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)

-- | 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 = 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

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

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

-- | 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 :: 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)
                        ]

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

-- | 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 :: 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)

-- | 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 :: 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

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

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