{-# 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 InlineState v

data InlineState =
    InlineState { InlineState -> Attr
inlineAttr :: Attr
                , InlineState -> Bool
inlineUrlsEnabled :: Bool
                }

-- | Set the background color to the provided 'Color'.
backColor :: Color -> InlineM ()
backColor :: Color -> InlineM ()
backColor Color
c = (InlineState -> InlineState) -> InlineM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InlineState -> InlineState) -> InlineM ())
-> (InlineState -> InlineState) -> InlineM ()
forall a b. (a -> b) -> a -> b
$ \InlineState
s ->
    InlineState
s { inlineAttr :: Attr
inlineAttr = InlineState -> Attr
inlineAttr InlineState
s Attr -> Attr -> Attr
forall a. Monoid a => a -> a -> a
`mappend` (Attr
currentAttr Attr -> Color -> Attr
`withBackColor` Color
c)
      }

-- | Set the foreground color to the provided 'Color'.
foreColor :: Color -> InlineM ()
foreColor :: Color -> InlineM ()
foreColor Color
c = (InlineState -> InlineState) -> InlineM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InlineState -> InlineState) -> InlineM ())
-> (InlineState -> InlineState) -> InlineM ()
forall a b. (a -> b) -> a -> b
$ \InlineState
s ->
    InlineState
s { inlineAttr :: Attr
inlineAttr = InlineState -> Attr
inlineAttr InlineState
s Attr -> Attr -> Attr
forall a. Monoid a => a -> a -> a
`mappend` (Attr
currentAttr Attr -> Color -> Attr
`withForeColor` Color
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 :: Style -> InlineM ()
applyStyle Style
st = (InlineState -> InlineState) -> InlineM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InlineState -> InlineState) -> InlineM ())
-> (InlineState -> InlineState) -> InlineM ()
forall a b. (a -> b) -> a -> b
$ \InlineState
s ->
    InlineState
s { inlineAttr :: Attr
inlineAttr = InlineState -> Attr
inlineAttr InlineState
s Attr -> Attr -> Attr
forall a. Monoid a => a -> a -> a
`mappend` (Attr
currentAttr Attr -> Style -> Attr
`withStyle` Style
st)
      }

-- | 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 :: Style -> InlineM ()
removeStyle Style
sMask = (InlineState -> InlineState) -> InlineM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InlineState -> InlineState) -> InlineM ())
-> (InlineState -> InlineState) -> InlineM ()
forall a b. (a -> b) -> a -> b
$ \InlineState
s ->
    InlineState
