git.iko.soy/vty
on 2dfe2c2 help sign in
vty/src/Graphics/Vty/Terminal/Debug.hs
121 lines 4.6 kB history raw
1-- Copyright 2009-2010 Corey O'Connor
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE TypeFamilies #-}
4module Graphics.Vty.Terminal.Debug ( DebugTerminal(..)
5 , DebugDisplay(..)
6 , terminal_instance
7 , dehandle
8 )
9 where
11import Graphics.Vty.DisplayRegion
12import Graphics.Vty.Terminal.Generic
14import Control.Applicative
15import Control.Monad.Trans
16import Control.Monad.State.Strict
18import qualified Data.ByteString.UTF8 as BS
19import qualified Data.ByteString as BSCore
20import Data.IORef
21import qualified Data.Sequence as Seq
22import qualified Data.String.UTF8 as UTF8
23import Data.Word
25import Foreign.Marshal.Array ( peekArray )
26import Foreign.Ptr ( plusPtr )
27import Foreign.Storable ( poke )
29import System.IO
31import Unsafe.Coerce
33-- | The debug display terminal produces a string representation of the requested picture. There is
34-- *not* an isomorphism between the string representation and the picture. The string
35-- representation is a simplification of the picture that is only useful in debugging VTY without
36-- considering terminal specific issues.
37--
38-- The debug implementation is useful in manually determining if the sequence of terminal operations
39-- matches the expected sequence. So requirement of the produced representation is simplicity in
40-- parsing the text representation and determining how the picture was mapped to terminal
41-- operations.
42--
43-- All terminals support the operations specified in the Terminal class defined in
44-- Graphics.Vty.Terminal. As an instance of the Terminal class is also an instance of the Monad
45-- class there exists a monoid that defines it's algebra. The string representation is a sequence of
46-- identifiers where each identifier is the name of an operation in the algebra.
48data DebugTerminal = DebugTerminal
49 { debug_terminal_last_output :: IORef (UTF8.UTF8 BS.ByteString)
50 , debug_terminal_bounds :: DisplayRegion
51 }
53instance Terminal DebugTerminal where
54 terminal_ID _t = "debug_terminal"
55 release_terminal _t = return ()
56 reserve_display _t = return ()
57 release_display _t = return ()
58 display_bounds t = return $ debug_terminal_bounds t
59 display_terminal_instance t r c = return $ c (DebugDisplay r)
60 output_byte_buffer t out_buffer buffer_size
61 = liftIO $ do
62 putStrLn $ "output_byte_buffer ?? " ++ show buffer_size
63 peekArray (fromEnum buffer_size) out_buffer
64 >>= return . UTF8.fromRep . BSCore.pack
65 >>= writeIORef (debug_terminal_last_output t)
67 output_handle t = return stdout
69data DebugDisplay = DebugDisplay
70 { debug_display_bounds :: DisplayRegion
71 }
73terminal_instance :: ( Applicative m, MonadIO m ) => DisplayRegion -> m TerminalHandle
74terminal_instance r = do
75 output_ref <- liftIO $ newIORef undefined
76 new_terminal_handle $ DebugTerminal output_ref r
78dehandle :: TerminalHandle -> DebugTerminal
79dehandle (TerminalHandle t _) = unsafeCoerce t
81instance DisplayTerminal DebugDisplay where
82 -- | Provide the current bounds of the output terminal.
83 context_region d = debug_display_bounds d
85 -- | A cursor move is always visualized as the single character 'M'
86 move_cursor_required_bytes _d _x _y = 1
88 -- | A cursor move is always visualized as the single character 'M'
89 serialize_move_cursor _d _x _y ptr = do
90 liftIO $ poke ptr (toEnum $ fromEnum 'M')
91 return $ ptr `plusPtr` 1
93 -- | Show cursor is always visualized as the single character 'S'
94 show_cursor_required_bytes _d = 1
96 -- | Show cursor is always visualized as the single character 'S'
97 serialize_show_cursor _d ptr = do
98 liftIO $ poke ptr (toEnum $ fromEnum 'S')
99 return $ ptr `plusPtr` 1
101 -- | Hide cursor is always visualized as the single character 'H'
102 hide_cursor_required_bytes _d = 1
104 -- | Hide cursor is always visualized as the single character 'H'
105 serialize_hide_cursor _d ptr = do
106 liftIO $ poke ptr (toEnum $ fromEnum 'H')
107 return $ ptr `plusPtr` 1
109 -- | An attr change is always visualized as the single character 'A'
110 attr_required_bytes _d _fattr _diffs _attr = 1
112 -- | An attr change is always visualized as the single character 'A'
113 serialize_set_attr _d _fattr _diffs _attr ptr = do
114 liftIO $ poke ptr (toEnum $ fromEnum 'A')
115 return $ ptr `plusPtr` 1
117 default_attr_required_bytes _d = 1
118 serialize_default_attr _d ptr = do
119 liftIO $ poke ptr (toEnum $ fromEnum 'D')
120 return $ ptr `plusPtr` 1