module Graphics.Vty.Input.Classify
( classify
, KClass(..)
) where
import Graphics.Vty.Input.Events
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
data KClass
= Valid Event [Char]
| Invalid
| Prefix
deriving(Show, Eq)
compile :: ClassifyMap -> [Char] -> KClass
compile table = cl' where
prefixSet = S.fromList $ concatMap (init . inits . fst) $ table
maxValidInputLength = maximum (map (length . fst) table)
eventForInput = M.fromList table
cl' [] = Prefix
cl' inputBlock = case M.lookup inputBlock eventForInput of
Just e -> Valid e []
Nothing -> case S.member inputBlock prefixSet of
True -> Prefix
False ->
let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock
in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of
(s,e) : _ -> Valid e (drop (length s) inputBlock)
[] -> Invalid
classify :: ClassifyMap -> [Char] -> KClass
classify table =
let standardClassifier = compile table
in \s -> case s of
(c:_) | ord c >= 0xC2 && utf8Length (ord c) > length s -> Prefix
(c:_) | ord c >= 0xC2 -> classifyUtf8 s
_ -> standardClassifier s
classifyUtf8 :: [Char] -> KClass
classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of
Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) []
_ -> Invalid
utf8Length :: (Num t, Ord a, Num a) => a -> t
utf8Length c
| c < 0x80 = 1
| c < 0xE0 = 2
| c < 0xF0 = 3
| otherwise = 4