{-# LANGUAGE BangPatterns #-}

-- | The inline module provides a limited interface to changing the
-- style of terminal output. The intention is for this interface to be
-- used inline with other output systems.
--
-- The changes specified by the InlineM monad are applied to the
-- terminal's display attributes. These display attributes affect the
-- display of all following text output to the terminal file descriptor.
--
-- For example, in an IO monad the following code will print the text
-- \"Not styled. \" Followed by the text \" Styled! \" drawn over a red
-- background and underlined.
--
-- @
--      putStr \"Not styled. \"
--      putAttrChange_ $ do
--          backColor red
--          applyStyle underline
--      putStr \" Styled! \"
--      putAttrChange_ $ defaultAll
--      putStrLn \"Not styled.\"
-- @
--
-- 'putAttrChange' emits the control codes to the terminal device
-- attached to 'Handle'. This is a duplicate of the 'stdout' handle when
-- the 'terminalHandle' was (first) acquired. If 'stdout' has since been
-- changed then 'putStr', 'putStrLn', 'print' etc. will output to a
-- different 'Handle' than 'putAttrChange'.
--
-- Copyright 2009-2010 Corey O'Connor
module Graphics.Vty.Inline
  ( module Graphics.Vty.Inline
  , withVty
  )
where

import Graphics.Vty
import Graphics.Vty.DisplayAttributes
import Graphics.Vty.Inline.Unsafe

import Blaze.ByteString.Builder (writeToByteString)

import Control.Monad.State.Strict

import Data.Bits ( (.&.), complement )
import Data.IORef

import System.IO

type InlineM v = State Attr v

-- | Set the background color to the provided 'Color'.
backColor :: Color -> InlineM ()
backColor c = modify $ flip mappend ( currentAttr `withBackColor` c )

-- | Set the foreground color to the provided 'Color'.
foreColor :: Color -> InlineM ()
foreColor c = modify $ flip mappend ( currentAttr `withForeColor` c )

-- | Attempt to change the 'Style' of the following text..
--
-- If the terminal does not support the style change then no error is
-- produced. The style can still be removed.
applyStyle :: Style -> InlineM ()
applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s )

-- | Attempt to remove the specified 'Style' from the display of the
-- following text.
--
-- This will fail if 'applyStyle' for the given style has not been
-- previously called.
removeStyle :: Style -> InlineM ()
removeStyle sMask = modify $ \attr ->
    let style' = case attrStyle attr of
                    Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
                    KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
                    SetTo s -> s .&. complement sMask
    in attr { attrStyle = SetTo style' }

-- | Reset the display attributes.
defaultAll :: InlineM ()
defaultAll = put defAttr

-- | Apply the provided display attribute changes to the given terminal
-- output device.
--
-- This does not flush the terminal.
putAttrChange :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m ()
putAttrChange out c = liftIO $ do
    bounds <- displayBounds out
    dc <- displayContext out bounds
    mfattr <- prevFattr <$> readIORef (assumedStateRef out)
    fattr <- case mfattr of
                Nothing -> do
                    liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc
                    return $ FixedAttr defaultStyleMask Nothing Nothing
                Just v -> return v
    let attr = execState c currentAttr
        attr' = limitAttrForDisplay out attr
        fattr' = fixDisplayAttr fattr attr'
        diffs = displayAttrDiffs fattr fattr'
    outputByteBuffer out $ writeToByteString $ writeSetAttr dc fattr attr' diffs
    modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }
    inlineHack dc

-- | Apply the provided display attributes changes to the terminal
-- output device.
--
-- This will flush the terminal output.
putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()
putAttrChange_ c = liftIO $ withOutput $ \out -> do
    hFlush stdout
    putAttrChange out c
    hFlush stdout