{-# 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 -> String -> KClass
compile :: ClassifyMap -> String -> KClass
compile ClassifyMap
table = String -> KClass
cl' where
    -- take all prefixes and create a set of these
    prefixSet :: Set String
prefixSet = [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$ ((String, Event) -> [String]) -> ClassifyMap -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([String] -> [String]
forall a. [a] -> [a]
init ([String] -> [String])
-> ((String, Event) -> [String]) -> (String, Event) -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
forall a. [a] -> [[a]]
inits (String -> [String])
-> ((String, Event) -> String) -> (String, Event) -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Event) -> String
forall a b. (a, b) -> a
fst) ClassifyMap
table
    maxValidInputLength :: Int
maxValidInputLength = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (((String, Event) -> Int) -> ClassifyMap -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ((String, Event) -> String) -> (String, Event) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Event) -> String
forall a b. (a, b) -> a
fst) ClassifyMap
table)
    eventForInput :: Map String Event
eventForInput = ClassifyMap -> Map String Event
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ClassifyMap
table
    cl' :: String -> KClass
cl' [] = KClass
Prefix
    cl' String
inputBlock = case String -> Map String Event -> Maybe Event
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
inputBlock Map String 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 -> String -> KClass
Valid Event
e []
            Maybe Event
Nothing -> case String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member String
inputBlock Set String
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 :: [String]
inputPrefixes = [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
maxValidInputLength ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
tail ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
forall a. [a] -> [[a]]
inits String
inputBlock
                    in case (String -> Maybe (String, Event)) -> [String] -> ClassifyMap
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\String
s -> (,) String
s (Event -> (String, Event)) -> Maybe Event -> Maybe (String, Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Map String Event -> Maybe Event
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
s Map String Event
eventForInput) [String]
inputPrefixes of
                        (String
s,Event
e) : ClassifyMap
_ -> Event -> String -> KClass
Valid Event
e (Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) String
inputBlock)
                        -- neither a prefix or a full event.
                        [] -> KClass
Invalid

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

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

      codepoint8 :: [Word8]
      codepoint8 :: [Word8]
codepoint8 = (Char -> Word8) -> String -> [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) String
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
< String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
codepoint -> KClass
Prefix
       Just (Char
unicodeChar, Int
_)    -> Event -> String -> KClass
Valid (Key -> [Modifier] -> Event
EvKey (Char -> Key
KChar Char
unicodeChar) []) String
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