-- Copyright Corey O'Connor
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
-- | This provides a mock terminal implementation that is nice for
-- testing. This transforms the output operations to visible characters
-- which is useful for testing.
module Graphics.Vty.Output.Mock
  ( MockData
  , mockTerminal
  )
where

import Graphics.Vty.Image (DisplayRegion)
import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16))
import Graphics.Vty.Output.Interface

import Blaze.ByteString.Builder.Word (writeWord8)

import Control.Monad.Trans

import qualified Data.ByteString as BS
import Data.IORef
import qualified Data.String.UTF8 as UTF8

type MockData = IORef (UTF8.UTF8 BS.ByteString)

-- | The mock display terminal produces a string representation of
-- the requested picture. There is *not* an isomorphism between the
-- string representation and the picture. The string representation is
-- a simplification of the picture that is only useful in debugging VTY
-- without considering terminal specific issues.
--
-- The mock implementation is useful in manually determining if the
-- sequence of terminal operations matches the expected sequence. The
-- requirement of the produced representation is simplicity in parsing
-- the text representation and determining how the picture was mapped to
-- terminal operations.
--
-- The string representation is a sequence of identifiers where each
-- identifier is the name of an operation in the algebra.
mockTerminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Output)
mockTerminal :: forall (m :: * -> *).
(Applicative m, MonadIO m) =>
DisplayRegion -> m (MockData, Output)
mockTerminal DisplayRegion
r = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    MockData
outRef <- forall a. a -> IO (IORef a)
newIORef forall a. HasCallStack => a
undefined
    IORef AssumedState
newAssumedStateRef <- forall a. a -> IO (IORef a)
newIORef AssumedState
initialAssumedState
    let t :: Output
t = Output
            { terminalID :: String
terminalID = String
"mock terminal"
            , releaseTerminal :: IO ()
releaseTerminal = forall (m :: * -> *) a. Monad m => a -> m a
return ()
            , reserveDisplay :: IO ()
reserveDisplay = forall (m :: * -> *) a. Monad m => a -> m a
return ()
            , releaseDisplay :: IO ()
releaseDisplay = forall (m :: * -> *) a. Monad m => a -> m a
return ()
            , ringTerminalBell :: IO ()
ringTerminalBell = forall (m :: * -> *) a. Monad m => a -> m a
return ()
            , supportsBell :: IO Bool
supportsBell = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            , supportsItalics :: IO Bool
supportsItalics = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            , supportsStrikethrough :: IO Bool
supportsStrikethrough = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            , setDisplayBounds :: DisplayRegion -> IO ()
setDisplayBounds = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
            , displayBounds :: IO DisplayRegion
displayBounds = forall (m :: * -> *) a. Monad m => a -> m a
return DisplayRegion
r
            , outputByteBuffer :: ByteString -> IO ()
outputByteBuffer = \ByteString
bytes -> do
                String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"mock outputByteBuffer of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
bytes) forall a. [a] -> [a] -> [a]
++ String
" bytes"
                forall a. IORef a -> a -> IO ()
writeIORef MockData
outRef forall a b. (a -> b) -> a -> b
$ forall string. string -> UTF8 string
UTF8.fromRep ByteString
bytes
            , supportsCursorVisibility :: Bool
supportsCursorVisibility = Bool
True
            , supportsMode :: Mode -> Bool
supportsMode = forall a b. a -> b -> a
const Bool
False
            , setMode :: Mode -> Bool -> IO ()
setMode = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
            , getModeStatus :: Mode -> IO Bool
getModeStatus = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            , assumedStateRef :: IORef AssumedState
assumedStateRef = IORef AssumedState
newAssumedStateRef
            , outputColorMode :: ColorMode
outputColorMode = ColorMode
ColorMode16
            , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext
mkDisplayContext = \Output
tActual DisplayRegion
rActual -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DisplayContext
                { contextRegion :: DisplayRegion
contextRegion = DisplayRegion
rActual
                , contextDevice :: Output
contextDevice = Output
tActual
                -- A cursor move is always visualized as the single
                -- character 'M'
                , writeMoveCursor :: Int -> Int -> Write
writeMoveCursor = \Int
_x Int
_y -> Word8 -> Write
writeWord8 forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum Char
'M'
                -- Show cursor is always visualized as the single
                -- character 'S'
                , writeShowCursor :: Write
writeShowCursor =  Word8 -> Write
writeWord8 forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum Char
'S'
                -- Hide cursor is always visualized as the single
                -- character 'H'
                , writeHideCursor :: Write
writeHideCursor = Word8 -> Write
writeWord8 forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum Char
'H'
                -- An attr change is always visualized as the single
                -- character 'A'
                , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
writeSetAttr = \Bool
_ FixedAttr
_fattr Attr
_diffs DisplayAttrDiff
_attr -> Word8 -> Write
writeWord8 forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum Char
'A'
                -- default attr is always visualized as the single
                -- character 'D'
                , writeDefaultAttr :: Bool -> Write
writeDefaultAttr = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Word8 -> Write
writeWord8 forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum Char
'D'
                -- row end is always visualized as the single character
                -- 'E'
                , writeRowEnd :: Write
writeRowEnd = Word8 -> Write
writeWord8 forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum Char
'E'
                , inlineHack :: IO ()
inlineHack = forall (m :: * -> *) a. Monad m => a -> m a
return ()
                }
            }
    forall (m :: * -> *) a. Monad m => a -> m a
return (MockData
outRef, Output
t)