path: root/Main-gut-ohne-transformers.hs

{-# 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)