move source to src/

1 files changed, 0 insertions, 554 deletions

diff --git a/Main.hs b/Main.hs
deleted file mode 100644
index 43ff393..0000000
--- a/Main.hs
+++ /dev/null
@@ -1,554 +0,0 @@
-{-# 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 ()
-
-