{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} module Main where import Test.HUnit import Test.QuickCheck import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 import qualified Data.Text as T import Data.Default import Data.Monoid import Control.Monad import Brick.AttrMap (AttrName, attrMap) import TextUI.ItemField import TextUI.ItemField.Layout import Graphics.Vty.Image import Graphics.Vty.Attributes (defAttr) import TestDataGen main = defaultMain tests instance Arbitrary LinePosRange where arbitrary = liftM2 LinePosRange (choose (0,500)) (choose (0,500)) shrink (LinePosRange a b) = [LinePosRange a' b' | a' <- shrink a, b' <- shrink b] maxItemGroupLine = maximum . (:) 0 . map groupsize . items where groupsize (ItemGroup g r) = T.length g + 1 + groupsize r groupsize _ = 0 maxLongGroupLine width = foldl maxLongLine 0 . map fullsize . items where fullsize (ItemGroup g r) = let gsize = T.length g + 1 subsize = fullsize r in (fst subsize + gsize, snd subsize + gsize) fullsize (Items n) = (0, n) -- + 1) maxLongLine o (g,n) = if g >= width then max o n else o maxItemLine = maximum . ((:) 0) . map linesize . items where linesize (ItemGroup g r) = T.length g + 1 + linesize r linesize (Items n) = n defattrs = attrMap defAttr [] tests = [ testGroup "RenderData" [ testCase "Empty Lines" $ [] @=? renderedLines (RenderData 1 []) , testProperty "recover lines" recover_lines , testProperty "rendered width calculation" $ \f lpr1 lpr2 -> let (rdata,img) = itemFieldRender (ItemFieldWidget "hi" f) defattrs w h w = lineWidth lpr1 h = lineWidth lpr2 expected_width = if maxItemGroupLine f >= w then maxLongGroupLine w f else w in expected_width == renderWidth rdata -- , testProperty "render zero items" $ -- \w h -> w == (renderWidth $ fst $ -- itemFieldRender (ItemFieldWidget "hi" $ -- newItemField [Items 0] Nothing) def w h) , testCase "rendered width no items show centered empty message" $ let (rdata,img) = itemFieldRender (ItemFieldWidget "hi" f) defattrs w 100 f = newItemField [] Nothing w = 100 in assertEqual "" w (imageWidth img) , testCase "rendered width zero items" $ let (rdata,img) = itemFieldRender (ItemFieldWidget "hi" f) defattrs 100 100 f = newItemField [Items 0] $ Just $ \a b -> "hi" in assertEqual "" 100 (imageWidth img) -- shows none message , testCase "rendered width too many items" $ let (rdata,img) = itemFieldRender (ItemFieldWidget "hi" f) defattrs w 3 f = newItemField [Items 100] $ Just $ \a b -> "hi" w = 5 in assertEqual "" w (imageWidth img) , testProperty "rendered width" $ prop_render_width , testCase "single group, one item per line, width" $ let (rdata,img) = itemFieldRender (ItemFieldWidget "hi" f) defattrs w h w = 11 h = 500 expected_width = 11 f = newItemField [ItemGroup "grp1" (ItemGroup "grp0" (Items 4))] Nothing in assertEqual "" expected_width (imageWidth img) ] , testGroup "LineIndices" [ testProperty "Initial 0" line_index_zero_start , testProperty "Final count" line_index_final_length , testCase "No elements" $ (null $ lineIndices []) @? "empty output for empty input" , testCase "Zero size first element" $ Just 4 @=? (lineLastIndex $ last $ lineIndices [ LinePosRange 3 0 , LinePosRange 10 5 ]) , testCase "Zero size middle element" $ Just 7 @=? (lineLastIndex $ last $ lineIndices [ LinePosRange 10 5 , LinePosRange 3 0 , LinePosRange 5 3 ]) , testCase "Zero size last element" $ Nothing @=? (lineLastIndex $ last $ lineIndices [ LinePosRange 10 5 , LinePosRange 3 0 ]) ] , testGroup "Line Computations" line_computations , testGroup "CursorPositioning" [ testProperty "valid coordinates" prop_coordinates ] ] prop_render_width f w = let (rdata,img) = itemFieldRender (ItemFieldWidget "hi" f) defattrs w h h = 500 expected_width = if maxItemGroupLine f >= w then maxLongGroupLine w f else min (maxItemLine f) w in w > 0 && w < 500 && cntItems (items f) > 0 ==> expected_width == imageWidth img prop_coordinates f w = let pc = pos_coordinates f rdata (Just (x,y)) = pc numItems = cntItems $ items f rdata = computeLinePosRanges w f in if numItems == 0 then Nothing == pc else x >= 0 && y >= 0 recover_lines lines = lines == (renderedLines $ RenderData 1 lines) line_index_zero_start lines = let li = lineIndices lines line1 = head li in if null lines then null li else if line1 == EmptyLine then Nothing == lineFirstIndex line1 else Just 0 == lineFirstIndex line1 line_index_final_length lines = let li = lineIndices lines num = foldl (\a l -> a + lineWidth l) 0 lines lineLast = last li last_index = lineLastIndex lineLast in if null lines then [] == li else if num == 0 then Nothing == last_index else if lineLast == EmptyLine then last_index == Nothing else last_index == Just (num - 1) line_computations = [ line_comp1 , line_comp2 , line_comp3 , line_comp4 , line_comp5 , line_comp6 , line_comp7 , line_comp8 , line_comp9 , line_comp10 , line_comp11 , line_comp12 ] line_comp1 = testCase "empty itemfield renderdata" $ RenderData 600 [] @=? computeLinePosRanges 600 (ItemFld 0 [] [] Nothing) line_comp2 = testProperty "renderdata width matches value passed or full width" $ \width itemfield -> let RenderData w _ = computeLinePosRanges width itemfield in w >= width line_comp3 = testProperty "single Item per line RenderData" $ \i -> let ttl = abs i items = [Items ttl] width = 10000 -- each items should be on a single line field = newItemField items Nothing RenderData w lprs = computeLinePosRanges width field in and [ w == width , length lprs == 1 , head lprs == LinePosRange 0 ttl ] lineHdrLen (Items _) = 0 lineHdrLen (ItemGroup g i) = T.length g + 1 + lineHdrLen i line_comp4 = testProperty "single Item set per line RenderData" $ \items -> let ttl = cntItems items width = 10000 -- each items should be on a single line field = newItemField items Nothing RenderData w lprs = computeLinePosRanges width field in and [ length lprs == length items , map lineStart lprs == map lineHdrLen items ] sample_field1 = newItemField [ Items 13 , ItemGroup "g1" $ Items 15 , Items 0 , ItemGroup "g2" $ ItemGroup "grp3" $ ItemGroup "g4" $ Items 6 , ItemGroup "g2" $ ItemGroup "g3" $ Items 4 , Items 90 , ItemGroup "empty" $ Items 0 , Items 5 ] Nothing line_comp5 = testCase "Expected lineranges for width greater than all group titles" $ ((renderedLines $ computeLinePosRanges 15 sample_field1) @?= sample_field1_linepos_width15) sample_field1_linepos_width15 = [ LinePosRange 0 13 , LinePosRange 3 (15 - 3), LinePosRange 3 3 , LinePosRange 0 0 , LinePosRange (3 + 5 + 3) (15 - 11), LinePosRange (3 + 5 + 3) 2 , LinePosRange (3 + 3) 4 , LinePosRange 0 15, LinePosRange 0 15, LinePosRange 0 15, LinePosRange 0 15 , {- + -} LinePosRange 0 15, LinePosRange 0 15 , LinePosRange 6 0 , LinePosRange 0 5 ] line_comp6 = testCase "Expected lineranges for width shorter than some group titles" $ ((renderedLines $ computeLinePosRanges 10 sample_field1) @?= [ LinePosRange 0 13 , LinePosRange 3 14, LinePosRange 3 1 , LinePosRange 0 0 , LinePosRange (3 + 5 + 3) 6 , LinePosRange (3 + 3) 4 , LinePosRange 0 17, LinePosRange 0 17, LinePosRange 0 17, LinePosRange 0 17, LinePosRange 0 17, LinePosRange 0 5 , LinePosRange 6 0 , LinePosRange 0 5 ]) line_comp7 = testCase "drawing no items output wide width tall" $ let width = 50 len = 500 itms = [] st8s = [] rdata = computeLinePosRanges width $ newItemField itms Nothing redraw = redrawSt8Lines len itms st8s rdata blanks n = (T.replicate n (T.singleton ' ') , itemBlankAttr) noneline = [ blanks 14 , (T.pack "[None identified yet]", itemNoneMessageAttr) , blanks 15 ] in [ noneline ] @=? redraw line_comp8 = testCase "drawing expected output for wide width tall" $ let width = 50 len = 500 itms = items sample_field1 st8s = itemst8 sample_field1 rdata = computeLinePosRanges width $ newItemField itms Nothing redraw = redrawSt8Lines len itms st8s rdata freedot = (".",itemFreeAttr) blank = (" ",itemBlankAttr) expected = [replicate 13 freedot ,[("g1",itemHeaderAttr) ,blank] <> replicate 15 freedot ,[] ,[("g2",itemHeaderAttr),blank ,("grp3",itemHeaderAttr),blank ,("g4",itemHeaderAttr),blank] <> replicate 6 freedot ,[("g2",itemHeaderAttr),blank ,("g3",itemHeaderAttr),blank ,freedot,freedot,freedot,freedot] , replicate 50 freedot , replicate 40 freedot ,[("empty",itemHeaderAttr),blank] ,[freedot,freedot,freedot,freedot,freedot] ] in expected @=? redraw sample_field1_linepos_width50 = [ LinePosRange 0 13 , LinePosRange 3 15 , LinePosRange 0 0 , LinePosRange (3 + 5 + 3) 6 , LinePosRange (3 + 3) 4 , LinePosRange 0 49, LinePosRange 0 41 , LinePosRange 6 0 , LinePosRange 0 5 ] line_comp9 = testCase "drawing expected output for medium width tall" $ let width = 15 len = 500 itms = items sample_field1 st8s = itemst8 sample_field1 rdata = computeLinePosRanges width $ newItemField itms Nothing redraw = redrawSt8Lines len itms st8s rdata freedot = (".",itemFreeAttr) blank = (" ",itemBlankAttr) expected = [replicate 13 freedot ,[("g1",itemHeaderAttr) ,blank] <> replicate 12 freedot ,[(" ",itemBlankAttr) ,freedot,freedot,freedot] ,[] ,[("g2",itemHeaderAttr),blank ,("grp3",itemHeaderAttr),blank ,("g4",itemHeaderAttr),blank] <> replicate 4 freedot ,[(" ",itemBlankAttr) ,(" ",itemBlankAttr) ,(" ",itemBlankAttr) ,freedot,freedot] ,[("g2",itemHeaderAttr),blank ,("g3",itemHeaderAttr),blank ,freedot,freedot,freedot,freedot] , replicate 15 freedot , replicate 15 freedot , replicate 15 freedot , replicate 15 freedot , replicate 15 freedot , replicate 15 freedot ,[("empty",itemHeaderAttr),blank] ,[freedot,freedot,freedot,freedot,freedot] ] tl = 1 -- in (expected !! tl) @=? (redraw !! tl) in expected @=? redraw line_comp10 = testCase "empty but width is too short for none message" $ let width = 15 len = 500 itms = [] st8s = [] rdata = computeLinePosRanges width $ newItemField itms Nothing redraw = redrawSt8Lines len itms st8s rdata blanks n = (T.replicate n (T.singleton ' ') , itemBlankAttr) noneline = [ (T.empty, itemBlankAttr) , (T.pack (take width "[None identified yet]") , itemNoneMessageAttr) , blanks 0 ] in [noneline] @=? redraw line_comp11 = testCase "drawing Items 0 output wide width tall" $ let width = 50 len = 500 itms = [Items 0] st8s = [] rdata = computeLinePosRanges width $ newItemField itms Nothing redraw = redrawSt8Lines len itms st8s rdata blanks n = (T.replicate n (T.singleton ' ') , itemBlankAttr) msg = "[None identified yet]" lpad = (width - (length msg + 1)) `div` 2 rpad = width - lpad - length msg noneline = [ blanks lpad , (T.pack msg, itemNoneMessageAttr) , blanks rpad ] in [noneline] @=? redraw line_comp12 = testCase "drawing with not enough state elements assumes Free" $ let width = 50 len = 500 itms = [ItemGroup "a" $ Items 2, Items 4] st8s = [] rdata = computeLinePosRanges width $ newItemField itms Nothing redraw = redrawSt8Lines len itms st8s rdata blank = (T.singleton ' ', itemBlankAttr) freedot = (".",itemFreeAttr) expected = [ [("a",itemHeaderAttr),blank,freedot,freedot] , [ freedot, freedot, freedot, freedot ] ] expLines = [LinePosRange 2 2, LinePosRange 0 4] in (expected, expLines) @=? (redraw, renderedLines rdata)