diff --git a/src/Graphics/Vty/Debug.hs b/src/Graphics/Vty/Debug.hs --- a/src/Graphics/Vty/Debug.hs +++ b/src/Graphics/Vty/Debug.hs @@ -1,37 +1,29 @@ -- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE ScopedTypeVariables #-} module Graphics.Vty.Debug ( module Graphics.Vty.Debug + , module Graphics.Vty.Debug.Image ) where import Graphics.Vty.Attributes -import Graphics.Vty.Image -import Graphics.Vty.Picture +import Graphics.Vty.Debug.Image import Graphics.Vty.Span import Graphics.Vty.DisplayRegion -import Control.Monad -import Data.Array +import qualified Data.Vector as Vector import Data.Word -instance Show SpanOpSequence where - show (SpanOpSequence _ row_ops) - = concat $ ["{ "] ++ map (\ops -> show ops ++ "; " ) (elems row_ops) ++ [" }"] - -instance Show SpanOp where - show (AttributeChange attr) = show attr - show (TextSpan ow cw _) = "TextSpan " ++ show ow ++ " " ++ show cw - -row_ops_effected_columns :: SpanOpSequence -> [Word] +row_ops_effected_columns :: DisplayOps -> [Word] row_ops_effected_columns spans - = map span_ops_effected_columns (elems $ row_ops spans) + = Vector.toList $ Vector.map span_ops_effected_columns $ display_ops spans +all_spans_have_width :: DisplayOps -> Word -> Bool all_spans_have_width spans expected - = all (== expected) ( map span_ops_effected_columns (elems $ row_ops spans) ) + = all (== expected) $ Vector.toList $ Vector.map span_ops_effected_columns $ display_ops spans -span_ops_effected_rows :: SpanOpSequence -> Word -span_ops_effected_rows (SpanOpSequence _ row_ops) - = toEnum $ length (filter (not . null) (elems row_ops)) +span_ops_effected_rows :: DisplayOps -> Word +span_ops_effected_rows (DisplayOps _ the_row_ops) + = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList the_row_ops)) type SpanConstructLog = [SpanConstructEvent] data SpanConstructEvent = SpanSetAttr Attr @@ -49,31 +41,3 @@ type TestWindow = DebugWindow -type ImageConstructLog = [ImageConstructEvent] -data ImageConstructEvent = ImageConstructEvent - deriving ( Show, Eq ) - -forward_image_ops = map forward_transform debug_image_ops - -forward_transform, reverse_transform :: ImageOp -> (Image -> Image) - -forward_transform (ImageOp f _) = f -reverse_transform (ImageOp _ r) = r - -data ImageOp = ImageOp ImageEndo ImageEndo -type ImageEndo = Image -> Image - -debug_image_ops = - [ id_image_op - -- , render_single_column_char_op - -- , render_double_column_char_op - ] - -id_image_op :: ImageOp -id_image_op = ImageOp id id - --- render_char_op :: ImageOp --- render_char_op = ImageOp id id - -instance Show Picture where - show (Picture _ image _ ) = "Picture ?? " ++ show image ++ " ??" diff --git a/src/Graphics/Vty/Image.hs b/src/Graphics/Vty/Image.hs --- a/src/Graphics/Vty/Image.hs +++ b/src/Graphics/Vty/Image.hs @@ -3,7 +3,8 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -module Graphics.Vty.Image ( Image(..) +module Graphics.Vty.Image ( DisplayString + , Image(..) , image_width , image_height , (<|>) @@ -45,7 +46,10 @@ infixr 5 <|> infixr 4 <-> -type StringSeq = Seq.Seq Char +-- | We pair each character with it's display length. This way we only compute the length once per +-- character. +-- * Though currently the width of some strings is still compute multiple times. +type DisplayString = Seq.Seq (Char, Word) -- | An image in VTY defines: -- @@ -69,8 +73,7 @@ HorizText { attr :: !Attr -- All character data is stored as Char sequences with the ISO-10646 encoding. - , text :: StringSeq - -- in columns + , text :: DisplayString , output_width :: !Word -- >= 0 , char_width :: !Word -- >= 1 } @@ -113,7 +116,7 @@ instance Show Image where show ( HorizText { output_width = ow, text = txt } ) - = "HorizText [" ++ show ow ++ "] (" ++ show txt ++ ")" + = "HorizText [" ++ show ow ++ "] (" ++ show (fmap fst txt) ++ ")" show ( BGFill { output_width = c, output_height = r } ) = "BGFill (" ++ show c ++ "," ++ show r ++ ")" show ( HorizJoin { part_left = l, part_right = r, output_width = c } ) @@ -128,14 +131,13 @@ = "ImagePad " ++ show size ++ " ( " ++ show i ++ " )" show ( EmptyImage ) = "EmptyImage" --- | Currently append in the Monoid instance is equivalent to <->. Future versions will just stack --- the images. +-- | Currently append in the Monoid instance is equivalent to <->. instance Monoid Image where mempty = empty_image mappend = (<->) -- A horizontal text image of 0 characters in width simplifies to the EmptyImage -horiz_text :: Attr -> StringSeq -> Word -> Image +horiz_text :: Attr -> DisplayString -> Word -> Image horiz_text a txt ow | ow == 0 = EmptyImage | otherwise = HorizText a txt ow (toEnum $ Seq.length txt) @@ -288,7 +290,9 @@ -- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in -- the ISO-10646 encoding. char :: Attr -> Char -> Image -char !a !c = HorizText a (Seq.singleton c) (safe_wcwidth c) 1 +char !a !c = + let display_width = safe_wcwidth c + in HorizText a (Seq.singleton (c, display_width)) display_width 1 -- | A string of characters layed out on a single row with the same display attribute. The string is -- assumed to be a sequence of ISO-10646 characters. @@ -300,7 +304,9 @@ -- directly to iso_10646_string or string. -- iso_10646_string :: Attr -> String -> Image -iso_10646_string !a !str = horiz_text a (Seq.fromList str) (safe_wcswidth str) +iso_10646_string !a !str = + let display_text = Seq.fromList $ map (\c -> (c, safe_wcwidth c)) str + in horiz_text a display_text (safe_wcswidth str) -- | Alias for iso_10646_string. Since the usual case is that a literal string like "foo" is -- represented internally as a list of ISO 10646 31 bit characters. @@ -316,14 +322,23 @@ utf8_string :: Attr -> [Word8] -> Image utf8_string !a !str = string a ( decode str ) +-- XXX: Characters with unknown widths occupy 1 column? +-- +-- Not sure if this is actually correct. I presume there is a replacement character that is output +-- by the terminal instead of the character and this replacement character is 1 column wide. If this +-- is not true for all terminals then a per-terminal replacement character width needs to be +-- implemented. + +-- | Returns the display width of a character. Assumes all characters with unknown widths are 1 width safe_wcwidth :: Char -> Word safe_wcwidth c = case wcwidth c of - i | i < 0 -> 0 -- error "negative wcwidth" + i | i < 0 -> 1 | otherwise -> toEnum i +-- | Returns the display width of a string. Assumes all characters with unknown widths are 1 width safe_wcswidth :: String -> Word safe_wcswidth str = case wcswidth str of - i | i < 0 -> 0 -- error "negative wcswidth" + i | i < 0 -> 1 | otherwise -> toEnum i -- | Renders a UTF-8 encoded bytestring. diff --git a/src/Graphics/Vty/Picture.hs b/src/Graphics/Vty/Picture.hs --- a/src/Graphics/Vty/Picture.hs +++ b/src/Graphics/Vty/Picture.hs @@ -37,6 +37,9 @@ , pic_background :: Background } +instance Show Picture where + show (Picture _ image _ ) = "Picture ?? " ++ show image ++ " ??" + -- | Create a picture for display for the given image. The picture will not have a displayed cursor -- and the background display attribute will be `current_attr`. pic_for_image :: Image -> Picture diff --git a/src/Graphics/Vty/Span.hs b/src/Graphics/Vty/Span.hs --- a/src/Graphics/Vty/Span.hs +++ b/src/Graphics/Vty/Span.hs @@ -9,8 +9,6 @@ module Graphics.Vty.Span where -import Codec.Binary.UTF8.Width ( wcwidth ) - import Graphics.Vty.Image import Graphics.Vty.Picture import Graphics.Vty.DisplayRegion @@ -20,19 +18,19 @@ import Control.Monad ( forM_ ) import Control.Monad.ST.Strict -import Data.Array.ST +import Data.Vector (Vector) +import qualified Data.Vector as Vector hiding ( take, replicate ) +import Data.Vector.Mutable ( MVector(..)) +import qualified Data.Vector.Mutable as Vector + import qualified Data.ByteString as B import qualified Data.ByteString.Internal as BInt import qualified Data.Foldable as Foldable -import Data.List -import Data.Word -import qualified Data.ByteString.UTF8 as BSUTF8 import qualified Data.String.UTF8 as UTF8 +import Data.Word import Foreign.Storable ( pokeByteOff ) -import GHC.Arr - {- | A picture is translated into a sequences of state changes and character spans. - State changes are currently limited to new attribute values. The attribute is applied to all - following spans. Including spans of the next row. The nth element of the sequence represents the @@ -40,31 +38,45 @@ - - A span op sequence will be defined for all rows and columns (and no more) of the region provided - with the picture to spans_for_pic. - - - - todo: Partition attribute changes into multiple categories according to the serialized - representation of the various attributes. -} -data SpanOpSequence = SpanOpSequence - { effected_region :: DisplayRegion - , row_ops :: RowOps - } -type RowOps = Array Word SpanOps -type SpanOps = [SpanOp] +data DisplayOps = DisplayOps + { effected_region :: DisplayRegion + , display_ops :: RowOps + } -span_ops_columns :: SpanOpSequence -> Word +-- vector of span operation vectors. One per row of the screen. +type RowOps = Vector SpanOps + +type MRowOps s = MVector s SpanOps + +-- vector of span operations. executed in succession +type SpanOps = Vector SpanOp + +type MSpanOps s = MVector s SpanOp + +instance Show DisplayOps where + show (DisplayOps _ the_row_ops) + = "{ " ++ (show $ Vector.map (\ops -> show ops ++ "; " ) the_row_ops) ++ " }" + +instance Show SpanOp where + show (AttributeChange attr) = show attr + show (TextSpan ow cw _) = "TextSpan " ++ show ow ++ " " ++ show cw + +span_ops_columns :: DisplayOps -> Word span_ops_columns ops = region_width $ effected_region ops -span_ops_rows :: SpanOpSequence -> Word +span_ops_rows :: DisplayOps -> Word span_ops_rows ops = region_height $ effected_region ops -span_ops_effected_columns :: [SpanOp] -> Word -span_ops_effected_columns in_ops = span_ops_effected_columns' 0 in_ops +span_ops_effected_columns :: SpanOps -> Word +span_ops_effected_columns in_ops = Vector.foldl' span_ops_effected_columns' 0 in_ops where - span_ops_effected_columns' t [] = t - span_ops_effected_columns' t (TextSpan w _ _ : r) = span_ops_effected_columns' (t + w) r - span_ops_effected_columns' t (_ : r) = span_ops_effected_columns' t r + span_ops_effected_columns' t (TextSpan w _ _ ) = t + w + span_ops_effected_columns' t _ = t -- | -- @@ -79,54 +91,70 @@ | TextSpan !Word !Word (UTF8.UTF8 B.ByteString) deriving Eq +-- used to determine the width of a span operation , if it has one. span_op_has_width :: SpanOp -> Maybe (Word, Word) span_op_has_width (TextSpan ow cw _) = Just (cw, ow) span_op_has_width _ = Nothing +-- returns the number of columns to the character at the given position in the span op columns_to_char_offset :: Word -> SpanOp -> Word columns_to_char_offset cx (TextSpan _ _ utf8_str) = let str = UTF8.toString utf8_str - in toEnum $ sum $ map wcwidth $ take (fromEnum cx) str + in toEnum $! sum $! map wcwidth $! take (fromEnum cx) str columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width" -- | Produces the span ops that will render the given picture, possibly cropped or padded, into the -- specified region. -spans_for_pic :: Picture -> DisplayRegion -> SpanOpSequence -spans_for_pic pic r = SpanOpSequence r $ runSTArray (build_spans pic r) +spans_for_pic :: Picture -> DisplayRegion -> DisplayOps +spans_for_pic pic r = DisplayOps r $ Vector.create (build_spans pic r) -build_spans :: Picture -> DisplayRegion -> ST s (STArray s Word [SpanOp]) +build_spans :: Picture -> DisplayRegion -> ST s (MRowOps s) build_spans pic region = do - -- m for mutable - mrow_ops <- newSTArray (0, region_height region - 1) [] - -- I think this can be better optimized if the build produced span operations in display order. + -- m for mutable! ;-) + mrow_ops <- Vector.replicate (fromEnum $ region_height region) Vector.empty + -- XXX: I think building the span operations in display order would provide better performance. -- However, I got stuck trying to implement an algorithm that did this. This will be considered -- as a possible future optimization. -- - -- A depth first traversal of the image is performed. - -- ordered according to the column range defined by the image from least to greatest. - -- The output row ops will at least have the region of the image specified. Iterate over all - -- output rows and output background fills for all unspecified columns. + -- A depth first traversal of the image is performed. ordered according to the column range + -- defined by the image from least to greatest. The output row ops will at least have the + -- region of the image specified. Iterate over all output rows and output background fills for + -- all unspecified columns. + -- + -- The images are made into span operations from left to right. It's possible that this could + -- easily be made to assure top to bottom output as well. if region_height region > 0 then do -- The ops builder recursively descends the image and outputs span ops that would -- display that image. The number of columns remaining in this row before exceeding the - -- bounds is also provided. This is used to clip the span ops produced. - _ <- ops_for_row mrow_ops (pic_background pic) region (pic_image pic) (0,0) 0 (region_width region) + -- bounds is also provided. This is used to clip the span ops produced to the display. + -- The skip dimensions provided do....??? + _ <- row_ops_for_image mrow_ops + (pic_image pic) + (pic_background pic) + region + (0,0) + 0 + (region_width region) -- Fill in any unspecified columns with the background pattern. - forM_ [0 .. region_height region - 1] $ \row -> do - end_x <- readSTArray mrow_ops row >>= return . span_ops_effected_columns + forM_ [0 .. (fromEnum $ region_height region - 1)] $! \row -> do + end_x <- Vector.read mrow_ops row >>= return . span_ops_effected_columns if end_x < region_width region then snoc_bg_fill mrow_ops (pic_background pic) (region_width region - end_x) row else return () else return () return mrow_ops -type MRowOps s = STArray s Word SpanOps - -ops_for_row :: MRowOps s -> Background -> DisplayRegion -> Image -> (Word, Word) -> Word -> Word -> ST s (Word, Word) -ops_for_row mrow_ops bg region image skip_dim@(skip_row,skip_col) y remaining_columns +row_ops_for_image :: MRowOps s -> Image -> Background -> DisplayRegion -> (Word, Word) -> Int -> Word -> ST s (Word, Word) +row_ops_for_image mrow_ops -- the image to output the ops to + image -- the image to rasterize in column order to mrow_ops + bg -- the background fill + region -- ??? + skip_dim@(skip_row,skip_col) -- the number of rows + y -- ??? + remaining_columns -- ??? | remaining_columns == 0 = return skip_dim - | y >= region_height region = return skip_dim + | y >= fromEnum (region_height region) = return skip_dim | otherwise = case image of EmptyImage -> return skip_dim -- The width provided is the number of columns this text span will occupy when displayed. @@ -138,22 +166,34 @@ else do skip_col' <- snoc_text_span a text_str mrow_ops skip_col y remaining_columns return (skip_row, skip_col') - VertJoin t b _ _ -> do - (skip_row',skip_col') <- ops_for_row mrow_ops bg region t skip_dim y remaining_columns - (skip_row'',skip_col'') <- ops_for_row mrow_ops bg region b (skip_row', skip_col) (y + image_height t - (skip_row - skip_row')) remaining_columns + VertJoin top_image bottom_image _ _ -> do + (skip_row',skip_col') <- row_ops_for_image mrow_ops + top_image + bg + region + skip_dim + y + remaining_columns + (skip_row'',skip_col'') <- row_ops_for_image mrow_ops + bottom_image + bg + region + (skip_row', skip_col) + (y + (fromEnum $! image_height top_image) - (fromEnum $! skip_row - skip_row')) + remaining_columns return (skip_row'', min skip_col' skip_col'') HorizJoin l r _ _ -> do - (skip_row',skip_col') <- ops_for_row mrow_ops bg region l skip_dim y remaining_columns + (skip_row',skip_col') <- row_ops_for_image mrow_ops l bg region skip_dim y remaining_columns -- Don't output the right part unless there is at least a single column left after -- outputting the left part. if image_width l - (skip_col - skip_col') > remaining_columns then return (skip_row,skip_col') else do - (skip_row'',skip_col'') <- ops_for_row mrow_ops bg region r (skip_row, skip_col') y (remaining_columns - image_width l + (skip_col - skip_col')) + (skip_row'',skip_col'') <- row_ops_for_image mrow_ops r bg region (skip_row, skip_col') y (remaining_columns - image_width l + (skip_col - skip_col')) return (min skip_row' skip_row'', skip_col'') BGFill width height -> do - let min_height = if y + height > region_height region - then region_height region - y + let min_height = if y + (fromEnum height) > (fromEnum $! region_height region) + then region_height region - (toEnum y) else height min_width = if width > remaining_columns then remaining_columns @@ -164,7 +204,7 @@ actual_width = if skip_col > min_width then 0 else min_width - skip_col - forM_ [y .. y + actual_height - 1] $ \y' -> snoc_bg_fill mrow_ops bg actual_width y' + forM_ [y .. y + fromEnum actual_height - 1] $! \y' -> snoc_bg_fill mrow_ops bg actual_width y' let skip_row' = if actual_height > skip_row then 0 else skip_row - min_height @@ -176,25 +216,25 @@ if dx < 0 -- Translation left -- Extract the delta and add it to skip_col. - then ops_for_row mrow_ops bg region (translate (0, dy) i) (skip_row, skip_col + dw) y remaining_columns + then row_ops_for_image mrow_ops (translate (0, dy) i) bg region (skip_row, skip_col + dw) y remaining_columns -- Translation right else if dy < 0 -- Translation up -- Extract the delta and add it to skip_row. - then ops_for_row mrow_ops bg region (translate (dx, 0) i) (skip_row + dh, skip_col) y remaining_columns + then row_ops_for_image mrow_ops (translate (dx, 0) i) bg region (skip_row + dh, skip_col) y remaining_columns -- Translation down -- Pad the start of lines and above the image with a -- background_fill image. - else ops_for_row mrow_ops bg region (background_fill ow dh <-> (background_fill dw ih <|> i)) skip_dim y remaining_columns + else row_ops_for_image mrow_ops (background_fill ow dh <-> (background_fill dw ih <|> i)) bg region skip_dim y remaining_columns where dw = toEnum $ abs dx dh = toEnum $ abs dy ow = image_width image ih = image_height i ImageCrop (max_w,max_h) i -> - if y >= max_h + if y >= fromEnum max_h then return skip_dim - else ops_for_row mrow_ops bg region i skip_dim y (min remaining_columns max_w) + else row_ops_for_image mrow_ops i bg region skip_dim y (min remaining_columns max_w) ImagePad (min_w,min_h) i -> do let hpad = if image_width i < min_w then background_fill (min_w - image_width i) (image_height i) @@ -202,48 +242,68 @@ let vpad = if image_height i < min_h then background_fill (image_width i) (min_h - image_height i) else empty_image - ops_for_row mrow_ops bg region ((i <|> hpad) <-> vpad) skip_dim y remaining_columns + row_ops_for_image mrow_ops ((i <|> hpad) <-> vpad) bg region skip_dim y remaining_columns -snoc_text_span :: (Foldable.Foldable t) - => Attr - -> t Char - -> MRowOps s - -> Word - -> Word - -> Word +snoc_text_span :: Attr -- the display attributes of the text span + -> DisplayString -- the text to output + -> MRowOps s -- the display operations to add to + -> Word -- the number of display columns in the text span to + -- skip before outputting + -> Int -- the row of the display operations to add to + -> Word -- the number of columns from the next column to be + -- defined to the end of the display for the row. -> ST s Word -snoc_text_span a text_str mrow_ops skip_col y remaining_columns = do - snoc_op mrow_ops y $ AttributeChange a - let (ow', dw', cw', txt) = Foldable.foldl' - build_cropped_txt - ( 0, 0, 0, B.empty ) - text_str - snoc_op mrow_ops y $ TextSpan ow' cw' (UTF8.fromRep txt) - return $ skip_col - dw' +snoc_text_span a text_str mrow_ops columns_to_skip y remaining_columns = do + {-# SCC "snoc_text_span-pre" #-} snoc_op mrow_ops y $! AttributeChange a + -- At most a text span will consist of remaining_columns characters + -- we keep track of the position of the next character. + let max_len :: Int = fromEnum remaining_columns + mspan_chars <- Vector.new max_len + ( used_display_columns, display_columns_skipped, used_char_count ) + <- {-# SCC "snoc_text_span-foldlM" #-} Foldable.foldlM (build_text_span mspan_chars) ( 0, 0, 0 ) text_str + -- once all characters have been output to mspan_chars we grab the used head + out_text <- Vector.unsafeFreeze $! Vector.take used_char_count mspan_chars + -- convert to UTF8 bytestring. + -- This could be made faster. Hopefully the optimizer does a fair job at fusing the fold + -- contained in fromString with the unfold in toList. No biggy right now then. + {-# SCC "snoc_text_span-post" #-} snoc_op mrow_ops y $! TextSpan used_display_columns (toEnum used_char_count) + $! UTF8.fromString + $! Vector.toList out_text + return $ columns_to_skip - display_columns_skipped where - build_cropped_txt (ow', dw', char_count', b0) c = {-# SCC "build_cropped_txt" #-} - let w = wcwidth c - -- Characters with unknown widths occupy 1 column. - -- - -- todo: Not sure if this is actually correct. - -- I presume there is a replacement character that is output by the terminal instead of - -- the character. If so then this replacement process may need to be implemented - -- manually for consistent behavior across terminals. - w' = toEnum $ if w < 0 then 1 else w - in if dw' == skip_col - then if ow' == remaining_columns - then ( ow', dw', char_count', b0 ) - else if (w' + ow') > remaining_columns - then ( remaining_columns, dw', char_count' + ooverflow, B.append b0 $ B.pack $ encode $ genericReplicate ooverflow '…' ) - else ( ow' + w', dw', char_count' + 1, B.append b0 $ B.pack $ encode [c] ) - else if (w' + dw') > skip_col - then ( doverflow, skip_col, doverflow, B.append b0 $ B.pack $ encode $ genericReplicate doverflow '…' ) - else ( ow', w' + dw', char_count', b0 ) - where - doverflow = skip_col - dw' - ooverflow = remaining_columns - ow' + build_text_span mspan_chars (!used_display_columns, !display_columns_skipped, !used_char_count) + (out_char, char_display_width) = {-# SCC "build_text_span" #-} + -- Only valid if the maximum width of a character is 2 display columns. + -- XXX: Optimize into a skip pass then clipped fill pass + if display_columns_skipped == columns_to_skip + then if used_display_columns == remaining_columns + then return $! ( used_display_columns, display_columns_skipped, used_char_count ) + else if ( used_display_columns + char_display_width ) > remaining_columns + then do + Vector.unsafeWrite mspan_chars used_char_count '…' + return $! ( used_display_columns + , display_columns_skipped + , used_char_count + 1 + ) + else do + Vector.unsafeWrite mspan_chars used_char_count out_char + return $! ( used_display_columns + char_display_width + , display_columns_skipped + , used_char_count + 1 + ) + else if (display_columns_skipped + char_display_width) > columns_to_skip + then do + Vector.unsafeWrite mspan_chars used_char_count '…' + return $! ( used_display_columns + 1 + , columns_to_skip + , used_char_count + 1 + ) + else return $ ( used_display_columns + , display_columns_skipped + char_display_width + , used_char_count + ) -snoc_bg_fill :: MRowOps s -> Background -> Word -> Word -> ST s () +snoc_bg_fill :: MRowOps s -> Background -> Word -> Int -> ST s () snoc_bg_fill _row_ops _bg 0 _row = return () snoc_bg_fill mrow_ops (Background c back_attr) fill_length row @@ -266,10 +326,9 @@ $ zip [0 .. fromEnum (fill_length - 1)] (cycle c_bytes) snoc_op mrow_ops row $ TextSpan fill_length fill_length (UTF8.fromRep utf8_bs) -snoc_op :: MRowOps s -> Word -> SpanOp -> ST s () +snoc_op :: MRowOps s -> Int -> SpanOp -> ST s () snoc_op !mrow_ops !row !op = do - ops <- readSTArray mrow_ops row - let ops' = ops ++ [op] - writeSTArray mrow_ops row ops' - return () + ops <- Vector.read mrow_ops row + let ops' = Vector.snoc ops op + Vector.write mrow_ops row ops' diff --git a/src/Graphics/Vty/Terminal/Generic.hs b/src/Graphics/Vty/Terminal/Generic.hs --- a/src/Graphics/Vty/Terminal/Generic.hs +++ b/src/Graphics/Vty/Terminal/Generic.hs @@ -21,11 +21,10 @@ import Control.Monad ( liftM ) import Control.Monad.Trans -import Data.Array import qualified Data.ByteString.Internal as BSCore -import Data.Foldable import Data.IORef import Data.String.UTF8 hiding ( foldl ) +import qualified Data.Vector as Vector import System.IO @@ -110,7 +109,7 @@ display_terminal_instance t b (\ d -> DisplayHandle d t s) data DisplayState = DisplayState - { previous_output_ref :: IORef (Maybe SpanOpSequence) + { previous_output_ref :: IORef (Maybe DisplayOps) } initial_display_state :: MonadIO m => m DisplayState @@ -220,8 +219,8 @@ -> if effected_region previous_ops /= effected_region ops then return $ replicate ( fromEnum $ region_height $ effected_region ops ) True - else return $ zipWith (/=) ( elems $ row_ops previous_ops ) - ( elems $ row_ops ops ) + else return $ zipWith (/=) ( Vector.toList $ display_ops previous_ops ) + ( Vector.toList $ display_ops ops ) -- determine the number of bytes required to completely serialize the output ops. let total = hide_cursor_required_bytes d @@ -254,9 +253,9 @@ liftIO $ writeIORef (previous_output_ref s) (Just ops) return () -required_bytes :: DisplayTerminal d => d -> FixedAttr -> [Bool] -> SpanOpSequence -> Word +required_bytes :: DisplayTerminal d => d -> FixedAttr -> [Bool] -> DisplayOps -> Word required_bytes d in_fattr diffs ops = - let (_, n, _, _) = foldl' required_bytes' (0, 0, in_fattr, diffs) ( row_ops ops ) + let (_, n, _, _) = Vector.foldl' required_bytes' (0, 0, in_fattr, diffs) ( display_ops ops ) in n where required_bytes' (y, current_sum, fattr, True : diffs') span_ops @@ -272,11 +271,11 @@ -- The first operation is to set the cursor to the start of the row let header_required_bytes = move_cursor_required_bytes d 0 y -- then the span ops are serialized in the order specified - in foldl' ( \(current_sum, fattr) op -> let (c, fattr') = span_op_required_bytes d fattr op - in (c + current_sum, fattr') - ) - (header_required_bytes, in_fattr) - span_ops + in Vector.foldl' ( \(current_sum, fattr) op -> let (c, fattr') = span_op_required_bytes d fattr op + in (c + current_sum, fattr') + ) + (header_required_bytes, in_fattr) + span_ops span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Word, FixedAttr) span_op_required_bytes d fattr (AttributeChange attr) = @@ -292,12 +291,12 @@ -> OutputBuffer -> FixedAttr -> [Bool] - -> SpanOpSequence + -> DisplayOps -> m OutputBuffer serialize_output_ops d start_ptr in_fattr diffs ops = do - (_, end_ptr, _, _) <- foldlM serialize_output_ops' + (_, end_ptr, _, _) <- Vector.foldM' serialize_output_ops' ( 0, start_ptr, in_fattr, diffs ) - ( row_ops ops ) + ( display_ops ops ) return end_ptr where serialize_output_ops' ( y, out_ptr, fattr, True : diffs' ) span_ops @@ -319,9 +318,9 @@ -- The first operation is to set the cursor to the start of the row out_ptr' <- serialize_move_cursor d 0 y out_ptr -- then the span ops are serialized in the order specified - foldlM ( \(out_ptr'', fattr) op -> serialize_span_op d op out_ptr'' fattr ) - (out_ptr', in_fattr) - span_ops + Vector.foldM ( \(out_ptr'', fattr) op -> serialize_span_op d op out_ptr'' fattr ) + (out_ptr', in_fattr) + span_ops serialize_span_op :: ( MonadIO m, DisplayTerminal d ) => d @@ -357,16 +356,16 @@ { char_to_output_pos :: (Word, Word) -> (Word, Word) } -cursor_output_map :: SpanOpSequence -> Cursor -> CursorOutputMap +cursor_output_map :: DisplayOps -> Cursor -> CursorOutputMap cursor_output_map span_ops _cursor = CursorOutputMap { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy) } -cursor_column_offset :: SpanOpSequence -> Word -> Word -> Word +cursor_column_offset :: DisplayOps -> Word -> Word -> Word cursor_column_offset span_ops cx cy = - let cursor_row_ops = row_ops span_ops ! cy + let cursor_row_ops = Vector.unsafeIndex (display_ops span_ops) (fromEnum cy) (out_offset, _, _) - = foldl' ( \(d, current_cx, done) op -> + = Vector.foldl' ( \(d, current_cx, done) op -> if done then (d, current_cx, done) else case span_op_has_width op of Nothing -> (d, current_cx, False) Just (cw, ow) -> case compare cx (current_cx + cw) of diff --git a/test/Bench.hs b/test/Bench.hs --- a/test/Bench.hs +++ b/test/Bench.hs @@ -1,6 +1,6 @@ module Main where -import Graphics.Vty +import Graphics.Vty hiding ( pad ) import Control.Concurrent( threadDelay ) import Control.Monad( liftM2 ) diff --git a/test/Makefile b/test/Makefile --- a/test/Makefile +++ b/test/Makefile @@ -26,7 +26,18 @@ $(shell mkdir -p objects ) # TODO: Tests should also be buildable referencing the currently installed vty -GHC_ARGS=--make -i../src -package parallel -package deepseq-1.1.0.2 -hide-package transformers -hide-package monads-fd -hide-package monads-tf -package QuickCheck-2.4 -ignore-package vty ../cbits/gwinsz.c ../cbits/set_term_timing.c ../cbits/mk_wcwidth.c -O -funbox-strict-fields -Wall -threaded -fno-full-laziness -fspec-constr -odir objects -hidir objects +GHC_ARGS=--make -i../src \ + -package parallel \ + -package deepseq-1.1.0.2 \ + -hide-package transformers \ + -hide-package monads-fd \ + -hide-package monads-tf \ + -package QuickCheck-2.4 \ + -ignore-package vty \ + ../cbits/gwinsz.c ../cbits/set_term_timing.c ../cbits/mk_wcwidth.c \ + -O -funbox-strict-fields -Wall -threaded -fno-full-laziness -fspec-constr -fspec-constr-count=10 \ + -rtsopts \ + -odir objects -hidir objects GHC_PROF_ARGS=-prof -auto-all $(GHC_ARGS) @@ -48,4 +59,8 @@ .PHONY: interactive_terminal_test interactive_terminal_test : ghc $(GHC_ARGS) $@ && ./$@ + +.PHONY: core +core : + ghc-core --no-asm --no-cast -- $(GHC_ARGS) Bench diff --git a/test/Verify.hs b/test/Verify.hs --- a/test/Verify.hs +++ b/test/Verify.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} @@ -11,8 +13,6 @@ , Result(..) , monadicIO , liftIO - , liftIOResult - , liftResult , liftBool ) where @@ -24,9 +24,7 @@ import qualified Codec.Binary.UTF8.String as UTF8 -import Control.Applicative import Control.Monad.State.Strict -import Control.Monad.Trans ( liftIO ) import Data.IORef import Data.Word @@ -34,13 +32,10 @@ import Numeric ( showHex ) import System.IO +import System.Random type Test = StateT TestState IO -instance Applicative Test where - pure = return - ( <*> ) = ap - data TestState = TestState { results_ref :: IORef [QC.Result] } @@ -82,6 +77,17 @@ [ toEnum 0x3040 .. toEnum 0x3098 ] ++ [ toEnum 0x309B .. toEnum 0xA4CF] -instance Arbitrary Word where - arbitrary = choose (0, 1024) >>= return . toEnum + +liftIOResult :: Testable prop => IO prop -> Property +liftIOResult = morallyDubiousIOProperty + +#if __GLASGOW_HASKELL__ <= 701 +instance Random Word where + random g = + let (i :: Int, g') = random g + in (toEnum i, g') + randomR (l,h) g = + let (i :: Int, g') = randomR (fromEnum l,fromEnum h) g + in (toEnum i, g') +#endif diff --git a/test/Verify/Data/Terminfo/Parse.hs b/test/Verify/Data/Terminfo/Parse.hs --- a/test/Verify/Data/Terminfo/Parse.hs +++ b/test/Verify/Data/Terminfo/Parse.hs @@ -111,7 +111,7 @@ verify_bytes_equal out_bytes expected_bytes = if out_bytes == expected_bytes then succeeded - else failed $ result + else failed { reason = "out_bytes [" ++ hex_dump out_bytes ++ "] /= expected_bytes [" diff --git a/test/Verify/Graphics/Vty/DisplayRegion.hs b/test/Verify/Graphics/Vty/DisplayRegion.hs --- a/test/Verify/Graphics/Vty/DisplayRegion.hs +++ b/test/Verify/Graphics/Vty/DisplayRegion.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Verify.Graphics.Vty.DisplayRegion ( module Verify.Graphics.Vty.DisplayRegion , module Graphics.Vty.DisplayRegion + , DebugWindow(..) ) where @@ -21,7 +22,7 @@ instance Arbitrary DebugWindow where arbitrary = do - w <- suchThat arbitrary (/= 0) - h <- suchThat arbitrary (/= 0) + w <- choose (1,1024) + h <- choose (1,1024) return $ DebugWindow w h diff --git a/test/Verify/Graphics/Vty/Image.hs b/test/Verify/Graphics/Vty/Image.hs --- a/test/Verify/Graphics/Vty/Image.hs +++ b/test/Verify/Graphics/Vty/Image.hs @@ -5,12 +5,11 @@ ) where -import Graphics.Vty.Debug +import Verify.Graphics.Vty.Attributes +import Graphics.Vty.Debug.Image import Graphics.Vty.Image -import Graphics.Vty.DisplayRegion import Verify -import Verify.Graphics.Vty.Attributes import Data.Word @@ -51,7 +50,7 @@ -- The text must contain at least one character. Otherwise the image simplifies to the -- IdImage which has a height of 0. If this is to represent a single row then the height -- must be 1 - single_column_row_text <- listOf1 arbitrary + single_column_row_text <- resize 128 (listOf1 arbitrary) attr <- arbitrary return $ SingleRowSingleAttrImage attr @@ -81,7 +80,7 @@ instance Arbitrary SingleAttrSingleSpanStack where arbitrary = do - NonEmpty image_list <- arbitrary + image_list <- resize 128 (listOf1 arbitrary) let image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- image_list ] return $ SingleAttrSingleSpanStack image diff --git a/test/Verify/Graphics/Vty/Span.hs b/test/Verify/Graphics/Vty/Span.hs --- a/test/Verify/Graphics/Vty/Span.hs +++ b/test/Verify/Graphics/Vty/Span.hs @@ -20,10 +20,11 @@ verify_all_spans_have_width i spans w = case all_spans_have_width spans w of True -> succeeded - False -> failed $ result { reason = "Not all spans contained operations defining exactly " - ++ show w - ++ " columns of output -\n" - ++ show i - ++ "\n->\n" - ++ show spans - } + False -> failed { reason = "Not all spans contained operations defining exactly " + ++ show w + ++ " columns of output -\n" + ++ show i + ++ "\n->\n" + ++ show spans + } + diff --git a/test/interactive_terminal_test.hs b/test/interactive_terminal_test.hs --- a/test/interactive_terminal_test.hs +++ b/test/interactive_terminal_test.hs @@ -13,10 +13,10 @@ import Data.List ( lookup ) import Data.Maybe ( isJust, fromJust ) import Data.Monoid +import Data.String.QQ import Data.Word import Foreign.Marshal.Array -import HereDoc import qualified System.Environment as Env @@ -28,14 +28,14 @@ output_file_path = "test_results.list" print_intro = do - putStr $ [$heredoc| + putStr $ [s| This is an interactive verification program for the terminal input and output support of the VTY library. This will ask a series of questions about what you see on screen. The goal is to verify that VTY's output and input support performs as expected with your terminal. This program produces a file named - |] ++ output_file_path ++ [$heredoc| + |] ++ output_file_path ++ [s| in the current directory that contains the results for each test assertion. This can be emailed to coreyoconnor@gmail.com and used by the VTY authors to improve support for your terminal. No personal information is contained in the report. @@ -186,7 +186,7 @@ release_terminal t return () , print_summary = do - putStr $ [$heredoc| + putStr $ [s| Once return is pressed: 0. The screen will be cleared. 1. Four lines of text should be visible. @@ -197,7 +197,7 @@ * The cursor is visible. |] , confirm_results = do - putStr $ [$heredoc| + putStr $ [s| Did the test output match the description? |] default_success_confirm_results @@ -308,14 +308,14 @@ } display_bounds_test_summary has_cursor = do - putStr $ [$heredoc| + putStr $ [s| Once return is pressed: 0. The screen will be cleared. |] if has_cursor then putStr " 1. The cursor will be visible." else putStr " 1. The cursor will NOT be visible." - putStr [$heredoc| + putStr [s| 2. The border of the display will be outlined in Xs. So if - and | represented the edge of the terminal window: |-------------| @@ -323,12 +323,12 @@ |X X||] if has_cursor - then putStr $ [$heredoc| + then putStr $ [s| |XXXXXXXXXXXXC| |] - else putStr $ [$heredoc| + else putStr $ [s| |XXXXXXXXXXXXX| |] - putStr $ [$heredoc| + putStr $ [s| |-------------| ( Where C is the final position of the cursor. There may be an X drawn @@ -341,7 +341,7 @@ |] generic_output_match_confirm = do - putStr $ [$heredoc| + putStr $ [s| Did the test output match the description? |] default_success_confirm_results @@ -423,7 +423,7 @@ , confirm_results = generic_output_match_confirm } -unicode_single_width_summary = putStr [$heredoc| +unicode_single_width_summary = putStr [s| Once return is pressed: 0. The screen will be cleared. 1. The cursor will be hidden. @@ -505,7 +505,7 @@ , confirm_results = generic_output_match_confirm } -unicode_double_width_summary = putStr [$heredoc| +unicode_double_width_summary = putStr [s| Once return is pressed: 0. The screen will be cleared. 1. The cursor will be hidden. @@ -558,7 +558,7 @@ release_terminal t return () , print_summary = do - putStr $ [$heredoc| + putStr $ [s| Once return is pressed: 0. The screen will be cleared. 1. The cursor will be hidden. @@ -579,7 +579,7 @@ 1. The cursor should be visible. |] , confirm_results = do - putStr $ [$heredoc| + putStr $ [s| Did the test output match the description? |] default_success_confirm_results @@ -604,7 +604,7 @@ release_terminal t return () , print_summary = do - putStr $ [$heredoc| + putStr $ [s| Once return is pressed: 0. The screen will be cleared. 1. The cursor will be hidden. @@ -634,7 +634,7 @@ 1. The cursor should be visible. |] , confirm_results = do - putStr $ [$heredoc| + putStr $ [s| Did the test output match the description? |] default_success_confirm_results @@ -661,7 +661,7 @@ release_terminal t return () , print_summary = do - putStr $ [$heredoc| + putStr $ [s| Once return is pressed: 0. The screen will be cleared. 1. The cursor will be hidden. @@ -693,7 +693,7 @@ 1. The cursor should be visible. |] , confirm_results = do - putStr $ [$heredoc| + putStr $ [s| Did the test output match the description? |] default_success_confirm_results @@ -720,7 +720,7 @@ release_terminal t return () , print_summary = do - putStr $ [$heredoc| + putStr $ [s| Once return is pressed: 0. The screen will be cleared. 1. The cursor will be hidden. @@ -760,7 +760,7 @@ 1. The cursor should be visible. |] , confirm_results = do - putStr $ [$heredoc| + putStr $ [s| Did the test output match the description? |] default_success_confirm_results @@ -796,7 +796,7 @@ release_terminal t return () , print_summary = do - putStr $ [$heredoc| + putStr $ [s| Once return is pressed: 0. The screen will be cleared. 1. The cursor will be hidden. @@ -823,7 +823,7 @@ 1. The cursor should be visible. |] , confirm_results = do - putStr $ [$heredoc| + putStr $ [s| Did the test output match the description? |] default_success_confirm_results @@ -847,7 +847,7 @@ release_terminal t return () , print_summary = do - putStr $ [$heredoc| + putStr $ [s| Once return is pressed: 0. The screen will be cleared. 1. The cursor will be hidden. @@ -861,7 +861,7 @@ 1. The cursor should be visible. |] , confirm_results = do - putStr $ [$heredoc| + putStr $ [s| Did the test output match the description? |] default_success_confirm_results @@ -879,7 +879,7 @@ putStrLn "line 3." release_terminal t return () - , print_summary = putStr $ [$heredoc| + , print_summary = putStr $ [s| lines are in order. The second line "line 2" should have a red background and the text underline. The third line "line 3" should be drawn in the same style as the first line. @@ -900,7 +900,7 @@ putStrLn "Not styled." release_terminal t return () - , print_summary = putStr $ [$heredoc| + , print_summary = putStr $ [s| |] , confirm_results = generic_output_match_confirm @@ -918,7 +918,7 @@ putStr "Not styled.\n" release_terminal t return () - , print_summary = putStr $ [$heredoc| + , print_summary = putStr $ [s| |] , confirm_results = generic_output_match_confirm diff --git a/test/verify_debug_terminal.hs b/test/verify_debug_terminal.hs --- a/test/verify_debug_terminal.hs +++ b/test/verify_debug_terminal.hs @@ -50,7 +50,7 @@ ++ concat (replicate (fromEnum h - 1) $ "MA" ++ replicate (fromEnum w) 'B') expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected if out_bytes /= expected_bytes - then return $ failed $ result { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } + then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } else return succeeded many_T_rows :: DebugWindow -> Property @@ -67,7 +67,7 @@ let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T') expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected if out_bytes /= expected_bytes - then return $ failed $ result { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } + then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } else return succeeded many_T_rows_cropped_width :: DebugWindow -> Property @@ -84,7 +84,7 @@ let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T') expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected if out_bytes /= expected_bytes - then return $ failed $ result { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } + then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } else return succeeded many_T_rows_cropped_height :: DebugWindow -> Property @@ -101,7 +101,7 @@ let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T') expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected if out_bytes /= expected_bytes - then return $ failed $ result { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } + then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } else return succeeded main = run_test $ do diff --git a/test/verify_eval_terminfo_caps.hs b/test/verify_eval_terminfo_caps.hs --- a/test/verify_eval_terminfo_caps.hs +++ b/test/verify_eval_terminfo_caps.hs @@ -104,8 +104,7 @@ parse_result <- parse_cap_expression cap_def let test_name = "\teval cap " ++ cap_name ++ " -> " ++ show cap_def _ <- case parse_result of - Left error -> verify test_name ( liftResult $ failed - $ result { reason = "prase error " ++ show error } ) + Left error -> verify test_name ( failed { reason = "prase error " ++ show error } ) Right !cap_expr -> verify test_name ( verify_eval_cap eval_buffer cap_expr ) return () Nothing -> do @@ -124,11 +123,11 @@ end_ptr <- serialize_cap_expression expr input_values start_ptr case end_ptr `minusPtr` start_ptr of count | count < 0 -> - return $ failed $ result { reason = "End pointer before start pointer." } + return $ failed { reason = "End pointer before start pointer." } | toEnum count > byte_count -> - return $ failed $ result { reason = "End pointer past end of buffer by " - ++ show (toEnum count - byte_count) - } + return $ failed { reason = "End pointer past end of buffer by " + ++ show (toEnum count - byte_count) + } | otherwise -> return succeeded diff --git a/test/verify_image_ops.hs b/test/verify_image_ops.hs --- a/test/verify_image_ops.hs +++ b/test/verify_image_ops.hs @@ -106,19 +106,19 @@ _ -> True main = run_test $ do - verify "two_sw_horiz_concat" two_sw_horiz_concat - verify "many_sw_horiz_concat" many_sw_horiz_concat - verify "two_sw_vert_concat" two_sw_vert_concat - verify "horiz_concat_sw_assoc" horiz_concat_sw_assoc - verify "many_dw_horiz_concat" many_dw_horiz_concat - verify "two_dw_horiz_concat" two_dw_horiz_concat - verify "two_dw_vert_concat" two_dw_vert_concat - verify "horiz_concat_dw_assoc" horiz_concat_dw_assoc + _ <- verify "two_sw_horiz_concat" two_sw_horiz_concat + _ <- verify "many_sw_horiz_concat" many_sw_horiz_concat + _ <- verify "two_sw_vert_concat" two_sw_vert_concat + _ <- verify "horiz_concat_sw_assoc" horiz_concat_sw_assoc + _ <- verify "many_dw_horiz_concat" many_dw_horiz_concat + _ <- verify "two_dw_horiz_concat" two_dw_horiz_concat + _ <- verify "two_dw_vert_concat" two_dw_vert_concat + _ <- verify "horiz_concat_dw_assoc" horiz_concat_dw_assoc liftIO $ putStrLn $ replicate 80 '-' - verify "single row vert concats to correct height" vert_contat_single_row - verify "disjoint_height_horiz_join" disjoint_height_horiz_join - verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill - verify "disjoint_width_vert_join" disjoint_width_vert_join - verify "disjoint_width_vert_join BG fill" disjoint_width_vert_join_bg_fill + _ <- verify "single row vert concats to correct height" vert_contat_single_row + _ <- verify "disjoint_height_horiz_join" disjoint_height_horiz_join + _ <- verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill + _ <- verify "disjoint_width_vert_join" disjoint_width_vert_join + _ <- verify "disjoint_width_vert_join BG fill" disjoint_width_vert_join_bg_fill return () diff --git a/test/verify_image_trans.hs b/test/verify_image_trans.hs --- a/test/verify_image_trans.hs +++ b/test/verify_image_trans.hs @@ -2,7 +2,6 @@ module Main where import Verify.Graphics.Vty.Image -import Graphics.Vty.Debug import Verify @@ -18,14 +17,15 @@ is_horiz_text_of_columns image char_count verify_horiz_contat_w_attr_change_simplifies :: SingleRowTwoAttrImage -> Bool -verify_horiz_contat_w_attr_change_simplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 char_count0 image0) - (SingleRowSingleAttrImage attr1 char_count1 image1) +verify_horiz_contat_w_attr_change_simplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 char_count0 _image0) + (SingleRowSingleAttrImage attr1 char_count1 _image1) i ) | char_count0 == 0 || char_count1 == 0 || attr0 == attr1 = is_horiz_text_of_columns i (char_count0 + char_count1) | otherwise = False == is_horiz_text_of_columns i (char_count0 + char_count1) +main :: IO () main = run_test $ do - verify "verify_horiz_contat_wo_attr_change_simplifies" verify_horiz_contat_wo_attr_change_simplifies - verify "verify_horiz_contat_w_attr_change_simplifies" verify_horiz_contat_w_attr_change_simplifies + _ <- verify "verify_horiz_contat_wo_attr_change_simplifies" verify_horiz_contat_wo_attr_change_simplifies + _ <- verify "verify_horiz_contat_w_attr_change_simplifies" verify_horiz_contat_w_attr_change_simplifies return () diff --git a/test/verify_parse_terminfo_caps.hs b/test/verify_parse_terminfo_caps.hs --- a/test/verify_parse_terminfo_caps.hs +++ b/test/verify_parse_terminfo_caps.hs @@ -111,7 +111,7 @@ verify_parse_cap cap_string on_parse = liftIOResult $ do parse_result <- parse_cap_expression cap_string case parse_result of - Left error -> return $ failed $ result { reason = "parse error " ++ show error } + Left error -> return $ failed { reason = "parse error " ++ show error } Right e -> on_parse e non_paramaterized_caps (NonParamCapString cap) = do @@ -140,7 +140,7 @@ out_param_count = param_count e in return $ if out_param_count == expected_param_count then verify_bytes_equal out_bytes expected_bytes - else failed $ result { reason = "out param count /= expected param count" } + else failed { reason = "out param count /= expected param count" } dec_print_param_caps (DecPrintCap cap_string expected_param_count expected_bytes) = do verify_parse_cap cap_string $ \e -> @@ -149,7 +149,7 @@ out_param_count = param_count e in return $ if out_param_count == expected_param_count then verify_bytes_equal out_bytes expected_bytes - else failed $ result { reason = "out param count /= expected param count" } + else failed { reason = "out param count /= expected param count" } print_cap ti cap_name = do putStrLn $ cap_name ++ ": " ++ show (from_capname ti cap_name) diff --git a/test/verify_span_ops.hs b/test/verify_span_ops.hs --- a/test/verify_span_ops.hs +++ b/test/verify_span_ops.hs @@ -11,7 +11,7 @@ import Verify -import Data.Array +import qualified Data.Vector as Vector unit_image_and_zero_window_0 :: UnitImage -> EmptyWindow -> Bool unit_image_and_zero_window_0 (UnitImage _ i) (EmptyWindow w) = @@ -139,7 +139,7 @@ first_span_op_sets_attr :: DefaultPic -> Bool first_span_op_sets_attr DefaultPic { default_pic = pic, default_win = win } = let spans = spans_for_pic pic (region_for_window win) - in all ( is_attr_span_op . head ) ( elems $ row_ops spans ) + in all ( is_attr_span_op . Vector.head ) ( Vector.toList $ display_ops spans ) single_attr_single_span_stack_op_coverage :: SingleAttrSingleSpanStack -> Result single_attr_single_span_stack_op_coverage stack = @@ -150,30 +150,31 @@ main :: IO () main = run_test $ do - verify "unit image is cropped when window size == (0,0) [0]" unit_image_and_zero_window_0 - verify "unit image is cropped when window size == (0,0) [1]" unit_image_and_zero_window_1 - verify "horiz span image is cropped when window size == (0,0) [0]" horiz_span_image_and_zero_window_0 - verify "horiz span image is cropped when window size == (0,0) [1]" horiz_span_image_and_zero_window_1 - verify "horiz span image is not cropped when window size == size of image [width]" horiz_span_image_and_equal_window_0 - verify "horiz span image is not cropped when window size == size of image [height]" horiz_span_image_and_equal_window_1 - verify "horiz span image is not cropped when window size < size of image [width]" horiz_span_image_and_lesser_window_0 - verify "horiz span image is not cropped when window size > size of image [width]" horiz_span_image_and_greater_window_0 - verify "arbitrary image is padded or cropped" arb_image_is_cropped - verify "The span ops actually define content for all the rows in the output region" span_ops_actually_fill_rows - verify "The span ops actually define content for all the columns in the output region" span_ops_actually_fill_columns - verify "first span op is always to set the text attribute" first_span_op_sets_attr - verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]" + _ <- verify "unit image is cropped when window size == (0,0) [0]" unit_image_and_zero_window_0 + _ <- verify "unit image is cropped when window size == (0,0) [1]" unit_image_and_zero_window_1 + _ <- verify "horiz span image is cropped when window size == (0,0) [0]" horiz_span_image_and_zero_window_0 + _ <- verify "horiz span image is cropped when window size == (0,0) [1]" horiz_span_image_and_zero_window_1 + _ <- verify "horiz span image is not cropped when window size == size of image [width]" horiz_span_image_and_equal_window_0 + _ <- verify "horiz span image is not cropped when window size == size of image [height]" horiz_span_image_and_equal_window_1 + _ <- verify "horiz span image is not cropped when window size < size of image [width]" horiz_span_image_and_lesser_window_0 + _ <- verify "horiz span image is not cropped when window size > size of image [width]" horiz_span_image_and_greater_window_0 + _ <- verify "arbitrary image is padded or cropped" arb_image_is_cropped + _ <- verify "The span ops actually define content for all the rows in the output region" span_ops_actually_fill_rows + _ <- verify "The span ops actually define content for all the columns in the output region" span_ops_actually_fill_columns + _ <- verify "first span op is always to set the text attribute" first_span_op_sets_attr + _ <- verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]" single_attr_single_span_stack_op_coverage - verify "a single attr text span is cropped when window size < size of stack image [width]" + _ <- verify "a single attr text span is cropped when window size < size of stack image [width]" single_attr_single_span_stack_cropped_0 - verify "a single attr text span is cropped when window size < size of stack image [height]" + _ <- verify "a single attr text span is cropped when window size < size of stack image [height]" single_attr_single_span_stack_cropped_1 - verify "single attr text span <|> single attr text span cropped. [width]" + _ <- verify "single attr text span <|> single attr text span cropped. [width]" single_attr_single_span_stack_cropped_2 - verify "single attr text span <|> single attr text span cropped. [height]" + _ <- verify "single attr text span <|> single attr text span cropped. [height]" single_attr_single_span_stack_cropped_3 - verify "single attr text span <-> single attr text span cropped. [width]" + _ <- verify "single attr text span <-> single attr text span cropped. [width]" single_attr_single_span_stack_cropped_4 - verify "single attr text span <-> single attr text span cropped. [height]" + _ <- verify "single attr text span <-> single attr text span cropped. [height]" single_attr_single_span_stack_cropped_5 return () + diff --git a/vty.cabal b/vty.cabal --- a/vty.cabal +++ b/vty.cabal @@ -1,5 +1,5 @@ Name: vty -Version: 4.7.0.0 +Version: 4.7.0.4 License: BSD3 License-file: LICENSE Author: Stefan O'Rear, Corey O'Connor @@ -28,12 +28,12 @@ . © 2008-2011 Corey O'Connor; BSD3 license. -Build-Depends: base >= 4 && < 5, bytestring, containers, unix +Build-Depends: base >= 4 && < 5, ghc-prim, bytestring, containers, unix Build-Depends: terminfo >= 0.3 && < 0.4 Build-Depends: utf8-string >= 0.3 && < 0.4 Build-Depends: mtl >= 1.1.1.0 && < 2.1 -Build-Depends: ghc-prim, parallel >= 2.2 && < 3.2, deepseq >= 1.1 && < 1.2 -Build-Depends: array +Build-Depends: parallel >= 2.2 && < 3.2, deepseq >= 1.1 && < 1.2 +Build-Depends: vector >= 0.7 Build-Depends: parsec >= 2 && < 4 Build-Type: Simple Data-Files: README, TODO @@ -105,4 +105,4 @@ ghc-options: -O2 -funbox-strict-fields -Wall -fno-full-laziness -fspec-constr -fspec-constr-count=10 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fno-full-laziness -fspec-constr -fspec-constr-count=10 - +cc-options: -O2