move source to src/

1 files changed, 554 insertions, 0 deletions

diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..43ff393
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,554 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Main where
+
+import Control.Applicative
+import Control.Concurrent
+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
+
+import GHC.Stats (getGCStats)
+
+import Control.Monad.Error
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+
+import Buffer
+import Process
+
+data VTConfig = VTConfig
+    { withOutput :: IO () -> IO ()
+    }
+
+data VTState = VTState
+    { buffer :: Buffer
+    , mode :: Mode
+    , processCount :: Int
+    }
+
+main :: IO ()
+main = do
+  hSetEcho stdin False
+  hSetBuffering stdin NoBuffering
+
+  -- WINCH
+  -- TODO installHandler 28 (Catch $ ioctl 0 ...) Nothing
+
+  let st = VTState
+          { mode = InsertMode
+          , buffer = ("", "")
+          , processCount = 0
+          }
+
+  lockRef <- newMVar ()
+  qRef <- newIORef st
+  let _putState = writeIORef qRef -- TODO atomicModifyIORef (?)
+      _getState = readIORef qRef
+      _withOutput a = do
+          q <- _getState
+          withMVar lockRef $ \ _ -> do
+              clearLine
+              a
+              renderInputLine (mode q) (buffer q)
+              hFlush stdout
+
+  let cf = VTConfig
+            { withOutput = _withOutput
+            }
+
+  -- render initial input line
+  _withOutput $ return ()
+
+  forkIO $ dateThread _withOutput 1000000
+
+  uiThread cf _putState _getState
+
+
+dateThread :: (IO () -> IO ()) -> Int -> IO ()
+dateThread _withOutput delay = forever $ do
+    t <- liftIO getCurrentTime
+    _withOutput $
+      putStrLn $ formatTime defaultTimeLocale rfc822DateFormat t
+    threadDelay delay
+
+
+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
+
+    -- TODO only putState if it has changed (?)
+    putState q1
+
+    let mbErr = case eitCmd of
+                  Left err -> Just err
+                  Right c ->
+                      -- TODO move this to execCommand / throwError
+                      case c of
+                        MotionCommand motion | buffer q0 == buffer q1 ->
+                            Just (OtherError $ "motion failed: " ++ show motion)
+                        _ ->
+                            Nothing
+
+    withOutput cf $ do
+        forM_ lns putStrLn
+
+        case mbErr of
+          Just err -> ringBell >> putStrLn (prettyError err)
+          Nothing -> return ()
+
+        --when (mode st /= mode st') $ do
+        --    putStrLn $ "change mode: " ++ (show $ mode st')
+
+
+
+data Command
+  = AlertBadInput String
+  | InsertString String
+  | KillLastWord
+  | KillLastChar
+  | KillNextChar
+  | ExecuteInputBuffer
+  | MotionCommand LeftRightMotion
+  | ChangeMode Mode
+  -- TODO Move Count Motion
+  --      Delete Count Register Motion
+  --      etc.
+  | Combine Command Command
+  | Nop
+  | RingBell
+
+instance Monoid Command where
+    mempty = Nop
+    mappend = Combine
+
+
+
+data ExecError
+  = UnhandledInputError String
+  | OtherError String
+
+instance Error ExecError where
+  noMsg = OtherError "something went wrong"
+
+prettyError :: ExecError -> String
+prettyError e = rec e
+  where
+    color cc s = "\x1b[" ++ cc ++ "m" ++ s ++ "\x1b[m"
+
+    rec (UnhandledInputError s) =
+      color "31" $ "unhandled input: <" ++ (pp "31;1" s) ++ "\x1b[;31m>"
+
+    rec (OtherError s) =
+      color "31" $ "error: " ++ s
+
+    -- TODO cc is ColorCode
+    pp cc = concat . map (pp1 cc)
+    pp1 cc c
+      | isPrint c = [c]
+      | otherwise = specialChar cc $
+        case c of
+          '\x1b' -> "^["
+          _ -> charToCode c
+    specialChar cc s = "\x1b[1;35m" ++ s ++ "\x1b[;" ++ cc ++ "m"
+
+
+
+
+modifyBuffer :: (Buffer -> Buffer) -> VT ()
+modifyBuffer f =
+    modify $ \st -> st { buffer = f (buffer st) }
+
+
+
+newtype VT a = VT
+    (ReaderT VTConfig
+        (ErrorT ExecError
+            (WriterT [String]
+                (StateT VTState IO
+        )))
+        a)
+  deriving
+    ( Applicative
+    , Functor
+    , Monad
+    , MonadError ExecError
+    , MonadIO
+    , MonadReader VTConfig
+    , MonadState VTState
+    , MonadWriter [String]
+    )
+
+runVT ::
+    VTConfig -> VTState -> VT a -> IO ((Either ExecError a, [String]), VTState)
+
+runVT cf st (VT a) =
+    runStateT (runWriterT (runErrorT (runReaderT a cf))) st
+
+
+
+insertString :: String -> Buffer -> Buffer
+insertString s (ls, rs) = (ls ++ s, rs)
+
+
+execCommand :: Command -> VT ()
+
+execCommand (MotionCommand x) = do
+    modifyBuffer (move x)
+    -- TODO apply mode constraints somewhere else
+    q <- get
+    when (mode q == NormalMode) $
+      when (null $ snd $ buffer q) $
+        modifyBuffer (gotoLeft 1)
+
+execCommand (ChangeMode m) =
+    modify $ \ q -> q { mode = m }
+
+execCommand (InsertString s) =
+    modifyBuffer (insertString s)
+
+execCommand ExecuteInputBuffer = do
+
+    ---- XXX hack to replace empty command line
+    --gets (null . showBuffer . buffer) >>= flip when
+    --    (modify $ \q -> q { buffer = ("!","") })
+
+    st <- get
+
+    case showBuffer (buffer st) of
+      ":s" -> do
+          s <- liftIO getGCStats
+          tell [ show s ]
+      '!' : cmdline -> do
+          --tell [ "spawn: " ++ cmdline ]
+          -- "input: <" ++ (concat $ map (reform 32) $ showBuffer b) ++ ">" ]
+          -- TODO register process
+          i <- state $ \ q ->
+              let i = processCount q + 1
+              in (i, q { processCount = i })
+          cf <- ask
+          liftIO $ forkIO $ spawn i (withOutput cf) cmdline
+          return ()
+      "" -> do
+          liftIO ringBell
+      s -> do
+          tell [ "input: <" ++ (concat $ map (reform 32) s) ++ ">" ]
+
+    modifyBuffer (const emptyBuffer)
+
+execCommand KillNextChar = do
+    get >>= flip (when . null . snd . buffer)
+                 (throwError $ OtherError "nothing to kill right")
+    modifyBuffer $ \(lhs, _:rhs') -> (lhs, rhs')
+
+execCommand KillLastChar = do
+    get >>= flip (when . null . fst . buffer)
+                 (throwError $ OtherError "nothing to kill left")
+    modifyBuffer $ \(lhs, rhs) -> (init lhs, rhs)
+
+execCommand KillLastWord = do
+    get >>= flip (when . null . fst . buffer)
+                 (throwError $ OtherError "nothing to kill left")
+    modifyBuffer $
+      \(lhs, rhs) -> (foldr dropWhileEnd lhs [not . isSpace, isSpace], rhs)
+
+execCommand (AlertBadInput s) =
+    throwError (UnhandledInputError s)
+
+execCommand (Combine c1 c2) = do
+    cf <- ask
+    q0 <- get
+
+    ((eSt1, lines1), q1) <- liftIO $ runVT cf q0 (execCommand c1)
+
+    -- TODO "stack trace"
+    whenLeft eSt1 throwError
+
+    ((eSt2, lines2), q2) <- liftIO $ runVT cf q1 (execCommand c2)
+
+    -- TODO "stack trace"
+    whenLeft eSt2 throwError
+
+    tell lines1
+    tell lines2
+
+    put q2
+
+execCommand Nop = return ()
+
+execCommand RingBell = liftIO ringBell
+
+
+reform :: Int -> Char -> String
+reform colorCode c =
+    if isPrint c
+      then normal colorCode [c]
+      else
+        special colorCode $
+          case ord c of
+            27 -> "^["
+            _ -> charToCode c
+
+normal :: Int -> String -> String
+normal colorCode s = "\x1b[" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"
+
+special :: Int -> String -> String
+special colorCode s = "\x1b[1;" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"
+
+
+
+-- XXX assumes that the cursor is already at the (cleared) input line
+renderInputLine :: Mode -> Buffer -> IO ()
+renderInputLine m (lhs, rhs) = do
+    clearLine -- TODO this is required for drawing the mode on the right side
+    saveCursor
+    moveCursorRight 1024
+    moveCursorLeft (length (show m) - 1)
+    putStr $ "\x1b[1;30m" ++ show m ++ "\x1b[m"
+    unsaveCursor
+
+    let promptString = case m of
+                        NormalMode -> "\x1b[33;1m@\x1b[m "
+                        InsertMode -> "> "
+                        VerbatimMode -> "\x1b[34;1m^\x1b[m "
+
+    putStr $ promptString ++ pp lhs ++ pp rhs
+    moveCursorLeft (length $ ppVis rhs)
+  where
+    pp = concat . map reform'
+
+    -- TODO unify reform and reform'
+    reform' c =
+      if isPrint c
+        then [c]
+        else
+          "\x1b[35m" ++ (
+            case ord c of
+              27 -> "^["
+              _ -> charToCode c
+          ) ++ "\x1b[m"
+
+    ppVis = concat . map reformVis
+    reformVis c =
+      if isPrint c
+        then [c]
+        else
+            case ord c of
+              27 -> "^["
+              _ -> charToCode c
+
+
+
+
+
+
+clearLine :: IO ()
+clearLine =
+    putStr "\x1b[2K" >>
+    moveCursorLeft 1024
+
+
+ringBell :: IO ()
+ringBell = putStr "\x07" -- BEL '\a'
+
+
+saveCursor :: IO ()
+saveCursor = putStr "\x1b[s"
+
+unsaveCursor :: IO ()
+unsaveCursor = putStr "\x1b[u"
+
+
+moveCursorLeft :: Int -> IO ()
+moveCursorLeft 0 = return ()
+moveCursorLeft i = putStr $ "\x1b[" ++ show i ++ "D"
+
+
+moveCursorRight :: Int -> IO ()
+moveCursorRight 0 = return ()
+moveCursorRight i = putStr $ "\x1b[" ++ show i ++ "C"
+
+
+-- TODO? charToCode c = "\\x" ++ showHex (ord c)
+charToCode :: Char -> String
+charToCode c = "\\x" ++ showIntAtBase 16 intToDigit (ord c) ""
+
+
+
+nmap :: Keymap
+nmap =
+  [ ("i", ChangeMode InsertMode)
+  , ("a", ChangeMode InsertMode <> MotionCommand (GotoRight 1))
+  , ("I", ChangeMode InsertMode <> MotionCommand GotoFirstChar)
+  , ("A", ChangeMode InsertMode <> MotionCommand GotoEndOfLine)
+  , ("0", MotionCommand GotoFirstChar)
+  , ("$", MotionCommand GotoEndOfLine)
+  , ("h", MotionCommand $ GotoLeft 1)
+  , ("l", MotionCommand $ GotoRight 1)
+  , ("b", MotionCommand $ WordsBackward 1)
+  , ("w", MotionCommand $ WordsForward 1)
+  , ("\x1b[C", MotionCommand $ GotoRight 1)
+  , ("\x1b[D", MotionCommand $ GotoLeft 1)
+  , ("\x0a", ExecuteInputBuffer <> ChangeMode InsertMode)
+  , ("\x1b", RingBell) -- TODO cancel any unfinished commands
+  ]
+
+
+imap :: Keymap
+imap =
+  [ ("\x1b", ChangeMode NormalMode <> MotionCommand (GotoLeft 1))
+  , ("\x01", MotionCommand GotoFirstChar)
+  , ("\x05", MotionCommand GotoEndOfLine)
+  , ("\x1b[3~", KillNextChar)
+  , ("\x1b[C", MotionCommand $ GotoRight 1)
+  , ("\x1b[D", MotionCommand $ GotoLeft 1)
+  , ("\x16", ChangeMode VerbatimMode) -- ^V
+  , ("\x17", KillLastWord) -- ^W
+  , ("\x0a", ExecuteInputBuffer)
+  , ("\x7f", KillLastChar) -- Delete
+  , ("\x08", KillLastChar) -- BackSpace
+  , ("\x1bOc", MotionCommand $ WordsForward 1)
+  , ("\x1bOd", MotionCommand $ WordsBackward 1)
+  ]
+
+
+type Keymap = [(String, Command)]
+
+data Mode
+  = InsertMode
+  | NormalMode
+  | VerbatimMode
+  deriving (Eq)
+
+instance  Show Mode  where
+  show NormalMode = "normal"
+  show InsertMode = "insert"
+  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
+
+
+-- TODO Control.Monad.whenLeft
+whenLeft :: Monad m => Either a b -> (a -> m ()) -> m ()
+whenLeft (Left x) f = f x
+whenLeft _ _ = return ()
+
+