s { inlineAttr :: Attr
inlineAttr =
          let style' :: Style
style' = case Attr -> MaybeDefault Style
attrStyle (InlineState -> Attr
inlineAttr InlineState
s) of
                MaybeDefault Style
Default -> [Char] -> Style
forall a. HasCallStack => [Char] -> a
error ([Char] -> Style) -> [Char] -> Style
forall a b. (a -> b) -> a -> b
$ [Char]
"Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
                MaybeDefault Style
KeepCurrent -> [Char] -> Style
forall a. HasCallStack => [Char] -> a
error ([Char] -> Style) -> [Char] -> Style
forall a b. (a -> b) -> a -> b
$ [Char]
"Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
                SetTo Style
st -> Style
st Style -> Style -> Style
forall a. Bits a => a -> a -> a
.&. Style -> Style
forall a. Bits a => a -> a
complement Style
sMask
          in (InlineState -> Attr
inlineAttr InlineState
s) { attrStyle :: MaybeDefault Style
attrStyle = Style -> MaybeDefault Style
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo Style
style' }
      }

-- | Reset the display attributes.
defaultAll :: InlineM ()
defaultAll :: InlineM ()
defaultAll = (InlineState -> InlineState) -> InlineM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InlineState -> InlineState) -> InlineM ())
-> (InlineState -> InlineState) -> InlineM ()
forall a b. (a -> b) -> a -> b
$ \InlineState
s -> InlineState
s { inlineAttr :: Attr
inlineAttr = Attr
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 :: Output -> InlineM () -> m ()
putAttrChange Output
out InlineM ()
c = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    DisplayRegion
bounds <- Output -> IO DisplayRegion
displayBounds Output
out
    DisplayContext
dc <- Output -> DisplayRegion -> IO DisplayContext
displayContext Output
out DisplayRegion
bounds
    Maybe FixedAttr
mfattr <- AssumedState -> Maybe FixedAttr
prevFattr (AssumedState -> Maybe FixedAttr)
-> IO AssumedState -> IO (Maybe FixedAttr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef AssumedState -> IO AssumedState
forall a. IORef a -> IO a
readIORef (Output -> IORef AssumedState
assumedStateRef Output
out)
    FixedAttr
fattr <- case Maybe FixedAttr
mfattr of
                Maybe FixedAttr
Nothing -> do
                    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Output -> ByteString -> IO ()
outputByteBuffer Output
out (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Write -> ByteString
writeToByteString (Write -> ByteString) -> Write -> ByteString
forall a b. (a -> b) -> a -> b
$ DisplayContext -> Bool -> Write
writeDefaultAttr DisplayContext
dc Bool
False
                    FixedAttr -> IO FixedAttr
forall (m :: * -> *) a. Monad m => a -> m a
return (FixedAttr -> IO FixedAttr) -> FixedAttr -> IO FixedAttr
forall a b. (a -> b) -> a -> b
$ Style -> Maybe Color -> Maybe Color -> Maybe Text -> FixedAttr
FixedAttr Style
defaultStyleMask Maybe Color
forall a. Maybe a
Nothing Maybe Color
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
                Just FixedAttr
v -> FixedAttr -> IO FixedAttr
forall (m :: * -> *) a. Monad m => a -> m a
return FixedAttr
v
    let InlineState Attr
attr Bool
urlsEnabled = InlineM () -> InlineState -> InlineState
forall s a. State s a -> s -> s
execState InlineM ()
c (Attr -> Bool -> InlineState
InlineState Attr
currentAttr Bool
False)
        attr' :: Attr
attr' = Output -> Attr -> Attr
limitAttrForDisplay Output
out Attr
attr
        fattr' :: FixedAttr
fattr' = FixedAttr -> Attr -> FixedAttr
fixDisplayAttr FixedAttr
fattr Attr
attr'
        diffs :: DisplayAttrDiff
diffs = FixedAttr -> FixedAttr -> DisplayAttrDiff
displayAttrDiffs FixedAttr
fattr FixedAttr
fattr'
    Output -> ByteString -> IO ()
outputByteBuffer Output
out (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Write -> ByteString
writeToByteString (Write -> ByteString) -> Write -> ByteString
forall a b. (a -> b) -> a -> b
$ DisplayContext
-> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
writeSetAttr DisplayContext
dc Bool
urlsEnabled FixedAttr
fattr Attr
attr' DisplayAttrDiff
diffs
    IORef AssumedState -> (AssumedState -> AssumedState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (Output -> IORef AssumedState
assumedStateRef Output
out) ((AssumedState -> AssumedState) -> IO ())
-> (AssumedState -> AssumedState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AssumedState
s -> AssumedState
s { prevFattr :: Maybe FixedAttr
prevFattr = FixedAttr -> Maybe FixedAttr
forall a. a -> Maybe a
Just FixedAttr
fattr' }
    DisplayContext -> IO ()
inlineHack DisplayContext
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_ :: InlineM () -> m ()
putAttrChange_ InlineM ()
c = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (Output -> IO ()) -> IO ()
forall b. (Output -> IO b) -> IO b
withOutput ((Output -> IO ()) -> IO ()) -> (Output -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Output
out -> do
    Handle -> IO ()
hFlush Handle
stdout
    Output -> InlineM () -> IO ()
forall (m :: * -> *).
(Applicative m, MonadIO m) =>
Output -> InlineM () -> m ()
putAttrChange Output
out InlineM ()
c
    Handle -> IO ()
hFlush Handle
stdout