From 91e07794826e15fa8c764cb7869c2f16bb0d9677 Mon Sep 17 00:00:00 2001
From: tv <tv@shackspace.de>
Date: Mon, 28 Jul 2014 22:08:13 +0200
Subject: Scanner: initial commit (not activated)
---
src/Scanner.hs | 258 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 258 insertions(+)
create mode 100644 src/Scanner.hs
(limited to 'src')
diff --git a/src/Scanner.hs b/src/Scanner.hs
new file mode 100644
index 0000000..ba81abb
--- /dev/null
+++ b/src/Scanner.hs
@@ -0,0 +1,258 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Scanner where
+
+import Control.Monad (forever)
+import System.IO
+
+import Data.Ord
+import Data.Bits
+import Data.Char
+
+import Prelude hiding ((/))
+
+import Control.Applicative
+import Control.Monad.Error
+import Control.Monad.State
+import Control.Monad.Writer
+
+import Data.Time.Clock
+
+
+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
+ , buffer :: [C]
+ }
+
+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 = 1
+
+
+main :: IO ()
+main = do
+ hSetEcho stdin False
+ hSetBuffering stdin NoBuffering
+ forever $ do
+
+ _ <- hLookAhead stdin -- wait for input
+
+ t0 <- getCurrentTime
+ ((res, s), _) <- runScanner scan
+ t1 <- getCurrentTime
+
+ putStrLn $ "====> \ESC[32;1m" ++ show s ++ "\ESC[m in " ++
+ (show $ diffUTCTime t1 t0)
+ ++ ": \"\ESC[35m" ++ (concat $ map (colorize . toChar) s)
+ ++ "\ESC[m\""
+ case res of
+ Left msg -> putStrLn $ " error: " ++ msg
+ Right _ -> return ()
+
+
+scan, scanESC, scanCS ::
+ ( Monad m
+ , MonadIO m
+ , MonadError ScanError m
+ , MonadState ScanState m
+ , MonadWriter ScanLog m
+ ) => m ()
+
+
+scan = do
+ c <- liftIO $ hGetC stdin
+ tell [c]
+ case () of _
+ | c == 01/11 -> scanESC
+ | otherwise -> return ()
+
+
+scanESC = do
+ mb_c <- liftIO $ hWaitGetC timeout stdin
+ whenJust mb_c $ \ c -> do
+ tell [c]
+ case () of _
+ | c == 05/11 ->
+ -- CSI
+ scanCS
+
+ | c == 01/11 ->
+ -- XXX M-F1 and other crazy chords may cause
+ -- \ESC\ESC... on wu, so we just recurse here...
+ scanESC
+
+ | c == 04/15 ->
+ -- XXX Non-CSI SS3
+ one $ between (04/00) (07/14)
+
+ | otherwise -> return ()
+
+
+scanCS = do
+ zeroOrMore $ between (03/00) (03/15) -- parameter bytes
+ zeroOrMore $ between (02/00) (02/15) -- intermediate bytes
+ one $ 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
+ ) => (C -> Bool) -> m ()
+
+
+zeroOrMore p = do
+ mb_c <- liftIO $ hWaitLookAheadC timeout stdin
+ whenJust mb_c $ \ c ->
+ when (p c) $ do
+ _ <- liftIO $ hGetC stdin -- drop
+ tell [c]
+ modify $ \q -> q { buffer = buffer q ++ [c] }
+ zeroOrMore p
+
+
+one p = do
+ mb_c <- liftIO $ hWaitLookAheadC timeout stdin
+ 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 ()
+
+
+
+
+c / r = C c r
+
+data C = C { column :: Int, row :: Int }
+ deriving (Eq)
+
+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
+
+
+instance Ord C where
+ compare (C c1 r1) (C c2 r2) =
+ case compare c1 c2 of
+ EQ -> compare r1 r2
+ x -> x
+
+
+fromChar :: Char -> C
+fromChar c = let i = ord c in C ((shift i (-4)) .&. 0xf) (i .&. 0xf)
+
+toChar :: C -> Char
+toChar (C col row) = chr $ (shift col 4) .|. row
+
+
+
+
+
+colorize :: Char -> String
+colorize c
+ | isPrint c = [c]
+ | otherwise = "\ESC[1m" ++ (showLitChar c "") ++ "\ESC[22m"
+
+
+
+
+
+--
+hWaitGetChar t h = do
+ ready <- hWaitForInput h t
+ if ready
+ then hGetChar h >>= return . Just
+ else return Nothing
+
+hGetC h = hGetChar h >>= return . fromChar
+hWaitGetC t h = do
+ mb_ch <- hWaitGetChar t h
+ case mb_ch of
+ Nothing -> return Nothing
+ Just ch -> return $ Just $ fromChar $ ch
+
+hWaitLookAheadC t h = do
+ ready <- hWaitForInput h t
+ if ready
+ then hLookAhead h >>= return . Just . fromChar
+ else return Nothing
+
+
+-- CRUFT
+--expect cx ca =
+-- when (cx /= ca) $
+-- throwError $ "expected: " ++ (show cx) ++ ", got: " ++ (show ca)
+--
+--
+--
+-- expect (01/11) c
+--
+-- c <- (liftIO getChar) >>= return . fromChar
+--
+-- tell [c]
+--
+-- expect (05/11) c
+
+ --liftIO $ putStrLn $ (show c) ++ " -> " ++ (show s)
+
+
--
cgit v1.2.3