1 files changed, 206 insertions, 0 deletions
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"