    {-# 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 table :: 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' inputBlock :: [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 e :: Event
    e -> Event -> [Char] -> KClass
    Valid Event
    e []
                Nothing -> case [Char] -> Set [Char] -> Bool
    forall a. Ord a => a -> Set a -> Bool
    S.member [Char]
    inputBlock Set [Char]
    prefixSet of
                    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.
                    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 (\s :: [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
                            (s :: [Char]
    s,e :: Event
    e) : _ -> 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 table :: ClassifyMap
    table =
        let standardClassifier :: [Char] -> KClass
    standardClassifier = ClassifyMap -> [Char] -> KClass
    compile ClassifyMap
    table
        in \s :: [Char]
    s -> case [Char]
    s of
            _ | [Char] -> Bool
    bracketedPasteStarted [Char]
    s ->
                if [Char] -> Bool
    bracketedPasteFinished [Char]
    s
                then [Char] -> KClass
    parseBracketedPaste [Char]
    s
                else KClass
    Prefix
            _ | [Char] -> Bool
    isMouseEvent [Char]
    s   -> [Char] -> KClass
    classifyMouseEvent [Char]
    s
            _ | [Char] -> Bool
    isFocusEvent [Char]
    s   -> [Char] -> KClass
    classifyFocusEvent [Char]
    s
            c :: Char
    c:cs :: [Char]
    cs | Char -> Int
    ord Char
    c Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= 0xC2 -> Char -> [Char] -> KClass
    classifyUtf8 Char
    c [Char]
    cs
            _                    -> [Char] -> KClass
    standardClassifier [Char]
    s

    classifyUtf8 :: Char -> [Char] -> KClass
    classifyUtf8 :: Char -> [Char] -> KClass
    classifyUtf8 c :: Char
    c cs :: [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)
          (codepoint :: [Char]
    codepoint,rest :: [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
           _ | 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 (unicodeChar :: Char
    unicodeChar, _)    -> Event -> [Char] -> KClass
    Valid (Key -> [Modifier] -> Event
    EvKey (Char -> Key
    KChar Char
    unicodeChar) []) [Char]
    rest
           -- something bad happened; just ignore and continue.
           Nothing                  -> KClass
    Invalid

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