git.iko.soy/vty
on c0faeca help sign in
vty/src/Graphics/Vty/Terminal/Debug.hs
117 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 Unsafe.Coerce
31-- | The debug display terminal produces a string representation of the requested picture. There is
32-- *not* an isomorphism between the string representation and the picture. The string
33-- representation is a simplification of the picture that is only useful in debugging VTY without
34-- considering terminal specific issues.
35--
36-- The debug implementation is useful in manually determining if the sequence of terminal operations
37-- matches the expected sequence. So requirement of the produced representation is simplicity in
38-- parsing the text representation and determining how the picture was mapped to terminal
39-- operations.
40--
41-- All terminals support the operations specified in the Terminal class defined in
42-- Graphics.Vty.Terminal. As an instance of the Terminal class is also an instance of the Monad
43-- class there exists a monoid that defines it's algebra. The string representation is a sequence of
44-- identifiers where each identifier is the name of an operation in the algebra.
46data DebugTerminal = DebugTerminal
47 { debug_terminal_last_output :: IORef (UTF8.UTF8 BS.ByteString)
48 , debug_terminal_bounds :: DisplayRegion
49 }
51instance Terminal DebugTerminal where
52 terminal_ID _t = "debug_terminal"
53 release_terminal _t = return ()
54 reserve_display _t = return ()
55 release_display _t = return ()
56 display_bounds t = return $ debug_terminal_bounds t
57 display_terminal_instance t r c = return $ c (DebugDisplay r)
58 output_byte_buffer t out_buffer buffer_size
59 = liftIO $ do
60 putStrLn $ "output_byte_buffer ?? " ++ show buffer_size
61 peekArray (fromEnum buffer_size) out_buffer
62 >>= return . UTF8.fromRep . BSCore.pack
63 >>= writeIORef (debug_terminal_last_output t)
65data DebugDisplay = DebugDisplay
66 { debug_display_bounds :: DisplayRegion
67 }
69terminal_instance :: ( Applicative m, MonadIO m ) => DisplayRegion -> m TerminalHandle
70terminal_instance r = do
71 output_ref <- liftIO $ newIORef undefined
72 new_terminal_handle $ DebugTerminal output_ref r
74dehandle :: TerminalHandle -> DebugTerminal
75dehandle (TerminalHandle t _) = unsafeCoerce t
77instance DisplayTerminal DebugDisplay where
78 -- | Provide the current bounds of the output terminal.
79 context_region d = debug_display_bounds d
81 -- | A cursor move is always visualized as the single character 'M'
82 move_cursor_required_bytes _d _x _y = 1
84 -- | A cursor move is always visualized as the single character 'M'
85 serialize_move_cursor _d _x _y ptr = do
86 liftIO $ poke ptr (toEnum $ fromEnum 'M')
87 return $ ptr `plusPtr` 1
89 -- | Show cursor is always visualized as the single character 'S'
90 show_cursor_required_bytes _d = 1
92 -- | Show cursor is always visualized as the single character 'S'
93 serialize_show_cursor _d ptr = do
94 liftIO $ poke ptr (toEnum $ fromEnum 'S')
95 return $ ptr `plusPtr` 1
97 -- | Hide cursor is always visualized as the single character 'H'
98 hide_cursor_required_bytes _d = 1
100 -- | Hide cursor is always visualized as the single character 'H'
101 serialize_hide_cursor _d ptr = do
102 liftIO $ poke ptr (toEnum $ fromEnum 'H')
103 return $ ptr `plusPtr` 1
105 -- | An attr change is always visualized as the single character 'A'
106 attr_required_bytes _d _fattr _diffs _attr = 1
108 -- | An attr change is always visualized as the single character 'A'
109 serialize_set_attr _d _fattr _diffs _attr ptr = do
110 liftIO $ poke ptr (toEnum $ fromEnum 'A')
111 return $ ptr `plusPtr` 1
113 default_attr_required_bytes _d = 1
114 serialize_default_attr _d ptr = do
115 liftIO $ poke ptr (toEnum $ fromEnum 'D')
116 return $ ptr `plusPtr` 1