content: {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE RecordWildCards, CPP #-}
  -- | This module provides an abstract interface for performing terminal
  -- output and functions for accessing the current terminal or a specific
  -- terminal device.
  module Graphics.Vty.Output
    ( Output(..)
    , AssumedState(..)
    , DisplayContext(..)
    , Mode(..)
    , displayContext
    , outputPicture
    , initialAssumedState
    , limitAttrForDisplay
    , setCursorPos
    , hideCursor
    , showCursor
    )
  where
  
  import Blaze.ByteString.Builder (Write, writeToByteString)
  import Blaze.ByteString.Builder.ByteString (writeByteString)
  import Control.Monad (when)
  import qualified Data.ByteString as BS
  import Data.IORef
  import qualified Data.Vector as Vector
  #if !MIN_VERSION_base(4,11,0)
  import Data.Monoid ((<>))
  #endif
  import qualified Data.Text.Encoding as T
  import qualified Data.Text.Lazy as TL
  
  import Graphics.Vty.Attributes
  import Graphics.Vty.DisplayAttributes
  import Graphics.Vty.Image (DisplayRegion, regionWidth, regionHeight)
  import Graphics.Vty.Picture
  import Graphics.Vty.PictureToSpans
  import Graphics.Vty.Span
  
  -- | Modal terminal features that can be enabled and disabled.
  data Mode = Mouse
            -- ^ Mouse mode (whether the terminal is configured to provide
            -- mouse input events)
            | BracketedPaste
            -- ^ Paste mode (whether the terminal is configured to provide
            -- events on OS pastes)
            | Focus
            -- ^ Focus-in/focus-out events (whether the terminal is
            -- configured to provide events on focus change)
            | Hyperlink
            -- ^ Hyperlink mode via the 'withURL' attribute modifier (see
            -- https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).
            -- Note that this may not work gracefully in all terminal
            -- emulators so be sure to test this mode with the terminals
            -- you intend to support. It is off by default.
            deriving (Eq, Read, Show)
  
  -- | The library's device output abstraction. Platform-specific
  -- implementations must implement an 'Output' and provide it to
  -- 'Graphics.Vty.mkVtyFromPair'.
  data Output = Output
      { -- | Text identifier for the output device. Used for debugging.
        terminalID :: String
        -- | Release the terminal just prior to application exit and reset
        -- it to its state prior to application startup.
      , releaseTerminal :: IO ()
        -- | Clear the display and initialize the terminal to some initial
        -- display state.
        --
        -- The expectation of a program is that the display starts in some
        -- The initial state. initial state would consist of fixed values:
        --
        --  - cursor at top left
        --  - UTF-8 character encoding
        --  - drawing characteristics are the default
      , reserveDisplay :: IO ()
        -- | Return the display to the state before `reserveDisplay` If no
        -- previous state then set the display state to the initial state.
      , releaseDisplay :: IO ()
        -- | Sets the current display bounds (width, height).
      , setDisplayBounds :: (Int, Int) -> IO ()
        -- | Returns the current display bounds.
      , displayBounds :: IO DisplayRegion
        -- | Output the bytestring to the terminal device.
      , outputByteBuffer :: BS.ByteString -> IO ()
        -- | Specifies whether the cursor can be shown / hidden.
      , supportsCursorVisibility :: Bool
        -- | Indicates support for terminal modes for this output device.
      , supportsMode :: Mode -> Bool
        -- | Enables or disables a mode (does nothing if the mode is
        -- unsupported).
      , setMode :: Mode -> Bool -> IO ()
        -- | Returns whether a mode is enabled.
      , getModeStatus :: Mode -> IO Bool
      , assumedStateRef :: IORef AssumedState
        -- | Acquire display access to the given region of the display.
        -- Currently all regions have the upper left corner of (0,0) and
        -- the lower right corner at (max displayWidth providedWidth, max
        -- displayHeight providedHeight)
      , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext
        -- | Ring the terminal bell if supported.
      , ringTerminalBell :: IO ()
        -- | Returns whether the terminal has an audio bell feature.
      , supportsBell :: IO Bool
        -- | Returns whether the terminal supports italicized text.
        --
        -- This is terminal-dependent and should make a best effort to
        -- determine whether this feature is supported, but even if the
        -- terminal advertises support (e.g. via terminfo) that might not
        -- be a reliable indicator of whether the feature will work as
        -- desired.
      , supportsItalics :: IO Bool
        -- | Returns whether the terminal supports strikethrough text.
        --
        -- This is terminal-dependent and should make a best effort to
        -- determine whether this feature is supported, but even if the
        -- terminal advertises support (e.g. via terminfo) that might not
        -- be a reliable indicator of whether the feature will work as
        -- desired.
      , supportsStrikethrough :: IO Bool
        -- | Returns how many colors the terminal supports.
      , outputColorMode :: ColorMode
        -- | Set the output's window title, if any.
      , setOutputWindowTitle :: String -> IO ()
      }
  
  -- | Sets the cursor position to the given output column and row.
  --
  -- This is not necessarily the same as the character position with the
  -- same coordinates. Characters can be a variable number of columns in
  -- width.
  --
  -- Currently, the only way to set the cursor position to a given
  -- character coordinate is to specify the coordinate in the Picture
  -- instance provided to 'outputPicture' or 'refresh'.
  setCursorPos :: Output -> Int -> Int -> IO ()
  setCursorPos t x y = do
      bounds <- displayBounds t
      when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do
          dc <- displayContext t bounds
          outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
  
  -- | Hides the cursor.
  hideCursor :: Output -> IO ()
  hideCursor t = do
      bounds <- displayBounds t
      dc <- displayContext t bounds
      outputByteBuffer t $ writeToByteString $ writeHideCursor dc
  
  -- | Shows the cursor.
  showCursor :: Output -> IO ()
  showCursor t = do
      bounds <- displayBounds t
      dc <- displayContext t bounds
      outputByteBuffer t $ writeToByteString $ writeShowCursor dc
  
  displayContext :: Output -> DisplayRegion -> IO DisplayContext
  displayContext t = mkDisplayContext t t
  
  data AssumedState = AssumedState
      { prevFattr :: Maybe FixedAttr
      , prevOutputOps :: Maybe DisplayOps
      }
  
  initialAssumedState :: AssumedState
  initialAssumedState = AssumedState Nothing Nothing
  
  data DisplayContext = DisplayContext
      { contextDevice :: Output
      -- | Provide the bounds of the display context.
      , contextRegion :: DisplayRegion
      -- | Sets the output position to the specified row and column
      -- where the number of bytes required for the control codes can be
      -- specified seperate from the actual byte sequence.
      , writeMoveCursor :: Int -> Int -> Write
      , writeShowCursor :: Write
      , writeHideCursor :: Write
      -- Ensure that the specified output attributes will be applied to
      -- all the following text until the next output attribute change
      -- where the number of bytes required for the control codes can be
      -- specified seperately from the actual byte sequence. The required
      -- number of bytes must be at least the maximum number of bytes
      -- required by any attribute changes. The serialization equations
      -- must provide the ptr to the next byte to be specified in the
      -- output buffer.
      --
      -- The currently applied display attributes are provided as well.
      -- The Attr data type can specify the style or color should not be
      -- changed from the currently applied display attributes. In order
      -- to support this the currently applied display attributes are
      -- required. In addition it may be possible to optimize the state
      -- changes based off the currently applied display attributes.
      , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
      -- | Reset the display attributes to the default display attributes.
      , writeDefaultAttr :: Bool -> Write
      , writeRowEnd :: Write
      -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
      , inlineHack :: IO ()
      }
  
  -- | All terminals serialize UTF8 text to the terminal device exactly as
  -- serialized in memory.
  writeUtf8Text  :: BS.ByteString -> Write
  writeUtf8Text = writeByteString
  
  -- | Displays the given `Picture`.
  --
  --      1. The image is cropped to the display size.
  --
  --      2. Converted into a sequence of attribute changes and text spans.
  --
  --      3. The cursor is hidden.
  --
  --      4. Serialized to the display.
  --
  --      5. The cursor is then shown and positioned or kept hidden.
  outputPicture :: DisplayContext -> Picture -> IO ()
  outputPicture dc pic = do
      urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink
      as <- readIORef (assumedStateRef $ contextDevice dc)
      let manipCursor = supportsCursorVisibility (contextDevice dc)
          r = contextRegion dc
          ops = displayOpsForPic pic r
          initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing
          -- Diff the previous output against the requested output.
          -- Differences are currently on a per-row basis.
          diffs :: [Bool] = case prevOutputOps as of
              Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True
              Just previousOps -> if affectedRegion previousOps /= affectedRegion ops
                  then replicate (displayOpsRows ops) True
                  else Vector.toList $ Vector.zipWith (/=) previousOps ops
          -- build the Write corresponding to the output image
          out = (if manipCursor then writeHideCursor dc else mempty)
                `mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops
                `mappend`
                  (let (w,h) = contextRegion dc
                       clampX = max 0 . min (w-1)
                       clampY = max 0 . min (h-1) in
                   case picCursor pic of
                      _ | not manipCursor -> mempty
                      NoCursor            -> mempty
                      AbsoluteCursor x y ->
                          writeShowCursor dc `mappend`
                          writeMoveCursor dc (clampX x) (clampY y)
                      PositionOnly isAbs x y ->
                          if isAbs
                             then writeMoveCursor dc (clampX x) (clampY y)
                             else let (ox, oy) = charToOutputPos m (clampX x, clampY y)
                                      m = cursorOutputMap ops $ picCursor pic
                                  in writeMoveCursor dc (clampX ox) (clampY oy)
                      Cursor x y           ->
                          let m = cursorOutputMap ops $ picCursor pic
                              (ox, oy) = charToOutputPos m (clampX x, clampY y)
                          in writeShowCursor dc `mappend`
                             writeMoveCursor dc (clampX ox) (clampY oy)
                  )
      -- ... then serialize
      outputByteBuffer (contextDevice dc) (writeToByteString out)
      -- Cache the output spans.
      let as' = as { prevOutputOps = Just ops }
      writeIORef (assumedStateRef $ contextDevice dc) as'
  
  writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
  writeOutputOps urlsEnabled dc initialAttr diffs ops =
      let (_, out, _) = Vector.foldl' writeOutputOps'
                                         (0, mempty, diffs)
                                         ops
      in out
      where
          writeOutputOps' (y, out, True : diffs') spanOps
              = let spanOut = writeSpanOps urlsEnabled dc y initialAttr spanOps
                    out' = out `mappend` spanOut
                in (y+1, out', diffs')
          writeOutputOps' (y, out, False : diffs') _spanOps
              = (y + 1, out, diffs')
          writeOutputOps' (_y, _out, []) _spanOps
              = error "vty - output spans without a corresponding diff."
  
  writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
  writeSpanOps urlsEnabled dc y initialAttr spanOps =
      -- The first operation is to set the cursor to the start of the row
      let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc urlsEnabled
      -- then the span ops are serialized in the order specified
      in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp urlsEnabled dc op fattr of
                                (opOut, fattr') -> (out `mappend` opOut, fattr')
                             )
                             (start, initialAttr)
                             spanOps
  
  writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
  writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr =
      let attr' = limitAttrForDisplay (contextDevice dc) attr
          fattr' = fixDisplayAttr fattr attr'
          diffs = displayAttrDiffs fattr fattr'
          out =  writeSetAttr dc urlsEnabled fattr attr' diffs
                 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
      in (out, fattr')
  writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip"
  writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `mappend` writeRowEnd dc, fattr)
  
  -- | The cursor position is given in X,Y character offsets. Due to
  -- multi-column characters this needs to be translated to column, row
  -- positions.
  data CursorOutputMap = CursorOutputMap
      { charToOutputPos :: (Int, Int) -> (Int, Int)
      }
  
  cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap
  cursorOutputMap spanOps _cursor = CursorOutputMap
      { charToOutputPos = \(cx, cy) -> (cursorColumnOffset spanOps cx cy, cy)
      }
  
  cursorColumnOffset :: DisplayOps -> Int -> Int -> Int
  cursorColumnOffset ops cx cy =
      let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy)
          (outOffset, _, _)
              = Vector.foldl' ( \(d, currentCx, done) op ->
                          if done then (d, currentCx, done) else case spanOpHasWidth op of
                              Nothing -> (d, currentCx, False)
                              Just (cw, ow) -> case compare cx (currentCx + cw) of
                                      GT -> ( d + ow
                                            , currentCx + cw
                                            , False
                                            )
                                      EQ -> ( d + ow
                                            , currentCx + cw
                                            , True
                                            )
                                      LT -> ( d + columnsToCharOffset (cx - currentCx) op
                                            , currentCx + cw
                                            , True
                                            )
                        )
                        (0, 0, False)
                        cursorRowOps
      in outOffset
  
  -- | Not all terminals support all display attributes. This filters a
  -- display attribute to what the given terminal can display.
  limitAttrForDisplay :: Output -> Attr -> Attr
  limitAttrForDisplay t attr
      = attr { attrForeColor = clampColor $ attrForeColor attr
             , attrBackColor = clampColor $ attrBackColor attr
             }
      where
          clampColor Default     = Default
          clampColor KeepCurrent = KeepCurrent
          clampColor (SetTo c)   = clampColor' (outputColorMode t) c
  
          clampColor' NoColor _ = Default
  
          clampColor' ColorMode8 (ISOColor v)
              | v >= 8    = SetTo $ ISOColor (v - 8)
              | otherwise = SetTo $ ISOColor v
          clampColor' ColorMode8 _ = Default
  
          clampColor' ColorMode16 c@(ISOColor _) = SetTo c
          clampColor' ColorMode16 _              = Default
  
          clampColor' (ColorMode240 _) c@(ISOColor _) = SetTo c
          clampColor' (ColorMode240 colorCount) c@(Color240 n)
              | n <= colorCount = SetTo c
              | otherwise       = Default
          clampColor' colorMode@(ColorMode240 _) (RGBColor r g b) =
              clampColor' colorMode (color240 r g b)
  
          clampColor' FullColor c = SetTo c
  