Output.hs

{-# LANGUAGE ForeignFunctionInterface #-}
{-# CFILES gwinsz.c #-}
module Graphics.Vty.Output ( initTermOutput
                           , clrscr
                           , getwinsize
                           , beep
                           , flush
                           , tputchar
                           , chgatt
                           , putShow
                           )
    where

import Graphics.Vty.Types
import Graphics.Vty.ControlStrings

import Control.Monad ( when )
import Data.Bits ( (.|.), (.&.), shiftR )

import Foreign.C.Types ( CLong )

import System.Console.Terminfo
import System.IO ( stdout, hFlush )

-- | Set up the terminal for output, and create an object representing the
-- initial state.  Also returns a function for shutting down the terminal access.
initTermOutput :: Terminal -> IO (TermState, IO ())
initTermOutput terminal = do 
    let cap_smcup = getCapability terminal $ tiGetStr "smcup"
    maybe (return ()) putStr cap_smcup
    putStr reset
    hFlush stdout
    return (TS 0 0 attr, uninitTermOutput terminal)

uninitTermOutput :: Terminal -> IO ()
uninitTermOutput terminal = do 
    (_,sy) <- getwinsize_
    putStr (endterm sy)
    let cap_rmcup = getCapability terminal $ tiGetStr "rmcup"
    maybe (return ()) putStr cap_rmcup
    hFlush stdout

-- | Force sent commands to be respected.
flush :: TermState -> IO TermState
flush ts = hFlush stdout >> return ts

-- | Reset the screen.
clrscr :: TermState -> IO TermState
clrscr _ts = do putStr reset
                return (TS 0 0 attr)

-- ANSI specific bits
chgatt :: Attr -> IO ()
chgatt (Attr bf)
      = putStr "\ESC[0;" >>
        putShow (bf .&. 0xFF) >> 
        putStr ";" >> putShow ((bf `shiftR` 8) .&. 0xFF) >> 
        0x10000 ? ";1" >>
        0x20000 ? ";5" >> 0x40000 ? ";7" >> 0x80000 ? ";2" >> 0x100000 ? ";4" >> 
        putStr "m"
    where
      {-# INLINE (?) #-}
      (?) :: Int -> [Char] -> IO ()
      field ? x | bf .&. field == 0 = return ()
                | otherwise         = putStr x

tputchar :: Char -> IO ()
tputchar ch | ich < 0x80    = pch ich
            | ich < 0x800   = pch (0xC0 .|. (ich `usr` 6)) >> pch (0x80 .|. (0x3F .&. ich))
            | ich < 0x10000 = pch (0xE0 .|. (ich `usr` 12)) >> pch (0x80 .|. (0x3F .&. (ich `usr` 6))) >>
                              pch (0x80 .|. (0x3F .&. ich))
            | otherwise     = pch (0xF0 .|. (ich `usr` 24)) >> pch (0x80 .|. (0x3F .&. (ich `usr` 12))) >>
                              pch (0x80 .|. (0x3F .&. (ich `usr` 6))) >> pch (0x80 .|. (0x3F .&. ich))
  where ich = fromEnum ch
        pch = putChar . toEnum
        usr = shiftR

putShow :: Int -> IO ()
putShow n = when (ini /= 0) (putShow ini) >> putChar (toEnum (lst + 48))
    where (ini, lst) = divMod n 10
-- {-# INLINE putShow #-}

foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong
getwinsize_ :: IO (Int,Int)
getwinsize_ = do (a,b) <- (`divMod` 65536) `fmap` c_get_window_size
                 return (fromIntegral b, fromIntegral a)
getwinsize :: TermState -> IO ((Int,Int), TermState)
getwinsize ts = do (a,b) <- (`divMod` 65536) `fmap` c_get_window_size
                   return ((fromIntegral b, fromIntegral a), ts)

reset :: String
reset =  -- "\ESCc"  ++ -- full reset
      utf8CharSet ++ 
      setCursorPosition 1 1 ++
      "\ESC[2J" -- erase all

-- | Make the terminal beep.
beep :: IO ()
beep = putStr "\BEL" 

-- | Restore the terminal to a good state for the shell.
-- Parameter is the line where the cursor should appear.
endterm :: Int -> [Char]
endterm sy = setCursorPosition sy 1 ++
             "\ESC[0;39;49m" ++ -- graphic rendition
             defaultCharSet ++ 
             "\CR" ++ 
             cvis ++
             "\ESC[K" -- erase line

defaultCharSet, utf8CharSet :: String
defaultCharSet = "\ESC%@"
utf8CharSet    = "\ESC%G"