{-# OPTIONS_HADDOCK hide #-}
-- This makes a kind of trie. 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(..)
  , ClassifierState(..)
  )
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 Control.Arrow (first)
import qualified Data.Map as M( fromList, lookup )
import Data.Maybe ( mapMaybe )
import qualified Data.Set as S( fromList, member )

import Data.Word

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Data.ByteString.Char8 (ByteString)

-- | Whether the classifier is currently processing a chunked format.
-- Currently, only bracketed pastes use this.
data ClassifierState
    = ClassifierStart
    -- ^ Not processing a chunked format.
    | ClassifierInChunk ByteString [ByteString]
    -- ^ Currently processing a chunked format. The initial chunk is in the
    -- first argument and a reversed remainder of the chunks is collected in
    -- the second argument. At the end of the processing, the chunks are
    -- reversed and concatenated with the final chunk.

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

classify :: ClassifyMap -> ClassifierState -> ByteString -> KClass
classify :: ClassifyMap -> ClassifierState -> ByteString -> KClass
classify ClassifyMap
table = ClassifierState -> ByteString -> KClass
process
    where
        standardClassifier :: ByteString -> KClass
standardClassifier = ClassifyMap -> ByteString -> KClass
compile ClassifyMap
table

        process :: ClassifierState -> ByteString -> KClass
process ClassifierState
ClassifierStart ByteString
s =
            case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
s of
                Maybe (Word8, ByteString)
_ | ByteString -> Bool
bracketedPasteStarted ByteString
s ->
                    if ByteString -> Bool
bracketedPasteFinished ByteString
s
                    then ByteString -> KClass
parseBracketedPaste ByteString
s
                    else KClass
Chunk
                Maybe (Word8, ByteString)
_ | ByteString -> Bool
isMouseEvent ByteString
s      -> ByteString -> KClass
classifyMouseEvent ByteString
s
                Maybe (Word8, ByteString)
_ | ByteString -> Bool
isFocusEvent ByteString
s      -> ByteString -> KClass
classifyFocusEvent ByteString
s
                Just (Word8
c,ByteString
cs) | Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
0xC2 -> Word8 -> ByteString -> KClass
classifyUtf8 Word8
c ByteString
cs
                Maybe (Word8, ByteString)
_                       -> ByteString -> KClass
standardClassifier ByteString
s

        process (ClassifierInChunk ByteString
p [ByteString]
ps) ByteString
s | ByteString -> Bool
bracketedPasteStarted ByteString
p =
            if ByteString -> Bool
bracketedPasteFinished ByteString
s
            then ByteString -> KClass
parseBracketedPaste forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.concat forall a b. (a -> b) -> a -> b
$ ByteString
pforall a. a -> [a] -> [a]
:forall a. [a] -> [a]
reverse (ByteString
sforall a. a -> [a] -> [a]
:[ByteString]
ps)
            else KClass
Chunk
        process ClassifierInChunk{} ByteString
_ = KClass
Invalid

classifyUtf8 :: Word8 -> ByteString -> KClass
classifyUtf8 :: Word8 -> ByteString -> KClass
classifyUtf8 Word8
c ByteString
cs =
  let n :: Int
n = Word8 -> Int
utf8Length Word8
c
      (ByteString
codepoint,ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
BS8.splitAt (Int
n forall a. Num a => a -> a -> a
- Int
1) ByteString
cs

      codepoint8 :: [Word8]
      codepoint8 :: [Word8]
codepoint8 = Word8
cforall a. a -> [a] -> [a]
:ByteString -> [Word8]
BS.unpack ByteString
codepoint

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

utf8Length :: Word8 -> Int
utf8Length :: Word8 -> Int
utf8Length Word8
c
    | Word8
c forall a. Ord a => a -> a -> Bool
< Word8
0x80 = Int
1
    | Word8
c forall a. Ord a => a -> a -> Bool
< Word8
0xE0 = Int
2
    | Word8
c forall a. Ord a => a -> a -> Bool
< Word8
0xF0 = Int
3
    | Bool
otherwise = Int
4