{-# OPTIONS_HADDOCK hide #-}
-- This makes a kind of tri. Has space efficiency issues with large
-- input blocks. Likely building a parser and just applying that would
-- be better.
module Graphics.Vty.Input.Classify
  ( classify
  , KClass(..)
  )
where

import Graphics.Vty.Input.Events
import Graphics.Vty.Input.Mouse
import Graphics.Vty.Input.Focus
import Graphics.Vty.Input.Paste
import Graphics.Vty.Input.Classify.Types

import Codec.Binary.UTF8.Generic (decode)

import Data.List (inits)
import qualified Data.Map as M( fromList, lookup )
import Data.Maybe ( mapMaybe )
import qualified Data.Set as S( fromList, member )

import Data.Char
import Data.Word

compile :: ClassifyMap -> [Char] -> KClass
compile :: ClassifyMap -> [Char] -> KClass
compile ClassifyMap
table = [Char] -> KClass
cl' where
    -- take all prefixes and create a set of these
    prefixSet :: Set [Char]
prefixSet = [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
S.fromList ([[Char]] -> Set [Char]) -> [[Char]] -> Set [Char]
forall a b. (a -> b) -> a -> b
$ (([Char], Event) -> [[Char]]) -> ClassifyMap -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([[Char]] -> [[Char]]
forall a. [a] -> [a]
init ([[Char]] -> [[Char]])
-> (([Char], Event) -> [[Char]]) -> ([Char], Event) -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
forall a. [a] -> [[a]]
inits ([Char] -> [[Char]])
-> (([Char], Event) -> [Char]) -> ([Char], Event) -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], Event) -> [Char]
forall a b. (a, b) -> a
fst) (ClassifyMap -> [[Char]]) -> ClassifyMap -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ClassifyMap
table
    maxValidInputLength :: Int
maxValidInputLength = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((([Char], Event) -> Int) -> ClassifyMap -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int)
-> (([Char], Event) -> [Char]) -> ([Char], Event) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], Event) -> [Char]
forall a b. (a, b) -> a
fst) ClassifyMap
table)
    eventForInput :: Map [Char] Event
eventForInput = ClassifyMap -> Map [Char] Event
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ClassifyMap
table
    cl' :: [Char] -> KClass
cl' [] = KClass
Prefix
    cl' [Char]
inputBlock = case [Char] -> Map [Char] Event -> Maybe Event
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
inputBlock Map [Char] Event
eventForInput of
            -- if the inputBlock is exactly what is expected for an
            -- event then consume the whole block and return the event
            Just Event
e -> Event -> [Char] -> KClass
Valid Event
e []
            Maybe Event
Nothing -> case [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member [Char]
inputBlock Set [Char]
prefixSet of
                Bool
True -> KClass
Prefix
                -- look up progressively smaller tails of the input
                -- block until an event is found The assumption is that
                -- the event that consumes the most input bytes should
                -- be produced.
                -- The test verifyFullSynInputToEvent2x verifies this.
                -- H: There will always be one match. The prefixSet
                -- contains, by definition, all prefixes of an event.
                Bool
False ->
                    let inputPrefixes :: [[Char]]
inputPrefixes = [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
take Int
maxValidInputLength ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
forall a. [a] -> [a]
tail ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
forall a. [a] -> [[a]]
inits [Char]
inputBlock
                    in case ([Char] -> Maybe ([Char], Event)) -> [[Char]] -> ClassifyMap
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\[Char]
s -> (,) [Char]
s (Event -> ([Char], Event)) -> Maybe Event -> Maybe ([Char], Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [Char] -> Map [Char] Event -> Maybe Event
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
s Map [Char] Event
eventForInput) [[Char]]
inputPrefixes of
                        ([Char]
s,Event
e) : ClassifyMap
_ -> Event -> [Char] -> KClass
Valid Event
e (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s) [Char]
inputBlock)
                        -- neither a prefix or a full event.
                        [] -> KClass
Invalid

classify :: ClassifyMap -> [Char] -> KClass
classify :: ClassifyMap -> [Char] -> KClass
classify ClassifyMap
table =
    let standardClassifier :: [Char] -> KClass
standardClassifier = ClassifyMap -> [Char] -> KClass
compile ClassifyMap
table
    in \[Char]
s -> case [Char]
s of
        [Char]
_ | [Char] -> Bool
bracketedPasteStarted [Char]
s ->
            if [Char] -> Bool
bracketedPasteFinished [Char]
s
            then [Char] -> KClass
parseBracketedPaste [Char]
s
            else KClass
Prefix
        [Char]
_ | [Char] -> Bool
isMouseEvent [Char]
s   -> [Char] -> KClass
classifyMouseEvent [Char]
s
        [Char]
_ | [Char] -> Bool
isFocusEvent [Char]
s   -> [Char] -> KClass
classifyFocusEvent [Char]
s
        Char
c:[Char]
cs | Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0xC2 -> Char -> [Char] -> KClass
classifyUtf8 Char
c [Char]
cs
        [Char]
_                    -> [Char] -> KClass
standardClassifier [Char]
s

classifyUtf8 :: Char -> [Char] -> KClass
classifyUtf8 :: Char -> [Char] -> KClass
classifyUtf8 Char
c [Char]
cs =
  let n :: Int
n = Int -> Int
forall t a. (Num t, Ord a, Num a) => a -> t
utf8Length (Char -> Int
ord Char
c)
      ([Char]
codepoint,[Char]
rest) = Int -> [Char] -> ([Char], [Char])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
cs)

      codepoint8 :: [Word8]
      codepoint8 :: [Word8]
codepoint8 = (Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) [Char]
codepoint

  in case [Word8] -> Maybe (Char, Int)
forall b s. UTF8Bytes b s => b -> Maybe (Char, s)
decode [Word8]
codepoint8 of
       Maybe (Char, Int)
_ | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
codepoint -> KClass
Prefix
       Just (Char
unicodeChar, Int
_)    -> Event -> [Char] -> KClass
Valid (Key -> [Modifier] -> Event
EvKey (Char -> Key
KChar Char
unicodeChar) []) [Char]
rest
       -- something bad happened; just ignore and continue.
       Maybe (Char, Int)
Nothing                  -> KClass
Invalid

utf8Length :: (Num t, Ord a, Num a) => a -> t
utf8Length :: a -> t
utf8Length a
c
    | a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0x80 = t
1
    | a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0xE0 = t
2
    | a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0xF0 = t
3
    | Bool
otherwise = t
4