summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2014-12-28 22:43:10 +0100
committertv <tv@shackspace.de>2015-10-17 02:12:08 +0200
commit9a8810eeba74b596c6a7de6fa20da56e3b52fd5b (patch)
tree329fcd4dcc90f5c1010aca8806552cc25b5be830
parentca87352723bc2f36c8e37df6b50e310a1a38054d (diff)
cleanup Scanner
-rw-r--r--src/Scanner.hs91
1 files changed, 27 insertions, 64 deletions
diff --git a/src/Scanner.hs b/src/Scanner.hs
index 9f0b5ed..1f8eb5c 100644
--- a/src/Scanner.hs
+++ b/src/Scanner.hs
@@ -1,23 +1,19 @@
{-# 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
+module Scanner
+ ( getKey
+ ) where
import Prelude hiding ((/))
-
import Control.Applicative
import Control.Monad.Error
import Control.Monad.State
import Control.Monad.Writer
-
-import Data.Time.Clock
+import Data.Bits
+import Data.Char
+import System.IO
-- high level interface
@@ -32,20 +28,26 @@ 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
+ { _result :: Maybe Token -- TODO underscore supresses warning, rename before usage..
, buffer :: [C]
}
+
+emptyScanState :: ScanState
emptyScanState = ScanState Nothing []
@@ -61,36 +63,17 @@ newtype Scanner m a = Scanner
, 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
-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" ++ (s >>= colorize . toChar)
- ++ "\ESC[m\""
- case res of
- Left msg -> putStrLn $ " error: " ++ msg
- Right _ -> return ()
-
-
scan, scanESC, scanCS ::
( Monad m
, MonadIO m
@@ -184,12 +167,14 @@ whenJust mb f =
-
+(/) :: Int -> Int -> C
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)
@@ -212,55 +197,33 @@ 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
+
+--
+hGetC :: Handle -> IO C
+hGetC h = hGetChar h >>= return . fromChar
-colorize :: Char -> String
-colorize c
- | isPrint c = [c]
- | otherwise = "\ESC[1m" ++ (showLitChar c "") ++ "\ESC[22m"
-
-
-
-
-
---
+hWaitGetChar :: Int -> Handle -> IO (Maybe Char)
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 :: 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
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)
-
-