summaryrefslogtreecommitdiffstats
path: root/Scanner.hs
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2015-10-17 03:10:15 +0200
committertv <tv@shackspace.de>2015-10-17 03:11:22 +0200
commit045dc986b4de225a927175f81c8ccfdab450202c (patch)
tree36a08119349dac5f415cd05b846b5aa76d68fb91 /Scanner.hs
parentbfd854e05207a073eaa983c49f27c37555ccfce5 (diff)
Use external Blessings and Scanner libraries
Diffstat (limited to 'Scanner.hs')
-rw-r--r--Scanner.hs141
1 files changed, 0 insertions, 141 deletions
diff --git a/Scanner.hs b/Scanner.hs
deleted file mode 100644
index df48868..0000000
--- a/Scanner.hs
+++ /dev/null
@@ -1,141 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-module Scanner
- ( scan
- ) where
-
-import Data.Bits ((.&.), testBit)
-import Data.Char (ord)
-import Data.Word (Word8)
-import Event
-import System.IO (Handle, hGetChar, hLookAhead, hWaitForInput)
-
-
-timeout :: Int
-timeout = 1
-
-
-scan :: Handle -> IO Event
-scan h =
- hGetChar h >>= \case
- '\ESC' -> scanESC h
- c -> return $ EKey [c]
-
-
-
-scanESC :: Handle -> IO Event
-scanESC h =
- hWaitGetChar timeout h >>= \case
- Nothing -> return $ EKey "\ESC"
- Just c
- | c == '[' -> -- 05/11
- scanCS h
- | c == '\ESC' -> -- 01/11
- -- XXX M-F1 and other crazy chords may cause
- -- \ESC\ESC... on wu, so we just recurse here...
- scanESC h
- | c == 'O' -> -- 04/15
- -- XXX Non-CSI SS3
- -- XXX finalByte is maybe calles somehow else here, but it's
- -- the same range
- one h finalByte ['O','\ESC'] >>=
- return . EKey . reverse
- | otherwise ->
- return $ EKey ['\ESC',c]
-
-
-scanCS :: Handle -> IO Event
-scanCS h =
- hWaitLookAhead timeout h >>= \case
- Nothing -> return $ EKey "\ESC" -- TODO move this to scanESC
- Just c
- | c == 'M' -> do
- _ <- hGetChar h -- drop 'M'
- b <- hGetChar h
- x <- hGetChar h
- y <- hGetChar h
- return $ parseNormalButton b x y
- | otherwise ->
- zeroOrMore h parameterByte ['[', '\ESC'] >>=
- zeroOrMore h intermediateByte >>=
- one h finalByte >>=
- return . EKey . reverse
-
-
-
-zeroOrMore :: Handle -> (Char -> Bool) -> [Char] -> IO [Char]
-zeroOrMore h p buf =
- hWaitLookAhead timeout h >>= \case
- Nothing -> return buf
- Just c
- | p c ->
- hGetChar h {-drop c-} >> zeroOrMore h p (c:buf)
- | otherwise ->
- return buf
-
-
-one :: Handle -> (Char -> Bool) -> [Char] -> IO [Char]
-one h p buf =
- hWaitLookAhead timeout h >>= \case
- Nothing -> return buf -- TODO error?
- Just c
- | p c -> do
- _ <- hGetChar h -- drop c
- return (c:buf)
- | otherwise ->
- error "expected one TODO"
-
-
-parameterByte :: Char -> Bool
-parameterByte = between '0' '?' -- 03/00 03/15
-
-intermediateByte :: Char -> Bool
-intermediateByte = between ' ' '/' -- 02/00 02/15
-
-finalByte :: Char -> Bool
-finalByte = between '@' '~' -- 04/00 07/14
-
-
-between :: Ord a => a -> a -> (a -> Bool)
-between lo hi = \ x -> lo <= x && x <= hi
-
-
-hWaitGetChar :: Int -> Handle -> IO (Maybe Char)
-hWaitGetChar t h = do
- ready <- hWaitForInput h t
- if ready
- then hGetChar h >>= return . Just
- else return Nothing
-
-
-hWaitLookAhead :: Int -> Handle -> IO (Maybe Char)
-hWaitLookAhead t h = do
- ready <- hWaitForInput h t
- if ready
- then hLookAhead h >>= return . Just
- else return Nothing
-
-
-parseNormalButton :: Char -> Char -> Char -> Event
-parseNormalButton cb cx cy = do
- let b = fromIntegral $ ord cb :: Word8
- x = ord cx - 32
- y = ord cy - 32
- button = case (b .&. 3) + (b .&. 64) of
- 0 -> 1
- 1 -> 2
- 2 -> 3
- 3 -> 0 -- release
- 64 -> 4 -- wheel up
- 65 -> 5 -- wheel down
- 66 -> 6 -- wheel left
- 67 -> 7 -- wheel right
- _ -> error "TODO proper parseNormalButton error"
- EMouse $ MouseInfo
- { mouseButton = button
- , mouseShift = testBit b 2
- , mouseMeta = testBit b 3
- , mouseControl = testBit b 4
- , mouseX = x
- , mouseY = y
- }