summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Main-gut-ohne-transformers.hs340
-rw-r--r--Main-kaputt-mit-mtl.hs396
-rw-r--r--Main.hs400
-rw-r--r--Makefile47
-rw-r--r--OldMain.hs206
-rw-r--r--default.nix24
-rw-r--r--defaultGetCommand.hs33
-rw-r--r--hack.cabal20
8 files changed, 1466 insertions, 0 deletions
diff --git a/Main-gut-ohne-transformers.hs b/Main-gut-ohne-transformers.hs
new file mode 100644
index 0000000..c4646ec
--- /dev/null
+++ b/Main-gut-ohne-transformers.hs
@@ -0,0 +1,340 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Control.Monad
+import Data.Char
+import Data.IORef
+import Data.List
+import Data.Time.Clock (getCurrentTime)
+import Data.Time.Format (formatTime)
+import Numeric (showIntAtBase)
+import System.IO
+import System.Locale (defaultTimeLocale, rfc822DateFormat)
+--import System.Posix.Signals
+
+
+type Buffer = (String, String)
+
+emptyBuffer = ("", "")
+
+
+main :: IO ()
+main = do
+ hSetEcho stdin False
+ hSetBuffering stdin NoBuffering
+
+ tid <- myThreadId
+
+ -- WINCH
+ -- TODO installHandler 28 (Catch $ ioctl 0 ...) Nothing
+
+ lock <- newMVar emptyBuffer
+
+ renderInputLine emptyBuffer
+ hFlush stdout
+
+ forkIO $ (dateThread 1000000) lock
+ uiThread (NormalMode nmap) lock
+
+
+dateThread delay lock = forever $ do
+ t <- getCurrentTime
+ withMVar lock $ \ buf -> do
+ putLine $ formatTime defaultTimeLocale rfc822DateFormat t
+ renderInputLine buf
+ hFlush stdout
+ threadDelay delay
+
+
+uiThread mode lock = do
+ c <- getCommand mode
+ mbMode <- modifyMVar lock (execCommand c)
+ case mbMode of
+ Nothing ->
+ uiThread mode lock
+ Just mode' ->
+ uiThread mode' lock
+
+
+data Command
+ = AlertBadInput String
+ | InsertChar Char
+ | InsertNextCharVerbatim
+ | InsertCharThenChangeMode Char Mode
+ | MoveCursorRight
+ | MoveCursorLeft
+ | KillLastWord
+ | KillLastChar
+ | KillNextChar
+ | ExecuteInputBuffer
+ | UnboundSequence String String
+ | GotoBOL
+ | GotoEOL
+
+
+finishCommand :: Buffer -> IO (Buffer, Maybe Mode)
+finishCommand buf = do
+ clearLine
+ renderInputLine buf
+ hFlush stdout
+ return (buf, Nothing)
+
+finishCommandChangeMode :: Buffer -> Mode -> IO (Buffer, Maybe Mode)
+finishCommandChangeMode buf mode = do
+ clearLine
+ putStrLn $ "change mode: " ++ (show mode)
+ renderInputLine buf
+ hFlush stdout
+ return (buf, Just mode)
+
+
+
+execCommand :: Command -> Buffer -> IO (Buffer, Maybe Mode)
+
+execCommand GotoBOL (lhs, rhs) =
+ finishCommand ("", lhs ++ rhs)
+
+execCommand GotoEOL (lhs, rhs) =
+ finishCommand (lhs ++ rhs, "")
+
+execCommand MoveCursorLeft buf@(lhs@(_:_),rhs) = do
+ finishCommand (init lhs, last lhs : rhs)
+
+execCommand MoveCursorRight (lhs,rhs@(_:_)) = do
+ finishCommand (lhs ++ [head rhs], tail rhs)
+
+execCommand (InsertChar c) (lhs,rhs) = do
+ finishCommand (lhs ++ [c], rhs)
+
+execCommand (InsertCharThenChangeMode c m) (lhs, rhs) = do
+ finishCommandChangeMode (lhs ++ [c], rhs) m
+
+execCommand InsertNextCharVerbatim buf = do
+ finishCommandChangeMode buf VerbatimMode
+
+execCommand ExecuteInputBuffer (lhs,rhs) = do
+ putLine $ "input: <" ++ (concat $ map (reform 32) $ lhs ++ rhs) ++ ">"
+ finishCommand emptyBuffer
+
+execCommand KillNextChar buf@(lhs,_:rhs') = do
+ finishCommand (lhs, rhs')
+
+execCommand KillLastChar (lhs@(_:_),rhs) = do
+ finishCommand (init lhs, rhs)
+
+execCommand KillLastWord (lhs@(_:_),rhs) = do
+ finishCommand (foldr dropWhileEnd lhs [not . isSpace, isSpace], rhs)
+
+execCommand (AlertBadInput s) buf@(lhs,rhs) = do
+ putLine $ "unhandled input: <" ++ (concat $ map (reform 31) s) ++ ">"
+ finishCommand buf
+
+execCommand (UnboundSequence s n) buf@(lhs,rhs) = do
+ putLine $ "unbound sequence: <" ++ (concat $ map (reform 31) s) ++ "> "
+ ++ (special 31 n)
+ finishCommand buf
+
+execCommand _ buf = do
+ ringBell
+ hFlush stdout
+ return (buf, Nothing)
+
+
+
+
+putLine s = do
+ clearLine -- TODO this renders finishCommand's clearLine redundant
+ putStrLn s
+
+
+
+reform colorCode c =
+ if isPrint c
+ then normal colorCode [c]
+ else
+ special colorCode $
+ case ord c of
+ 27 -> "^["
+ _ -> charToCode c
+
+normal colorCode s = "\x1b[" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"
+special colorCode s = "\x1b[1;" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"
+
+
+
+-- XXX assumes that the cursor is already at the input line
+renderInputLine :: Buffer -> IO ()
+renderInputLine (lhs, rhs) = do
+ --clearLine
+ putStr $ "> " ++ pp lhs ++ pp rhs
+ moveCursorLeft (length $ ppVis rhs)
+ --hFlush stdout
+ where
+ pp = concat . map reform
+ reform c =
+ if isPrint c
+ then [c]
+ else
+ "\x1b[35m" ++ (
+ case ord c of
+ 27 -> "^["
+ _ -> "\\" ++ show (ord c)
+ ) ++ "\x1b[m"
+
+ ppVis = concat . map reformVis
+ reformVis c =
+ if isPrint c
+ then [c]
+ else
+ case ord c of
+ 27 -> "^["
+ _ -> "\\" ++ show (ord c)
+
+
+
+
+
+
+clearLine =
+ putStr "\x1b[2K" >>
+ moveCursorLeft 80
+
+
+ringBell = putStr "\x07" -- BEL '\a'
+
+
+moveCursorLeft 0 = return ()
+moveCursorLeft i = putStr $ "\x1b[" ++ show i ++ "D"
+
+moveCursorRight 0 = return ()
+moveCursorRight i = putStr $ "\x1b[" ++ show i ++ "C"
+
+clearLineFromCursorRight = putStr "\x1b[0K"
+
+
+-- TODO? charToCode c = "\\x" ++ showHex (ord c)
+charToCode c = "\\x" ++ showIntAtBase 16 intToDigit (ord c) ""
+
+
+
+
+
+-- TODO pressing ESC, then F11 etc. is ugly
+nmap =
+ [ ("\x01", GotoBOL)
+ , ("\x05", GotoEOL)
+ , ("\x1b[3~", KillNextChar)
+ , ("\x1b[C", MoveCursorRight)
+ , ("\x1b[D", MoveCursorLeft)
+ , ("\x16", InsertNextCharVerbatim) -- ^V
+ , ("\x17", KillLastWord) -- ^W
+ , ("\x0a", ExecuteInputBuffer)
+ , ("\x7f", KillLastChar) -- Delete
+ , ("\x08", KillLastChar) -- BackSpace
+ ]
+ ++ [unboundSequence "\x1b[2~" "<Insert>"]
+ ++ [unboundSequence "\x1b[5~" "<Prior>"] -- page up
+ ++ [unboundSequence "\x1b[6~" "<Next>"] -- page dn
+ ++ [unboundSequence "\x1b[7~" "<Home>"]
+ ++ [unboundSequence "\x1b[8~" "<End>"]
+ ++ [unboundSequence "\x1b[2$" "<S-Insert>"]
+ ++ [unboundSequence "\x1b[5$" "<S-Prior>"] -- page up
+ ++ [unboundSequence "\x1b[6$" "<S-Next>"] -- page dn
+ ++ [unboundSequence "\x1b[7$" "<S-Home>"]
+ ++ [unboundSequence "\x1b[8$" "<S-End>"]
+ ++ [unboundSequence "\x1b\x1b[2$" "<S-M-Insert>"]
+ ++ [unboundSequence "\x1b\x1b[5$" "<S-M-Prior>"] -- page up
+ ++ [unboundSequence "\x1b\x1b[6$" "<S-M-Next>"] -- page dn
+ ++ [unboundSequence "\x1b\x1b[7$" "<S-M-Home>"]
+ ++ [unboundSequence "\x1b\x1b[8$" "<S-M-End>"]
+ ++ [unboundSequence "\x1b\x1b[A" "<M-Up>"]
+ ++ [unboundSequence "\x1b\x1b[B" "<M-Down>"]
+ ++ [unboundSequence "\x1b\x1b[C" "<M-Right>"]
+ ++ [unboundSequence "\x1b\x1b[D" "<M-Left>"]
+ ++ [unboundSequence "\x1b\x1b[a" "<S-M-Up>"]
+ ++ [unboundSequence "\x1b\x1b[b" "<S-M-Down>"]
+ ++ [unboundSequence "\x1b\x1b[c" "<S-M-Right>"]
+ ++ [unboundSequence "\x1b\x1b[d" "<S-M-Left>"]
+ ++ [unboundSequence "\x1b[a" "<S-Up>"]
+ ++ [unboundSequence "\x1b[b" "<S-Down>"]
+ ++ [unboundSequence "\x1b[c" "<S-Right>"]
+ ++ [unboundSequence "\x1b[d" "<S-Left>"]
+ ++ [unboundSequence "\x1bOa" "<C-Up>"]
+ ++ [unboundSequence "\x1bOb" "<C-Down>"]
+ ++ [unboundSequence "\x1bOc" "<C-Right>"]
+ ++ [unboundSequence "\x1bOd" "<C-Left>"]
+ ++ [unboundSequence "\x1b\x1bOa" "<C-M-Up>"]
+ ++ [unboundSequence "\x1b\x1bOb" "<C-M-Down>"]
+ ++ [unboundSequence "\x1b\x1bOc" "<C-M-Right>"]
+ ++ [unboundSequence "\x1b\x1bOd" "<C-M-Left>"]
+ ++ [unboundSequence "\x1b[11~" "<F1>"]
+ ++ [unboundSequence "\x1b[12~" "<F2>"]
+ ++ [unboundSequence "\x1b[13~" "<F3>"]
+ ++ [unboundSequence "\x1b[14~" "<F4>"]
+ ++ [unboundSequence "\x1b[15~" "<F5>"]
+ ++ [unboundSequence "\x1b[17~" "<F6>"]
+ ++ [unboundSequence "\x1b[18~" "<F7>"]
+ ++ [unboundSequence "\x1b[19~" "<F8>"]
+ ++ [unboundSequence "\x1b[20~" "<F9>"]
+ ++ [unboundSequence "\x1b[21~" "<F10>"]
+ ++ [unboundSequence "\x1b[23~" "<F11>"]
+ ++ [unboundSequence "\x1b[24~" "<F12>"]
+
+ ++ [unboundSequence "\x1b\x1b[2~" "<M-Insert>"]
+ ++ [unboundSequence "\x1b\x1b[3~" "<M-Delete>"]
+ ++ map (\ i -> unboundSequence ("\x1b\x1b[" ++ show i ++ "~")
+ ("<M-F" ++ show i ++ ">"))
+ [11..24]
+ ++ [unboundSequence "\x1b\x7f" "<M-BackSpace>"]
+ ++ [unboundSequence "\x1b\x0a" "<M-Return>"]
+
+
+unboundSequence seq name =
+ (seq, UnboundSequence seq name)
+
+
+data Mode
+ = NormalMode [(String, Command)]
+ | VerbatimMode
+
+instance Show Mode where
+ show (NormalMode _) = "normal"
+ show VerbatimMode = "verbatim"
+
+
+getCommand :: Mode -> IO Command
+getCommand (NormalMode map) = getMappedCommand map
+getCommand VerbatimMode = verbatimKeymap
+
+
+getMappedCommand :: [(String, Command)] -> IO Command
+getMappedCommand xs = do
+ c <- getChar
+ if any (isPrefixOf [c] . fst) xs
+ then rec [c]
+ else
+ if isPrint c
+ then return $ InsertChar c
+ else return $ AlertBadInput [c]
+ 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
+
+
+verbatimKeymap :: IO Command
+verbatimKeymap = do
+ c <- getChar
+ --return $ InsertCharThenChangeMode c defaultGetCommand
+ return $ InsertCharThenChangeMode c (NormalMode nmap)
+
diff --git a/Main-kaputt-mit-mtl.hs b/Main-kaputt-mit-mtl.hs
new file mode 100644
index 0000000..0167b9f
--- /dev/null
+++ b/Main-kaputt-mit-mtl.hs
@@ -0,0 +1,396 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Main where
+
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Control.Monad
+import Data.Char
+import Data.IORef
+import Data.List
+import Data.Time.Clock (getCurrentTime)
+import Data.Time.Format (formatTime)
+import Numeric (showIntAtBase)
+import System.IO
+import System.Locale (defaultTimeLocale, rfc822DateFormat)
+--import System.Posix.Signal
+--import Control.Monad.Trans.Class (lift)
+--import Control.Monad.IO.Class (liftIO, MonadIO)
+--import Control.Monad.Trans.State.Lazy
+import Control.Monad.State
+import Control.Monad.Reader
+import Data.Typeable
+import Control.Applicative
+
+
+newtype VT a = VT (StateT VTState IO a)
+ deriving (Functor, Monad, MonadIO, MonadState VTState)
+
+
+instance Applicative VT where
+ pure = return
+ (<*>) = ap
+
+
+data VTState = VTState
+ { mode :: Mode
+ , buffer :: MVar Buffer
+ }
+
+runVT :: VTState -> VT a -> IO (a, VTState)
+runVT st (VT a) = runStateT a st
+
+
+
+
+type Buffer = (String, String)
+
+emptyBuffer = ("", "")
+
+
+main :: IO ()
+main = do
+ hSetEcho stdin False
+ hSetBuffering stdin NoBuffering
+
+ tid <- myThreadId
+
+ -- WINCH
+ -- TODO installHandler 28 (Catch $ ioctl 0 ...) Nothing
+
+ lock <- newMVar emptyBuffer
+
+ renderInputLine emptyBuffer
+ hFlush stdout
+
+ let st = VTState
+ { mode = NormalMode nmap
+ , buffer = lock
+ }
+
+ forkIO $ runVT st (dateThread 1000000 lock) >> return ()
+ runVT st uiThread
+
+ return ()
+
+
+dateThread :: Int -> MVar Buffer -> VT ()
+dateThread delay lock = forever $ do
+ t <- liftIO getCurrentTime
+ liftIO $ withMVar lock $ \ buf -> do
+ putLine $ formatTime defaultTimeLocale rfc822DateFormat t
+ renderInputLine buf
+ hFlush stdout
+ liftIO $ threadDelay delay
+
+
+--uiThread :: MVar Buffer -> VT ()
+--uiThread lock = do
+-- c <- liftIO $ getCommand mode
+--uiThread :: mvar buffer -> vt ()
+--uiThread lock = do
+uiThread :: VT ()
+uiThread = forever $ do
+ st <- get
+ let m = mode st
+ c <- liftIO $ getCommand m
+ b <- liftIO $ readMVar (buffer st)
+ execCommand c b
+ --mbMode <- liftIO $ modifyMVar (buffer st) (execCommand c)
+ --case mbMode of
+ -- Nothing -> return ()
+ -- Just mode' -> do
+ -- put $ st { mode = mode' }
+
+
+data Command
+ = AlertBadInput String
+ | InsertChar Char
+ | InsertNextCharVerbatim
+ | InsertCharThenChangeMode Char Mode
+ | MoveCursorRight
+ | MoveCursorLeft
+ | KillLastWord
+ | KillLastChar
+ | KillNextChar
+ | ExecuteInputBuffer
+ | UnboundSequence String String
+ | GotoBOL
+ | GotoEOL
+
+
+--finishCommand :: Buffer -> IO (Buffer, Maybe Mode)
+finishCommand :: Buffer -> VT ()
+finishCommand buf = do
+ b <- gets buffer
+ liftIO $ do
+ clearLine
+ renderInputLine buf
+ hFlush stdout
+ putMVar b buf
+ --modify $ \ st -> st { buffer = buf }
+ --return (buf, Nothing)
+
+--finishCommandChangeMode :: Buffer -> Mode -> IO (Buffer, Maybe Mode)
+finishCommandChangeMode :: Buffer -> Mode -> VT ()
+finishCommandChangeMode buf mode = do
+ b <- gets buffer
+ liftIO $ do
+ clearLine
+ putStrLn $ "change mode: " ++ (show mode)
+ renderInputLine buf
+ hFlush stdout
+ putMVar b buf
+ --return (buf, Just mode)
+ --modify $ \ st -> st { buffer = buf }
+
+
+--execCommand :: Command -> Buffer -> IO (Buffer, Maybe Mode)
+execCommand :: Command -> Buffer -> VT ()
+
+execCommand GotoBOL (lhs, rhs) =
+ finishCommand ("", lhs ++ rhs)
+
+execCommand GotoEOL (lhs, rhs) =
+ finishCommand (lhs ++ rhs, "")
+
+execCommand MoveCursorLeft buf@(lhs@(_:_),rhs) = do
+ finishCommand (init lhs, last lhs : rhs)
+
+execCommand MoveCursorRight (lhs,rhs@(_:_)) = do
+ finishCommand (lhs ++ [head rhs], tail rhs)
+
+execCommand (InsertChar c) (lhs,rhs) = do
+ finishCommand (lhs ++ [c], rhs)
+
+execCommand (InsertCharThenChangeMode c m) (lhs, rhs) = do
+ finishCommandChangeMode (lhs ++ [c], rhs) m
+
+execCommand InsertNextCharVerbatim buf = do
+ finishCommandChangeMode buf VerbatimMode
+
+execCommand ExecuteInputBuffer (lhs,rhs) = do
+ liftIO $ putLine $ "input: <" ++ (concat $ map (reform 32) $ lhs ++ rhs) ++ ">"
+ finishCommand emptyBuffer
+
+execCommand KillNextChar buf@(lhs,_:rhs') = do
+ finishCommand (lhs, rhs')
+
+execCommand KillLastChar (lhs@(_:_),rhs) = do
+ finishCommand (init lhs, rhs)
+
+execCommand KillLastWord (lhs@(_:_),rhs) = do
+ finishCommand (foldr dropWhileEnd lhs [not . isSpace, isSpace], rhs)
+
+execCommand (AlertBadInput s) buf@(lhs,rhs) = do
+ liftIO $ putLine $ "unhandled input: <" ++ (concat $ map (reform 31) s) ++ ">"
+ finishCommand buf
+
+execCommand (UnboundSequence s n) buf@(lhs,rhs) = do
+ liftIO $ putLine $ "unbound sequence: <" ++ (concat $ map (reform 31) s) ++ "> "
+ ++ (special 31 n)
+ finishCommand buf
+
+execCommand _ buf = do
+ liftIO $ do
+ ringBell
+ hFlush stdout
+ --return (buf, Nothing)
+
+
+
+
+putLine s = do
+ clearLine -- TODO this renders finishCommand's clearLine redundant
+ putStrLn s
+
+
+
+reform colorCode c =
+ if isPrint c
+ then normal colorCode [c]
+ else
+ special colorCode $
+ case ord c of
+ 27 -> "^["
+ _ -> charToCode c
+
+normal colorCode s = "\x1b[" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"
+special colorCode s = "\x1b[1;" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"
+
+
+
+-- XXX assumes that the cursor is already at the input line
+renderInputLine :: Buffer -> IO ()
+renderInputLine (lhs, rhs) = do
+ --clearLine
+ putStr $ "> " ++ pp lhs ++ pp rhs
+ moveCursorLeft (length $ ppVis rhs)
+ --hFlush stdout
+ where
+ pp = concat . map reform
+ reform c =
+ if isPrint c
+ then [c]
+ else
+ "\x1b[35m" ++ (
+ case ord c of
+ 27 -> "^["
+ _ -> "\\" ++ show (ord c)
+ ) ++ "\x1b[m"
+
+ ppVis = concat . map reformVis
+ reformVis c =
+ if isPrint c
+ then [c]
+ else
+ case ord c of
+ 27 -> "^["
+ _ -> "\\" ++ show (ord c)
+
+
+
+
+
+
+clearLine =
+ putStr "\x1b[2K" >>
+ moveCursorLeft 80
+
+
+ringBell = putStr "\x07" -- BEL '\a'
+
+
+moveCursorLeft 0 = return ()
+moveCursorLeft i = putStr $ "\x1b[" ++ show i ++ "D"
+
+moveCursorRight 0 = return ()
+moveCursorRight i = putStr $ "\x1b[" ++ show i ++ "C"
+
+clearLineFromCursorRight = putStr "\x1b[0K"
+
+
+-- TODO? charToCode c = "\\x" ++ showHex (ord c)
+charToCode c = "\\x" ++ showIntAtBase 16 intToDigit (ord c) ""
+
+
+
+
+
+-- TODO pressing ESC, then F11 etc. is ugly
+nmap =
+ [ ("\x01", GotoBOL)
+ , ("\x05", GotoEOL)
+ , ("\x1b[3~", KillNextChar)
+ , ("\x1b[C", MoveCursorRight)
+ , ("\x1b[D", MoveCursorLeft)
+ , ("\x16", InsertNextCharVerbatim) -- ^V
+ , ("\x17", KillLastWord) -- ^W
+ , ("\x0a", ExecuteInputBuffer)
+ , ("\x7f", KillLastChar) -- Delete
+ , ("\x08", KillLastChar) -- BackSpace
+ ]
+ ++ [unboundSequence "\x1b[2~" "<Insert>"]
+ ++ [unboundSequence "\x1b[5~" "<Prior>"] -- page up
+ ++ [unboundSequence "\x1b[6~" "<Next>"] -- page dn
+ ++ [unboundSequence "\x1b[7~" "<Home>"]
+ ++ [unboundSequence "\x1b[8~" "<End>"]
+ ++ [unboundSequence "\x1b[2$" "<S-Insert>"]
+ ++ [unboundSequence "\x1b[5$" "<S-Prior>"] -- page up
+ ++ [unboundSequence "\x1b[6$" "<S-Next>"] -- page dn
+ ++ [unboundSequence "\x1b[7$" "<S-Home>"]
+ ++ [unboundSequence "\x1b[8$" "<S-End>"]
+ ++ [unboundSequence "\x1b\x1b[2$" "<S-M-Insert>"]
+ ++ [unboundSequence "\x1b\x1b[5$" "<S-M-Prior>"] -- page up
+ ++ [unboundSequence "\x1b\x1b[6$" "<S-M-Next>"] -- page dn
+ ++ [unboundSequence "\x1b\x1b[7$" "<S-M-Home>"]
+ ++ [unboundSequence "\x1b\x1b[8$" "<S-M-End>"]
+ ++ [unboundSequence "\x1b\x1b[A" "<M-Up>"]
+ ++ [unboundSequence "\x1b\x1b[B" "<M-Down>"]
+ ++ [unboundSequence "\x1b\x1b[C" "<M-Right>"]
+ ++ [unboundSequence "\x1b\x1b[D" "<M-Left>"]
+ ++ [unboundSequence "\x1b\x1b[a" "<S-M-Up>"]
+ ++ [unboundSequence "\x1b\x1b[b" "<S-M-Down>"]
+ ++ [unboundSequence "\x1b\x1b[c" "<S-M-Right>"]
+ ++ [unboundSequence "\x1b\x1b[d" "<S-M-Left>"]
+ ++ [unboundSequence "\x1b[a" "<S-Up>"]
+ ++ [unboundSequence "\x1b[b" "<S-Down>"]
+ ++ [unboundSequence "\x1b[c" "<S-Right>"]
+ ++ [unboundSequence "\x1b[d" "<S-Left>"]
+ ++ [unboundSequence "\x1bOa" "<C-Up>"]
+ ++ [unboundSequence "\x1bOb" "<C-Down>"]
+ ++ [unboundSequence "\x1bOc" "<C-Right>"]
+ ++ [unboundSequence "\x1bOd" "<C-Left>"]
+ ++ [unboundSequence "\x1b\x1bOa" "<C-M-Up>"]
+ ++ [unboundSequence "\x1b\x1bOb" "<C-M-Down>"]
+ ++ [unboundSequence "\x1b\x1bOc" "<C-M-Right>"]
+ ++ [unboundSequence "\x1b\x1bOd" "<C-M-Left>"]
+ ++ [unboundSequence "\x1b[11~" "<F1>"]
+ ++ [unboundSequence "\x1b[12~" "<F2>"]
+ ++ [unboundSequence "\x1b[13~" "<F3>"]
+ ++ [unboundSequence "\x1b[14~" "<F4>"]
+ ++ [unboundSequence "\x1b[15~" "<F5>"]
+ ++ [unboundSequence "\x1b[17~" "<F6>"]
+ ++ [unboundSequence "\x1b[18~" "<F7>"]
+ ++ [unboundSequence "\x1b[19~" "<F8>"]
+ ++ [unboundSequence "\x1b[20~" "<F9>"]
+ ++ [unboundSequence "\x1b[21~" "<F10>"]
+ ++ [unboundSequence "\x1b[23~" "<F11>"]
+ ++ [unboundSequence "\x1b[24~" "<F12>"]
+
+ ++ [unboundSequence "\x1b\x1b[2~" "<M-Insert>"]
+ ++ [unboundSequence "\x1b\x1b[3~" "<M-Delete>"]
+ ++ map (\ i -> unboundSequence ("\x1b\x1b[" ++ show i ++ "~")
+ ("<M-F" ++ show i ++ ">"))
+ [11..24]
+ ++ [unboundSequence "\x1b\x7f" "<M-BackSpace>"]
+ ++ [unboundSequence "\x1b\x0a" "<M-Return>"]
+
+
+unboundSequence seq name =
+ (seq, UnboundSequence seq name)
+
+
+data Mode
+ = NormalMode [(String, Command)]
+ | VerbatimMode
+
+instance Show Mode where
+ show (NormalMode _) = "normal"
+ show VerbatimMode = "verbatim"
+
+
+getCommand :: Mode -> IO Command
+getCommand (NormalMode map) = getMappedCommand map
+getCommand VerbatimMode = verbatimKeymap
+
+
+getMappedCommand :: [(String, Command)] -> IO Command
+getMappedCommand xs = do
+ c <- getChar
+ if any (isPrefixOf [c] . fst) xs
+ then rec [c]
+ else
+ if isPrint c
+ then return $ InsertChar c
+ else return $ AlertBadInput [c]
+ 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
+
+
+verbatimKeymap :: IO Command
+verbatimKeymap = do
+ c <- getChar
+ --return $ InsertCharThenChangeMode c defaultGetCommand
+ return $ InsertCharThenChangeMode c (NormalMode nmap)
+
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..8f4ceb7
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,400 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Control.Monad
+import Data.Char
+import Data.IORef
+import Data.List
+import Data.Time.Clock (getCurrentTime)
+import Data.Time.Format (formatTime)
+import Numeric (showIntAtBase)
+import System.IO
+import System.Locale (defaultTimeLocale, rfc822DateFormat)
+--import System.Posix.Signals
+
+
+data VTState = VTState
+ { buffer :: Buffer
+ , mode :: Mode
+ }
+
+emptyState = VTState emptyBuffer (NormalMode nmap)
+
+
+type Buffer = (String, String)
+
+emptyBuffer = ("", "")
+
+
+main :: IO ()
+main = do
+ hSetEcho stdin False
+ hSetBuffering stdin NoBuffering
+
+ tid <- myThreadId
+
+ -- WINCH
+ -- TODO installHandler 28 (Catch $ ioctl 0 ...) Nothing
+
+ lock <- newMVar emptyBuffer
+
+ renderInputLine emptyBuffer
+ hFlush stdout
+
+ forkIO $ (dateThread 1000000) lock
+ uiThread (NormalMode nmap) lock
+
+
+dateThread delay lock = forever $ do
+ t <- getCurrentTime
+ withMVar lock $ \ buf -> do
+ putLine $ formatTime defaultTimeLocale rfc822DateFormat t
+ renderInputLine buf
+ hFlush stdout
+ threadDelay delay
+
+
+uiThread mod lock = do
+ c <- getCommand mod
+ --mbMode <- modifyMVar lock (execCommand c)
+ --case mbMode of
+ -- Nothing ->
+ -- uiThread mode lock
+ -- Just mode' ->
+ -- uiThread mode' lock
+ mod' <- modifyMVar lock $ \ buf -> do
+ let st = VTState
+ { mode = mod
+ , buffer = buf
+ }
+ mbst' <- execCommand c st
+
+ case mbst' of
+ Nothing -> do
+ ringBell
+ hFlush stdout
+ return (buf, mod)
+ Just st' -> do
+ clearLine
+ when (show (mode st) /= show (mode st')) $ do
+ putStrLn $ "change mode: " ++ (show $ mode st')
+ renderInputLine (buffer st')
+ hFlush stdout
+
+ return (buffer st', mode st')
+
+ uiThread mod' lock
+
+
+data Command
+ = AlertBadInput String
+ | InsertChar Char
+ | InsertNextCharVerbatim
+ | InsertCharThenChangeMode Char Mode
+ | MoveCursorRight
+ | MoveCursorLeft
+ | KillLastWord
+ | KillLastChar
+ | KillNextChar
+ | ExecuteInputBuffer
+ | UnboundSequence String String
+ | GotoBOL
+ | GotoEOL
+
+
+--finishCommand :: Buffer -> IO (Buffer, Maybe Mode)
+--finishCommand buf = do
+-- clearLine
+-- renderInputLine buf
+-- hFlush stdout
+-- return (buf, Nothing)
+--
+--finishCommandChangeMode :: Buffer -> Mode -> IO (Buffer, Maybe Mode)
+--finishCommandChangeMode buf mode = do
+-- clearLine
+-- putStrLn $ "change mode: " ++ (show mode)
+-- renderInputLine buf
+-- hFlush stdout
+-- return (buf, Just mode)
+
+-- TODO execCommand :: Command -> VTState -> VTState
+
+--execCommand :: Command -> Buffer -> IO (Buffer, Maybe Mode)
+
+
+-- TODO instead of propagating Maybe to caller, use
+-- something like Writer monad to generate bell
+modifyBuffer :: (Buffer -> Maybe Buffer) -> VTState -> Maybe VTState
+modifyBuffer f st =
+ case f (buffer st) of
+ Nothing -> Nothing
+ Just b' -> Just st { buffer = b' }
+
+-- TODO instance Show Buffer (w/newtype Buffer)
+
+showBuffer :: Buffer -> String
+showBuffer (lhs, rhs) = lhs ++ rhs
+
+
+execCommand :: Command -> VTState -> IO (Maybe VTState)
+
+execCommand GotoBOL q =
+ return . modifyBuffer (\(lhs, rhs) -> Just ("", lhs ++ rhs)) $ q
+
+execCommand GotoEOL q =
+ return . modifyBuffer (\(lhs, rhs) -> Just (lhs ++ rhs, "")) $ q
+
+execCommand MoveCursorLeft q =
+ return . modifyBuffer (\(lhs, rhs) ->
+ if null lhs then Nothing else Just (init lhs, last lhs : rhs)
+ ) $ q
+
+execCommand MoveCursorRight q =
+ return . modifyBuffer (\(lhs, rhs) ->
+ if null lhs then Nothing else Just (lhs ++ [head rhs], tail rhs)
+ ) $ q
+
+execCommand (InsertChar c) q =
+ return . modifyBuffer (\(lhs, rhs) -> Just (lhs ++ [c], rhs)) $ q
+
+execCommand (InsertCharThenChangeMode c m) q =
+ execCommand (InsertChar c) q { mode = m }
+
+execCommand InsertNextCharVerbatim q =
+ return . modifyBuffer Just $ q { mode = VerbatimMode }
+
+execCommand ExecuteInputBuffer q = do
+ -- TODO Writer monad?
+ putLine $ concat
+ [ "input: <", concat $ map (reform 32) $ showBuffer . buffer $ q, ">"
+ ]
+ return . modifyBuffer (const $ Just emptyBuffer) $ q
+
+execCommand KillNextChar q =
+ return . modifyBuffer (\(lhs, _:rhs') -> Just (lhs, rhs')) $ q
+
+execCommand KillLastChar q =
+ return . modifyBuffer (\(lhs, rhs) ->
+ if null lhs then Nothing else Just (init lhs, rhs)
+ ) $ q
+
+execCommand KillLastWord q =
+ return . modifyBuffer (\(lhs, rhs) ->
+ if null lhs then Nothing
+ else Just (foldr dropWhileEnd lhs [not . isSpace, isSpace], rhs)
+ ) $ q
+
+execCommand (AlertBadInput s) q = do
+ putLine $ "unhandled input: <" ++ (concat $ map (reform 31) s) ++ ">"
+ return Nothing
+ --return . Just $ q
+
+execCommand (UnboundSequence s n) q = do
+ putLine $ "unbound sequence: <" ++ (concat $ map (reform 31) s) ++ "> "
+ ++ (special 31 n)
+ --return . Just $ q
+ return Nothing
+
+--execCommand _ q = do
+-- ringBell
+-- hFlush stdout
+-- return q
+
+
+
+putLine s = do
+ clearLine -- TODO this renders finishCommand's clearLine redundant
+ putStrLn s
+
+
+
+reform colorCode c =
+ if isPrint c
+ then normal colorCode [c]
+ else
+ special colorCode $
+ case ord c of
+ 27 -> "^["
+ _ -> charToCode c
+
+normal colorCode s = "\x1b[" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"
+special colorCode s = "\x1b[1;" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"
+
+
+
+-- XXX assumes that the cursor is already at the input line
+renderInputLine :: Buffer -> IO ()
+renderInputLine (lhs, rhs) = do
+ --clearLine
+ putStr $ "> " ++ pp lhs ++ pp rhs
+ moveCursorLeft (length $ ppVis rhs)
+ --hFlush stdout
+ where
+ pp = concat . map reform
+ reform c =
+ if isPrint c
+ then [c]
+ else
+ "\x1b[35m" ++ (
+ case ord c of
+ 27 -> "^["
+ _ -> "\\" ++ show (ord c)
+ ) ++ "\x1b[m"
+
+ ppVis = concat . map reformVis
+ reformVis c =
+ if isPrint c
+ then [c]
+ else
+ case ord c of
+ 27 -> "^["
+ _ -> "\\" ++ show (ord c)
+
+
+
+
+
+
+clearLine =
+ putStr "\x1b[2K" >>
+ moveCursorLeft 80
+
+
+ringBell = putStr "\x07" -- BEL '\a'
+
+
+moveCursorLeft 0 = return ()
+moveCursorLeft i = putStr $ "\x1b[" ++ show i ++ "D"
+
+moveCursorRight 0 = return ()
+moveCursorRight i = putStr $ "\x1b[" ++ show i ++ "C"
+
+clearLineFromCursorRight = putStr "\x1b[0K"
+
+
+-- TODO? charToCode c = "\\x" ++ showHex (ord c)
+charToCode c = "\\x" ++ showIntAtBase 16 intToDigit (ord c) ""
+
+
+
+
+
+-- TODO pressing ESC, then F11 etc. is ugly
+nmap =
+ [ ("\x01", GotoBOL)
+ , ("\x05", GotoEOL)
+ , ("\x1b[3~", KillNextChar)
+ , ("\x1b[C", MoveCursorRight)
+ , ("\x1b[D", MoveCursorLeft)
+ , ("\x16", InsertNextCharVerbatim) -- ^V
+ , ("\x17", KillLastWord) -- ^W
+ , ("\x0a", ExecuteInputBuffer)
+ , ("\x7f", KillLastChar) -- Delete
+ , ("\x08", KillLastChar) -- BackSpace
+ ]
+ ++ [unboundSequence "\x1b[2~" "<Insert>"]
+ ++ [unboundSequence "\x1b[5~" "<Prior>"] -- page up
+ ++ [unboundSequence "\x1b[6~" "<Next>"] -- page dn
+ ++ [unboundSequence "\x1b[7~" "<Home>"]
+ ++ [unboundSequence "\x1b[8~" "<End>"]
+ ++ [unboundSequence "\x1b[2$" "<S-Insert>"]
+ ++ [unboundSequence "\x1b[5$" "<S-Prior>"] -- page up
+ ++ [unboundSequence "\x1b[6$" "<S-Next>"] -- page dn
+ ++ [unboundSequence "\x1b[7$" "<S-Home>"]
+ ++ [unboundSequence "\x1b[8$" "<S-End>"]
+ ++ [unboundSequence "\x1b\x1b[2$" "<S-M-Insert>"]
+ ++ [unboundSequence "\x1b\x1b[5$" "<S-M-Prior>"] -- page up
+ ++ [unboundSequence "\x1b\x1b[6$" "<S-M-Next>"] -- page dn
+ ++ [unboundSequence "\x1b\x1b[7$" "<S-M-Home>"]
+ ++ [unboundSequence "\x1b\x1b[8$" "<S-M-End>"]
+ ++ [unboundSequence "\x1b\x1b[A" "<M-Up>"]
+ ++ [unboundSequence "\x1b\x1b[B" "<M-Down>"]
+ ++ [unboundSequence "\x1b\x1b[C" "<M-Right>"]
+ ++ [unboundSequence "\x1b\x1b[D" "<M-Left>"]
+ ++ [unboundSequence "\x1b\x1b[a" "<S-M-Up>"]
+ ++ [unboundSequence "\x1b\x1b[b" "<S-M-Down>"]
+ ++ [unboundSequence "\x1b\x1b[c" "<S-M-Right>"]
+ ++ [unboundSequence "\x1b\x1b[d" "<S-M-Left>"]
+ ++ [unboundSequence "\x1b[a" "<S-Up>"]
+ ++ [unboundSequence "\x1b[b" "<S-Down>"]
+ ++ [unboundSequence "\x1b[c" "<S-Right>"]
+ ++ [unboundSequence "\x1b[d" "<S-Left>"]
+ ++ [unboundSequence "\x1bOa" "<C-Up>"]
+ ++ [unboundSequence "\x1bOb" "<C-Down>"]
+ ++ [unboundSequence "\x1bOc" "<C-Right>"]
+ ++ [unboundSequence "\x1bOd" "<C-Left>"]
+ ++ [unboundSequence "\x1b\x1bOa" "<C-M-Up>"]
+ ++ [unboundSequence "\x1b\x1bOb" "<C-M-Down>"]
+ ++ [unboundSequence "\x1b\x1bOc" "<C-M-Right>"]
+ ++ [unboundSequence "\x1b\x1bOd" "<C-M-Left>"]
+ ++ [unboundSequence "\x1b[11~" "<F1>"]
+ ++ [unboundSequence "\x1b[12~" "<F2>"]
+ ++ [unboundSequence "\x1b[13~" "<F3>"]
+ ++ [unboundSequence "\x1b[14~" "<F4>"]
+ ++ [unboundSequence "\x1b[15~" "<F5>"]
+ ++ [unboundSequence "\x1b[17~" "<F6>"]
+ ++ [unboundSequence "\x1b[18~" "<F7>"]
+ ++ [unboundSequence "\x1b[19~" "<F8>"]
+ ++ [unboundSequence "\x1b[20~" "<F9>"]
+ ++ [unboundSequence "\x1b[21~" "<F10>"]
+ ++ [unboundSequence "\x1b[23~" "<F11>"]
+ ++ [unboundSequence "\x1b[24~" "<F12>"]
+
+ ++ [unboundSequence "\x1b\x1b[2~" "<M-Insert>"]
+ ++ [unboundSequence "\x1b\x1b[3~" "<M-Delete>"]
+ ++ map (\ i -> unboundSequence ("\x1b\x1b[" ++ show i ++ "~")
+ ("<M-F" ++ show i ++ ">"))
+ [11..24]
+ ++ [unboundSequence "\x1b\x7f" "<M-BackSpace>"]
+ ++ [unboundSequence "\x1b\x0a" "<M-Return>"]
+
+
+unboundSequence seq name =
+ (seq, UnboundSequence seq name)
+
+
+data Mode
+ = NormalMode [(String, Command)]
+ | VerbatimMode
+
+instance Show Mode where
+ show (NormalMode _) = "normal"
+ show VerbatimMode = "verbatim"
+
+
+getCommand :: Mode -> IO Command
+getCommand (NormalMode map) = getMappedCommand map
+getCommand VerbatimMode = verbatimKeymap
+
+
+getMappedCommand :: [(String, Command)] -> IO Command
+getMappedCommand xs = do
+ c <- getChar
+ if any (isPrefixOf [c] . fst) xs
+ then rec [c]
+ else
+ if isPrint c
+ then return $ InsertChar c
+ else return $ AlertBadInput [c]
+ 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
+
+
+verbatimKeymap :: IO Command
+verbatimKeymap = do
+ c <- getChar
+ --return $ InsertCharThenChangeMode c defaultGetCommand
+ return $ InsertCharThenChangeMode c (NormalMode nmap)
+
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..bf7ea23
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,47 @@
+pname := hack
+nixpkgs := ${HOME}/src/nixpkgs
+
+configureFlags := -fdevelopment
+
+.PHONY: all build clean distclean configure run
+
+all: run
+
+clean:
+ cabal clean
+
+distclean: clean
+ rm -f result
+ rm -fR log
+
+ifeq (${NIX_MYENV_NAME},${pname})
+
+build:
+ cabal build ${pname}
+
+configure:
+ cabal configure ${configureFlags}
+
+run: build
+ mkdir -p log
+ dist/build/${pname}/${pname}
+
+else
+#
+# setup development environment (and rerun make)
+#
+
+ifdef nixpkgs
+export NIX_PATH := nixpkgs=${nixpkgs}
+endif
+
+# XXX result is a symlink we want to check
+MAKEFLAGS += -L
+
+build configure run: result
+ echo make $@ | result/bin/load-env-${pname}
+
+result: default.nix
+ nix-build $<
+
+endif
diff --git a/OldMain.hs b/OldMain.hs
new file mode 100644
index 0000000..05fb955
--- /dev/null
+++ b/OldMain.hs
@@ -0,0 +1,206 @@
+module Main where
+
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Control.Monad (forever)
+import System.IO
+import Data.IORef
+import Data.Time.Clock (getCurrentTime)
+import Data.Time.Format (formatTime)
+import System.Locale (defaultTimeLocale, rfc822DateFormat)
+import Data.Char
+import Data.List
+
+
+data Config = Config
+
+data State = State
+ { promptString :: String
+ , inputBuffer :: (String, String)
+ , getCommand :: IO Command
+ , outputLock :: MVar ()
+ }
+
+initState :: State
+initState = State "> " ("", "") defaultGetCommand
+
+
+main :: IO ()
+main = do
+ hSetEcho stdin False
+ hSetBuffering stdin NoBuffering
+
+ lock <- newMVar initState
+
+ let q = State
+ { promptString = "> "
+ , inputBuffer = ("", "")
+ , getCommand = defaultGetCommand
+ , outputLock = lock
+ }
+
+ putStr (promptString q)
+
+ forkIO $ dateThread q
+ uiThread q
+
+
+dateThread q = forever $ do
+ t <- getCurrentTime
+ withMVar (outputLock q) $ \ _ -> do
+ clearLine
+ putStrLn $ formatTime defaultTimeLocale rfc822DateFormat t
+ putStr $ (promptString q) ++ lhs ++ rhs
+ moveCursorLeft (length rhs)
+ hFlush stdout
+ return ()
+ threadDelay 1000000
+
+
+uiThread q = do
+ c <- getCommand q
+ modifyMVar_ (outputLock q) (execCommand c) >>= uiThread
+
+
+data Command
+ = AlertBadInput String
+ | InsertChar Char
+ | InsertNextCharVerbatim
+ | MoveCursorRight
+ | MoveCursorLeft
+ | KillLastWord
+ | KillLastChar
+ | ExecuteInputBuffer
+
+
+defaultGetCommand :: IO Command
+defaultGetCommand = do
+ c1 <- getChar
+ case c1 of
+ '\x1b' -> do
+ c2 <- getChar
+ case c2 of
+ '[' -> do
+ c3 <- getChar
+ case c3 of
+ 'C' -> return MoveCursorRight
+ 'D' -> return MoveCursorLeft
+ _ -> return $ AlertBadInput (c1:c2:c3:[])
+ _ -> return $ AlertBadInput (c1:c2:[])
+ _ ->
+ if isPrint c1
+ then return $ InsertChar c1
+ else
+ case ord c1 of
+ 22 -> return InsertNextCharVerbatim
+ 23 -> return KillLastWord
+ 10 -> return ExecuteInputBuffer
+ 127 -> return KillLastChar
+ _ -> return $ AlertBadInput (c1:[])
+
+
+execCommand :: String -> Command -> (String, String) -> IO (String, String)
+
+execCommand MoveCursorLeft q@State{inputBuffer=([],_)} =
+ cannotExecuteCommand q
+
+execCommand MoveCursorLeft q@State{inputBuffer=(lhs,rhs)} = do
+ clearLineFromCursorRight
+ putStr rhs
+ moveCursorLeft (length rhs + 1)
+ hFlush stdout
+ return q{inputBuffer=(init lhs, last lhs : rhs)}
+
+execCommand MoveCursorRight q@State{inputBuffer=(_,[])} =
+ cannotExecuteCommand q
+
+execCommand MoveCursorRight q@State{inputBuffer=(lhs,rhs)} = do
+ moveCursorRight 1
+ hFlush stdout
+ return q{inputBuffer=(lhs ++ [head rhs], tail rhs)}
+
+execCommand (InsertChar c) q@State{inputBuffer=(lhs,rhs)} = do
+ putChar c
+ -- TODO rhs
+ hFlush stdout
+ return q{inputBuffer=(lhs ++ [c], rhs)}
+
+--execCommand InsertNextCharVerbatim input = do
+-- return input { keymap = verbatimKeymap }
+
+
+execCommand ExecuteInputBuffer q@State{inputBuffer=(lhs,rhs)} = do
+ clearLine
+ putStrLn $ "input: <\x1b[32;1m" ++ lhs ++ rhs ++ "\x1b[m>"
+ putStr (promptString q)
+ hFlush stdout
+ return q{inputBuffer=("","")}
+
+execCommand KillLastChar q@State{inputBuffer=([],_)} =
+ cannotExecuteCommand q
+
+execCommand KillLastChar q@State{inputBuffer=(lhs,rhs)} = do
+ moveCursorLeft 1
+ clearLineFromCursorRight
+ putStr rhs
+ moveCursorLeft (length rhs)
+ hFlush stdout
+ return q{inputBuffer=(init lhs, rhs)}
+
+execCommand KillLastWord q@State{inputBuffer=([],_)} =
+ cannotExecuteCommand q
+
+execCommand KillLastWord q@State{inputBuffer=(lhs,rhs)} = do
+ let lhs' =
+ dropWhileEnd (not . isSpace) $
+ dropWhileEnd isSpace lhs
+ killedCharCount = length lhs - length lhs'
+ moveCursorLeft killedCharCount
+ clearLineFromCursorRight
+ putStr rhs
+ moveCursorLeft (length rhs)
+ hFlush stdout
+ return q{inputBuffer=(lhs', rhs)}
+
+execCommand (AlertBadInput s) q@State{inputBuffer=(lhs,rhs)} = do
+ clearLine
+ putStrLn $ "unhandled input: <" ++ (concat $ map reform s) ++ ">"
+ putStr $ (promptString q) ++ lhs ++ rhs
+ moveCursorLeft (length rhs)
+ hFlush stdout
+ return q
+ where
+ reform c =
+ if isPrint c
+ then "\x1b[31m" ++ [c] ++ "\x1b[m"
+ else
+ "\x1b[1;31m" ++ (
+ case ord c of
+ 27 -> "^["
+ _ -> "\\" ++ show (ord c)
+ ) ++ "\x1b[m"
+
+
+clearLine =
+ putStr "\x1b[2K" >>
+ moveCursorLeft 80
+
+
+
+cannotExecuteCommand input = do
+ ringBell
+ hFlush stdout
+ return input
+
+
+
+ringBell = putStr "\x07" -- BEL '\a'
+
+
+moveCursorLeft 0 = return ()
+moveCursorLeft i = putStr $ "\x1b[" ++ show i ++ "D"
+
+moveCursorRight 0 = return ()
+moveCursorRight i = putStr $ "\x1b[" ++ show i ++ "C"
+
+clearLineFromCursorRight = putStr "\x1b[0K"
diff --git a/default.nix b/default.nix
new file mode 100644
index 0000000..bba6906
--- /dev/null
+++ b/default.nix
@@ -0,0 +1,24 @@
+
+let
+ pkgs = import <nixpkgs> {};
+ hsEnv = pkgs.haskellPackages.ghcWithPackages (hsPkgs : with hsPkgs; [
+ mtl
+ ]);
+in
+
+pkgs.myEnvFun {
+ name = "hack";
+ buildInputs = with pkgs; [
+ hsEnv
+ ];
+
+ # XXX https://nixos.org/wiki/Haskell says:
+ # Since tools (such as hdevtools [snap-loader-dynamic in our case]) that
+ # rely on the ghc-api to do haskell language manipulation are sensitive
+ # to nix-wrapping of ghc, we need the extraCmds line to ensure the
+ # proper ghc-wrapping environment variables are set inside the
+ # dev-environment shell.
+ extraCmds = ''
+ $(grep export ${hsEnv.outPath}/bin/ghc)
+ '';
+}
diff --git a/defaultGetCommand.hs b/defaultGetCommand.hs
new file mode 100644
index 0000000..b82f2ce
--- /dev/null
+++ b/defaultGetCommand.hs
@@ -0,0 +1,33 @@
+
+
+
+
+defaultGetCommand :: IO Command
+defaultGetCommand = do
+ c1 <- getChar
+ case c1 of
+ '\x1b' -> do
+ c2 <- getChar
+ case c2 of
+ '[' -> do
+ c3 <- getChar
+ case c3 of
+ 'C' -> return MoveCursorRight
+ 'D' -> return MoveCursorLeft
+ '3' -> do
+ c4 <- getChar
+ case c4 of
+ '~' -> return KillNextChar
+ _ -> return $ AlertBadInput (c1:c2:c3:c4:[])
+ _ -> return $ AlertBadInput (c1:c2:c3:[])
+ _ -> return $ AlertBadInput (c1:c2:[])
+ _ ->
+ if isPrint c1
+ then return $ InsertChar c1
+ else
+ case ord c1 of
+ 22 -> return InsertNextCharVerbatim
+ 23 -> return KillLastWord
+ 10 -> return ExecuteInputBuffer
+ 127 -> return KillLastChar
+ _ -> return $ AlertBadInput (c1:[])
diff --git a/hack.cabal b/hack.cabal
new file mode 100644
index 0000000..d398a93
--- /dev/null
+++ b/hack.cabal
@@ -0,0 +1,20 @@
+Name: hack
+Version: 0.1
+Synopsis: Project Synopsis Here
+Description: Project Description Here
+License: AllRightsReserved
+Author: Author
+Maintainer: maintainer@example.com
+Stability: Experimental
+Category: Web
+Build-type: Simple
+Cabal-version: >=1.2
+
+Executable hack
+ main-is: Main.hs
+
+ Build-depends:
+ old-locale,
+ time,
+ mtl,
+ base
generated by cgit v1.2.3 (git 2.25.1) at 2025-06-16 16:08:22 +0000
[cgit] Unable to lock slot /tmp/cgit/9c300000.lock: No such file or directory (2)