summaryrefslogtreecommitdiffstats
path: root/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Main.hs')
-rw-r--r--Main.hs117
1 files changed, 95 insertions, 22 deletions
diff --git a/Main.hs b/Main.hs
index 75af792..4a794a4 100644
--- a/Main.hs
+++ b/Main.hs
@@ -392,32 +392,105 @@ instance Show Mode where
getCommand :: Mode -> IO Command
-getCommand InsertMode = getMappedCommand imap (InsertString . (:[]))
-getCommand NormalMode = getMappedCommand nmap (AlertBadInput . (:[]))
+getCommand InsertMode = getCommandXXX imap InsertString
+getCommand NormalMode = getCommandXXX nmap AlertBadInput
getCommand VerbatimMode = verbatimKeymap
-getMappedCommand :: Keymap -> (Char -> Command) -> IO Command
-getMappedCommand xs defCmd = do
- c <- getChar
- if any (isPrefixOf [c] . fst) xs
- then rec [c]
- else
- if isPrint c
- then return $ defCmd c
- else return $ AlertBadInput [c]
+-- TODO refactor me please^_^
+getCommandXXX :: Keymap -> (String -> Command) -> IO Command
+getCommandXXX keymap defCmd = do
+
+ -- wait for the first character
+ c <- hLookAhead stdin
+
+ bufRef <- newIORef ""
+ candRef <- newIORef Nothing
+ cmdRef <- 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")
+ forkIO $ do
+ rec keymap cmdRef candRef bufRef
+
+ watchDogThreadId <-
+ 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 <- takeMVar cmdRef
+
+ killThread watchDogThreadId
+
+ cmd <- case mbCmd of
+ Just cmd -> return cmd
+ Nothing -> do
+ mbCmd2 <- readIORef candRef
+ case mbCmd2 of
+ Just cmd2 -> return cmd2
+ Nothing -> return defCmd
+
+ s <- readIORef bufRef
+
+ --clearLine
+ --putStrLn $ "\x1b[35;1m" ++ (show s) ++ " -> " ++ (show $ cmd s) ++ "\x1b[m"
+ return $ cmd s
+
where
- rec :: String -> IO Command
- rec s =
- case lookup s xs of
- Just c -> return c
- _ ->
- if any (isPrefixOf s . fst) xs
- then do
- c <- getChar
- rec $ s ++ [c]
- else
- return $ AlertBadInput s
+ 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 :: IO Command