diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 140 |
1 files changed, 30 insertions, 110 deletions
diff --git a/src/Main.hs b/src/Main.hs index 43ff393..1a26868 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -23,6 +23,8 @@ import Control.Monad.Writer import Buffer import Process +import Scanner (scan, runScanner, toChar) + data VTConfig = VTConfig { withOutput :: IO () -> IO () @@ -84,14 +86,34 @@ uiThread :: VTConfig -> (VTState -> IO ()) -> IO VTState -> IO () uiThread cf putState getState = forever $ do q0 <- getState - ((eitCmd, lns), q1) <- runVT cf q0 $ do - c <- getCommand (mode q0) - execCommand c - return c + + _ <- hLookAhead stdin -- wait for input + --t0 <- getCurrentTime + -- ((res, s), _) <- runScanner scan + ((_, 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 () + + -- TODO don't leak C + let cmd = getCommand (mode q0) (map toChar s) + + --withOutput cf $ do + -- putStrLn $ show cmd + + ((_, lns), q1) <- runVT cf q0 (execCommand cmd) -- TODO only putState if it has changed (?) putState q1 + -- XXX dummy for following legacy code + let eitCmd = Right cmd + let mbErr = case eitCmd of Left err -> Just err Right c -> @@ -438,112 +460,10 @@ instance Show Mode where show VerbatimMode = "verbatim" -getCommand :: Mode -> VT Command -getCommand InsertMode = getCommandXXX imap InsertString -getCommand NormalMode = getCommandXXX nmap AlertBadInput -getCommand VerbatimMode = verbatimKeymap - - --- TODO refactor me please^_^ -getCommandXXX :: Keymap -> (String -> Command) -> VT Command -getCommandXXX keymap defCmd = do - - -- wait for the first character - _ <- liftIO $ hLookAhead stdin - - bufRef <- liftIO $ newIORef "" - candRef <- liftIO $ newIORef Nothing - cmdRef <- liftIO $ newEmptyMVar -- :: MVar (Maybe (String -> Command)) - - -- TODO ensure that this thread dies eventually - --forkIO $ rec "" keymap cmdRef candRef - getCharThreadId <- - --forkFinally (rec keymap cmdRef candRef bufRef) - -- (\_ -> putStrLn "input terminated") - liftIO $ forkIO $ do - rec keymap cmdRef candRef bufRef - - watchDogThreadId <- - liftIO $ forkIO $ do - --putStrLn "watchdog activated" - threadDelay $ 1000 * 50 -- 50ms - --putStrLn "watchdog timeout" - killThread getCharThreadId - --putStrLn "watchdog killed getCharThread" - putMVar cmdRef Nothing -- continue main thread - - mbCmd <- liftIO $ takeMVar cmdRef - - liftIO $ killThread watchDogThreadId - - cmd <- case mbCmd of - Just cmd -> return cmd - Nothing -> do - mbCmd2 <- liftIO $ readIORef candRef - case mbCmd2 of - Just cmd2 -> return cmd2 - Nothing -> return defCmd - - s <- liftIO $ readIORef bufRef - - --clearLine - --putStrLn $ "\x1b[35;1m" ++ (show s) ++ " -> " ++ (show $ cmd s) ++ "\x1b[m" - return $ cmd s - - where - rec :: Keymap - -> MVar (Maybe (String -> Command)) - -> IORef (Maybe (String -> Command)) - -> IORef String - -> IO () - rec km cmdRef candRef bufRef = do - c <- getChar - -- TODO s <- atomicModifyIORef bufRef $ \s -> let s' = s++[c] in (s,s) - olds <- readIORef bufRef - let s = olds ++ [c] - writeIORef bufRef s - - let km' = map (\(str,cmd) -> (tail str, cmd)) - $ filter ((==c) . head . fst) km - - -- direct and indirect candidates - (dc, ic) = partition (null . fst) km' - - --clearLine - --putStrLn $ " s: " ++ show s - --putStrLn $ "ic: " ++ (show $ map snd ic) - --putStrLn $ "dc: " ++ (show $ map snd dc) - - -- update candidate - if length dc == 1 - then atomicWriteIORef candRef (Just $ const $ snd $ dc !! 0) - else atomicWriteIORef candRef Nothing - - case length km' of - 0 -> do - --return $ defCmd' (s ++ [c]) - cand <- readIORef candRef - putMVar cmdRef cand - 1 -> - let (rest, cmd) = km' !! 0 - in if null rest - then do - --return $ cmd - -- TODO somehow give s? - putMVar cmdRef (Just $ const cmd) - else do - --rec (s ++ [c]) ic defCmd' - rec ic cmdRef candRef bufRef - _ -> do - --rec (s ++ [c]) ic defCmd' - rec ic cmdRef candRef bufRef - - - -verbatimKeymap :: VT Command -verbatimKeymap = do - c <- liftIO getChar - return $ InsertString [c] <> ChangeMode InsertMode +getCommand :: Mode -> String -> Command +getCommand InsertMode s = maybe (InsertString s) id $ lookup s imap +getCommand NormalMode s = maybe (AlertBadInput s) id $ lookup s nmap +getCommand VerbatimMode s = InsertString s <> ChangeMode InsertMode -- TODO Control.Monad.whenLeft |