rewrite Scanner to use Event

1 files changed, 80 insertions, 203 deletions

diff --git a/src/Scanner.hs b/src/Scanner.hs
index 3c96a6e..361a1c6 100644
--- a/src/Scanner.hs
+++ b/src/Scanner.hs
@@ -1,217 +1,102 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Scanner
-    ( getKey
-    , hGetKey
+    ( scan
     ) where
 
-import Prelude hiding ((/))
-import Control.Applicative
-import Control.Monad.Error
-import Control.Monad.State
-import Control.Monad.Writer
-import Data.Bits
-import Data.Char
-import System.IO
+import Data.Char (ord)
+import Event
+import System.IO (Handle, hGetChar, hLookAhead, hWaitForInput)
 
 
--- high level interface
-
-getKey :: IO String
-getKey = hGetKey stdin
-
-hGetKey :: Handle -> IO String
-hGetKey h = do
-    _ <- hLookAhead h -- wait for input
-    ((_, raw_s), _) <- runScanner $ scan h
-    return $ map toChar raw_s
-
-
-
-type P = C
-type I = C
-type F = C
-
-
-data Token
-    = CS [P] [I] F
-    | Chr C
-  deriving (Show)
-
-
-type ScanLog = [C]
-
-
-type ScanError = String
-
-
-data ScanState = ScanState
-    { _result :: Maybe Token -- TODO underscore supresses warning, rename before usage..
-    , buffer :: [C]
-    }
-
-
-emptyScanState :: ScanState
-emptyScanState = ScanState Nothing []
-
-
-newtype Scanner m a = Scanner
-    (ErrorT ScanError (WriterT ScanLog (StateT ScanState m)) a)
-  deriving
-    ( Applicative
-    , Functor
-    , Monad
-    , MonadIO
-    , MonadState ScanState
-    , MonadError ScanError
-    , MonadWriter ScanLog
-    )
-
-
-runScanner :: Scanner m a -> m ((Either ScanError a, ScanLog), ScanState)
-runScanner (Scanner a) =
-    runStateT (runWriterT (runErrorT a)) emptyScanState
-
-
--- TODO max timeout
 timeout :: Int
 timeout = 1
 
 
-scan, scanESC, scanCS ::
-    ( Monad m
-    , MonadIO m
-    , MonadError ScanError m
-    , MonadState ScanState m
-    , MonadWriter ScanLog m
-    )
-    => Handle
-    -> m ()
-
-scan h = do
-    c <- liftIO $ hGetC h
-    tell [c]
-    case () of _
-                | c == 01/11 -> scanESC h
-                | otherwise -> return ()
-
-
-scanESC h = do
-    mb_c <- liftIO $ hWaitGetC timeout h
-    whenJust mb_c $ \ c -> do
-        tell [c]
-        case () of _
-                    | c == 05/11 ->
-                        -- CSI
-                        scanCS h
-
-                    | c == 01/11 ->
-                        -- XXX M-F1 and other crazy chords may cause
-                        -- \ESC\ESC... on wu, so we just recurse here...
-                        scanESC h
-
-                    | c == 04/15 ->
-                        -- XXX Non-CSI SS3
-                        one h $ between (04/00) (07/14)
-
-                    | otherwise -> return ()
-
-
-scanCS h = do
-    zeroOrMore h $ between (03/00) (03/15)    -- parameter bytes
-    zeroOrMore h $ between (02/00) (02/15)    -- intermediate bytes
-    one h $ between (04/00) (07/14)           -- final byte
-
-
-between :: C -> C -> (C -> Bool)
-between lo hi = \ x -> lo <= x && x <= hi
-
-
-zeroOrMore, one ::
-    ( Monad m
-    , MonadIO m
-    , MonadError ScanError m
-    , MonadState ScanState m
-    , MonadWriter ScanLog m
-    )
-    => Handle
-    -> (C -> Bool)
-    -> m ()
-
-zeroOrMore h p = do
-    mb_c <- liftIO $ hWaitLookAheadC timeout h
-    whenJust mb_c $ \ c ->
-        when (p c) $ do
-            _ <- liftIO $ hGetC h -- drop
-            tell [c]
-            modify $ \q -> q { buffer = buffer q ++ [c] }
-            zeroOrMore h p
-
-
-one h p = do
-    mb_c <- liftIO $ hWaitLookAheadC timeout h
-    whenJust mb_c $ \ c -> do
-        if p c
-            then do
-                _ <- liftIO getChar
-                tell [c]
-                modify $ \q -> q { buffer = buffer q ++ [c] }
-            else do
-                throwError "expected one TODO"
-
-
-
-
-
-
-
-
-whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
-whenJust mb f =
-    case mb of
-        Just a -> f a
-        Nothing -> return ()
-
-
-
-(/) :: Int -> Int -> C
-c / r = C c r
+scan :: Handle -> IO Event
+scan h =
+    hGetChar h >>= \case
+        '\ESC' -> scanESC h
+        c -> return $ EKey [c]
+
 
 
-data C = C { column :: Int, row :: Int }
-    deriving (Eq)
+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
+                -- VT200 mouse
+                _ <- hGetChar h -- drop 'M'
+                b <- hGetChar h
+                x <- hGetChar h
+                y <- hGetChar h
+                return $ EMouse b (ord x - 32) (ord y - 32)
+            | otherwise ->
+                zeroOrMore h parameterByte ['[', '\ESC'] >>=
+                zeroOrMore h intermediateByte >>=
+                one h finalByte >>=
+                return . EKey . reverse
+
 
 
-instance Show C where
-  show C{..} = 
-      (padl 2 '0' $ show column) ++ "/" ++ (padl 2 '0' $ show row)
-    where
-      padl n c s
-        | length s < n = padl n c (c : s)
-        | otherwise = s
+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
 
 
-instance Ord C where
-    compare (C c1 r1) (C c2 r2) =
-        case compare c1 c2 of
-            EQ -> compare r1 r2
-            x -> x
+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"
 
 
-fromChar :: Char -> C
-fromChar c = let i = ord c in C ((shift i (-4)) .&. 0xf) (i .&. 0xf)
+parameterByte :: Char -> Bool
+parameterByte = between '0' '?'     -- 03/00 03/15
 
-toChar :: C -> Char
-toChar (C col row) = chr $ (shift col 4) .|. row
+intermediateByte :: Char -> Bool
+intermediateByte = between ' ' '/'  -- 02/00 02/15
 
-
---
+finalByte :: Char -> Bool
+finalByte = between '@' '~'         -- 04/00 07/14
 
 
-hGetC :: Handle -> IO C
-hGetC h = hGetChar h >>= return . fromChar
+between :: Ord a => a -> a -> (a -> Bool)
+between lo hi = \ x -> lo <= x && x <= hi
 
 
 hWaitGetChar :: Int -> Handle -> IO (Maybe Char)
@@ -222,17 +107,9 @@ hWaitGetChar t h = do
         else return Nothing
 
 
-hWaitGetC :: Int -> Handle -> IO (Maybe C)
-hWaitGetC t h = do
-    mb_ch <- hWaitGetChar t h
-    case mb_ch of
-        Nothing -> return Nothing
-        Just ch -> return $ Just $ fromChar $ ch
-
-
-hWaitLookAheadC :: Int -> Handle -> IO (Maybe C)
-hWaitLookAheadC t h = do
+hWaitLookAhead :: Int -> Handle -> IO (Maybe Char)
+hWaitLookAhead t h = do
     ready <- hWaitForInput h t
     if ready
-        then hLookAhead h >>= return . Just . fromChar
+        then hLookAhead h >>= return . Just
         else return Nothing