-- 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.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 matche 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 :: DisplayRegion -> m (MockData, Output)
mockTerminal DisplayRegion
r = IO (MockData, Output) -> m (MockData, Output)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MockData, Output) -> m (MockData, Output))
-> IO (MockData, Output) -> m (MockData, Output)
forall a b. (a -> b) -> a -> b
$ do
    MockData
outRef <- UTF8 ByteString -> IO MockData
forall a. a -> IO (IORef a)
newIORef UTF8 ByteString
forall a. HasCallStack => a
undefined
    IORef AssumedState
newAssumedStateRef <- AssumedState -> IO (IORef AssumedState)
forall a. a -> IO (IORef a)
newIORef AssumedState
initialAssumedState
    let t :: Output
t = Output :: String
-> IO ()
-> IO ()
-> IO ()
-> (DisplayRegion -> IO ())
-> IO DisplayRegion
-> (ByteString -> IO ())
-> Int
-> Bool
-> (Mode -> Bool)
-> (Mode -> Bool -> IO ())
-> (Mode -> IO Bool)
-> IORef AssumedState
-> (Output -> DisplayRegion -> IO DisplayContext)
-> IO ()
-> IO Bool
-> IO Bool
-> IO Bool
-> Output
Output
            { terminalID :: String
terminalID = String
"mock terminal"
            , releaseTerminal :: IO ()
releaseTerminal = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            , reserveDisplay :: IO ()
reserveDisplay = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            , releaseDisplay :: IO ()
releaseDisplay = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            , ringTerminalBell :: IO ()
ringTerminalBell = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            , supportsBell :: IO Bool
supportsBell = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            , supportsItalics :: IO Bool
supportsItalics = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            , supportsStrikethrough :: IO Bool
supportsStrikethrough = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            , setDisplayBounds :: DisplayRegion -> IO ()
setDisplayBounds = IO () -> DisplayRegion -> IO ()
forall a b. a -> b -> a
const (IO () -> DisplayRegion -> IO ())
-> IO () -> DisplayRegion -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            , displayBounds :: IO DisplayRegion
displayBounds = DisplayRegion -> IO DisplayRegion
forall (m :: * -> *) a. Monad m => a -> m a
return DisplayRegion
r
            , outputByteBuffer :: ByteString -> IO ()
outputByteBuffer = \ByteString
bytes -> do
                String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"mock outputByteBuffer of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
bytes) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" bytes"
                MockData -> UTF8 ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef MockData
outRef (UTF8 ByteString -> IO ()) -> UTF8 ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> UTF8 ByteString
forall string. string -> UTF8 string
UTF8.fromRep ByteString
bytes
            , contextColorCount :: Int
contextColorCount = Int
16
            , supportsCursorVisibility :: Bool
supportsCursorVisibility = Bool
True
            , supportsMode :: Mode -> Bool
supportsMode = Bool -> Mode -> Bool
forall a b. a -> b -> a
const Bool
False
            , setMode :: Mode -> Bool -> IO ()
setMode = (Bool -> IO ()) -> Mode -> Bool -> IO ()
forall a b. a -> b -> a
const ((Bool -> IO ()) -> Mode -> Bool -> IO ())
-> (Bool -> IO ()) -> Mode -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> Bool -> IO ()
forall a b. a -> b -> a
const (IO () -> Bool -> IO ()) -> IO () -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            , getModeStatus :: Mode -> IO Bool
getModeStatus = IO Bool -> Mode -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> Mode -> IO Bool) -> IO Bool -> Mode -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            , assumedStateRef :: IORef AssumedState
assumedStateRef = IORef AssumedState
newAssumedStateRef
            , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext
mkDisplayContext = \Output
tActual DisplayRegion
rActual -> DisplayContext -> IO DisplayContext
forall (m :: * -> *) a. Monad m => a -> m a
return (DisplayContext -> IO DisplayContext)
-> DisplayContext -> IO DisplayContext
forall a b. (a -> b) -> a -> b
$ DisplayContext :: Output
-> DisplayRegion
-> (Int -> Int -> Write)
-> Write
-> Write
-> (Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write)
-> (Bool -> Write)
-> Write
-> IO ()
-> DisplayContext
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 (Word8 -> Write) -> Word8 -> Write
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a. Enum a => Int -> a
toEnum (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
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 (Word8 -> Write) -> Word8 -> Write
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a. Enum a => Int -> a
toEnum (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
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 (Word8 -> Write) -> Word8 -> Write
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a. Enum a => Int -> a
toEnum (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
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 (Word8 -> Write) -> Word8 -> Write
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a. Enum a => Int -> a
toEnum (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'A'
                -- default attr is always visualized as the single
                -- character 'D'
                , writeDefaultAttr :: Bool -> Write
writeDefaultAttr = Write -> Bool -> Write
forall a b. a -> b -> a
const (Write -> Bool -> Write) -> Write -> Bool -> Write
forall a b. (a -> b) -> a -> b
$ Word8 -> Write
writeWord8 (Word8 -> Write) -> Word8 -> Write
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a. Enum a => Int -> a
toEnum (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
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 (Word8 -> Write) -> Word8 -> Write
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a. Enum a => Int -> a
toEnum (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'E'
                , inlineHack :: IO ()
inlineHack = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                }
            }
    (MockData, Output) -> IO (MockData, Output)
forall (m :: * -> *) a. Monad m => a -> m a
return (MockData
outRef, Output
t)