vty-ui 0.3 → 0.4

raw patch · 12 files changed

+217/−100 lines, 12 filesdep ~containersdep ~vty

Dependency ranges changed: containers, vty

Files

• src/Demo.hs +1/−1
• src/Graphics/Vty/Widgets/Base.hs +24/−0
• src/Graphics/Vty/Widgets/Borders.hs +26/−14
• src/Graphics/Vty/Widgets/Composed.hs +10/−0
• src/Graphics/Vty/Widgets/Text.hs +1/−2
• src/Text/Trans/Tokenize.hs +10/−7
• test/TestDriver.hs +5/−72
• test/src/Tests/Instances.hs +30/−0
• test/src/Tests/Text.hs +28/−0
• test/src/Tests/Tokenize.hs +58/−0
• test/src/Tests/Util.hs +14/−0
• vty-ui.cabal +10/−4

@@ -148,7 +148,7 @@ handleEvent (EvKey KPageDown []) = modify pageListDown >> continue handleEvent (EvKey (KASCII 'q') []) = stop handleEvent (EvResize _ h) = do-  let newSize = ceiling (0.05 * fromIntegral h)+  let newSize = ceiling ((0.05 :: Double) * fromIntegral h)   when (newSize > 0) $ modify (resizeList newSize)   continue handleEvent _ = continue

@@ -8,6 +8,8 @@     , vBox     , hFill     , vFill+    , hLimit+    , vLimit     ) where @@ -144,3 +146,25 @@ -- |An alias for 'vBox' intended as sugar to chain widgets vertically. (<-->) :: Widget -> Widget -> Widget (<-->) = vBox++-- |Impose a maximum horizontal size, in columns, on a 'Widget'.+hLimit :: Int -> Widget -> Widget+hLimit maxWidth w = w { growHorizontal = False+                      , render = restrictedRender+                      }+    where+      restrictedRender sz =+          if region_width sz < fromIntegral maxWidth+          then render w sz+          else render w $ sz `withWidth` fromIntegral maxWidth++-- |Impose a maximum vertical size, in rows, on a 'Widget'.+vLimit :: Int -> Widget -> Widget+vLimit maxHeight w = w { growVertical = False+                       , render = restrictedRender+                       }+    where+      restrictedRender sz =+          if region_height sz < fromIntegral maxHeight+          then render w sz+          else render w $ sz `withHeight` fromIntegral maxHeight

@@ -3,6 +3,8 @@ module Graphics.Vty.Widgets.Borders     ( vBorder     , hBorder+    , vBorderWith+    , hBorderWith     , bordered     ) where@@ -32,23 +34,33 @@  -- |Create a single-row horizontal border. hBorder :: Attr -> Widget-hBorder att = Widget {-                growVertical = False-              , growHorizontal = True-              , primaryAttribute = att-              , withAttribute = hBorder-              , render = \s -> renderImg $ char_fill att '-' (region_width s) 1-              }+hBorder = hBorderWith '-' +-- |Create a single-row horizontal border using the specified+-- attribute and character.+hBorderWith :: Char -> Attr -> Widget+hBorderWith ch att =+    Widget { growVertical = False+           , growHorizontal = True+           , primaryAttribute = att+           , withAttribute = hBorder+           , render = \s -> renderImg $ char_fill att ch (region_width s) 1+           }+ -- |Create a single-column vertical border. vBorder :: Attr -> Widget-vBorder att = Widget {-                growHorizontal = False-              , growVertical = True-              , primaryAttribute = att-              , render = \s -> renderImg $ char_fill att '|' 1 (region_height s)-              , withAttribute = vBorder-              }+vBorder = vBorderWith '|'++-- |Create a single-column vertical border using the specified+-- attribute and character.+vBorderWith :: Char -> Attr -> Widget+vBorderWith ch att =+    Widget { growHorizontal = False+           , growVertical = True+           , primaryAttribute = att+           , render = \s -> renderImg $ char_fill att ch 1 (region_height s)+           , withAttribute = vBorder+           }  -- |Wrap a widget in a bordering box using the specified attribute. bordered :: Attr -> Widget -> Widget

@@ -2,6 +2,7 @@ module Graphics.Vty.Widgets.Composed     ( bottomPadded     , topPadded+    , boxLimit     ) where @@ -11,6 +12,8 @@ import Graphics.Vty.Widgets.Base     ( (<-->)     , vFill+    , vLimit+    , hLimit     )  -- |Add expanding bottom padding to a widget.@@ -20,3 +23,10 @@ -- |Add expanding top padding to a widget. topPadded :: Widget -> Widget topPadded w = vFill (primaryAttribute w) ' ' <--> w++-- |Impose a maximum size (width, height) on a widget.+boxLimit :: Int -- ^Maximum width in columns+         -> Int -- ^Maximum height in rows+         -> Widget+         -> Widget+boxLimit maxWidth maxHeight = vLimit maxHeight . hLimit maxWidth

@@ -94,8 +94,7 @@ wrap :: Formatter wrap sz t = t { tokens = newTokens }     where-      newTokens = concatMap (wrapLine attr width) $ tokens t-      attr = defaultAttr t+      newTokens = concatMap (wrapLine width) $ tokens t       width = fromEnum $ region_width sz  -- |A highlight formatter takes a regular expression used to scan the

@@ -28,7 +28,6 @@ import Data.List     ( inits     , intercalate-    , splitAt     )  -- |The type of textual tokens.  Tokens have an "annotation" type,@@ -63,6 +62,7 @@  -- |Tokenize a string using a default annotation value. tokenize :: String -> a -> [[Token a]]+tokenize [] _ = [[]] tokenize s def = map (tokenize' def) $ splitWith s (== '\n')  tokenize' :: a -> String -> [Token a]@@ -101,18 +101,21 @@       passing = dropWhile ((> width) . sum) cases  -- |Given a list of tokens without Newlines, (potentially) wrap the--- list to the specified column width, using the specified default--- annotation.-wrapLine :: (Eq a) => a -> Int -> [Token a] -> [[Token a]]-wrapLine _ _ [] = []-wrapLine def width ts =+-- list to the specified column width.+wrapLine :: Int -> [Token a] -> [[Token a]]+wrapLine _ [] = []+wrapLine width ts =     -- If there were no passing cases, that means the line can't be     -- wrapped so just return it as-is (e.g., one long unbroken     -- string).  Otherwise, package up the acceptable tokens and     -- continue wrapping.     if null passing     then [ts]-    else these : wrapLine def width those+    else if null these+         then if length those' == 1+              then [those']+              else [head those'] : (wrapLine width $ tail those')+         else these : wrapLine width those     where       lengths = map (length . tokenString) ts       cases = reverse $ inits lengths

@@ -2,83 +2,16 @@ module Main where  import System.Exit ( exitFailure, exitSuccess )--import Data.Word ( Word8 )-import Data.Char ( isPrint ) import Test.QuickCheck import Test.QuickCheck.Test-import Control.Applicative ( (<$>), (<*>), pure ) -import Graphics.Vty-import Graphics.Vty.Widgets.Text-import Graphics.Vty.Widgets.Rendering--import Text.Trans.Tokenize--instance (Arbitrary a, Eq a) => Arbitrary (MaybeDefault a) where-    arbitrary = oneof [ pure Default-                      , pure KeepCurrent-                      , SetTo <$> arbitrary-                      ]--instance Arbitrary Word8 where-    arbitrary = toEnum <$> choose (0, 255)--instance Arbitrary Color where-    arbitrary = oneof [ ISOColor <$> arbitrary-                      , Color240 <$> arbitrary-                      ]--instance Arbitrary Attr where-    arbitrary = Attr <$> arbitrary <*> arbitrary <*> arbitrary--instance Arbitrary DisplayRegion where-    arbitrary = DisplayRegion <$> coord <*> coord-        where-          coord = sized $ \n -> fromIntegral <$> choose (0, n)--instance (Arbitrary a) =>  Arbitrary (Token a) where-    arbitrary = oneof [ Whitespace <$> ws <*> arbitrary-                      , Token <$> s <*> arbitrary-                      ]-        where-          ws = oneof [ pure " ", pure "\t" ]-          s = replicate <$> choose (1, 10) <*> pure 'a'--toImage :: DisplayRegion -> Widget -> Image-toImage sz w = fst $ mkImageSize upperLeft sz w-    where upperLeft = DisplayRegion 0 0--textSize :: Property-textSize =-    property $ forAll textString $ \str attr sz ->-        let img = toImage sz $ simpleText attr str-        in-          if null str || region_height sz == 0 || region_width sz == 0-          then image_height img == 0 && image_width img == 0-          else image_width img <= (toEnum $ length str) && image_height img <= 1--imageSize :: Widget -> DisplayRegion -> Bool-imageSize w sz =-    image_width img <= region_width sz && image_height img <= region_height sz-        where-          img = toImage sz w--textString :: Gen String-textString = listOf (arbitrary `suchThat` (\c -> isPrint c && c /= '\n'))--tokenGen :: Gen [[Token ()]]-tokenGen = listOf $ listOf arbitrary+import qualified Tests.Text as Text+import qualified Tests.Tokenize as Tokenize  tests :: [Property]-tests = [ textSize-        , property $ forAll textString $-                       \str attr -> imageSize (simpleText attr str)-        -- Round-trip property for token serialization and string-        -- tokenization.-        , property $ forAll tokenGen $-                       \ts -> serialize ts == (serialize $ tokenize (serialize ts) ())-        ]+tests = concat [ Text.tests+               , Tokenize.tests+               ]  main :: IO () main = do

@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Tests.Instances where++import Test.QuickCheck+import Control.Applicative ( (<*>), (<$>), pure )+import Data.Word ( Word8 )++import Graphics.Vty++instance (Arbitrary a, Eq a) => Arbitrary (MaybeDefault a) where+    arbitrary = oneof [ pure Default+                      , pure KeepCurrent+                      , SetTo <$> arbitrary+                      ]++instance Arbitrary Word8 where+    arbitrary = toEnum <$> choose (0, 255)++instance Arbitrary Color where+    arbitrary = oneof [ ISOColor <$> arbitrary+                      , Color240 <$> arbitrary+                      ]++instance Arbitrary Attr where+    arbitrary = Attr <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary DisplayRegion where+    arbitrary = DisplayRegion <$> coord <*> coord+        where+          coord = sized $ \n -> fromIntegral <$> choose (0, n)

@@ -0,0 +1,28 @@+module Tests.Text where++import Test.QuickCheck+import Data.Char ( isPrint )++import Graphics.Vty+import Graphics.Vty.Widgets.Text++import Tests.Util+import Tests.Instances ()++textSize :: Property+textSize =+    property $ forAll textString $ \str attr sz ->+        let img = toImage sz $ simpleText attr str+        in+          if null str || region_height sz == 0 || region_width sz == 0+          then image_height img == 0 && image_width img == 0+          else image_width img <= (toEnum $ length str) && image_height img <= 1++textString :: Gen String+textString = listOf (arbitrary `suchThat` (\c -> isPrint c && c /= '\n'))++tests :: [Property]+tests = [ label "textSize" textSize+        , label "imageSize" $ property $ forAll textString $+                    \str attr -> imageSize (simpleText attr str)+        ]

@@ -0,0 +1,58 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Tests.Tokenize where++import Data.Char ( isPrint )+import Control.Applicative ( (<$>), (<*>), pure )+import Test.QuickCheck++import Text.Trans.Tokenize++instance (Arbitrary a) => Arbitrary (Token a) where+    arbitrary = oneof [ Whitespace <$> ws <*> arbitrary+                      , Token <$> s <*> arbitrary+                      ]+        where+          ws = oneof [ pure " ", pure "\t" ]+          s = replicate <$> choose (1, 10) <*> pure 'a'++tokenGen :: Gen [[Token ()]]+tokenGen = listOf $ listOf arbitrary++lineGen :: Gen [Token ()]+lineGen = listOf1 arbitrary++stringGen :: Gen String+stringGen = listOf (arbitrary `suchThat` (\c -> isPrint c))++checkToken :: Token a -> Bool+checkToken (Whitespace s _) = all (`elem` " \t") s+checkToken (Token s _) = all (not . (`elem` " \t")) s++count :: (a -> Bool) -> [a] -> Int+count _ [] = 0+count f (a:as) = count f as + if f a then 1 else 0++numNewlines :: String -> Int+numNewlines = count (== '\n')++tests :: [Property]+tests = [ label "tokenizeConsistency" $ property $ forAll tokenGen $+                    \ts -> serialize ts == (serialize $ tokenize (serialize ts) ())+        , label "tokenizeContents" $ property $ forAll stringGen $+                    \s -> all (all checkToken) $ tokenize s undefined+        , label "tokenizeNewlines" $ property $ forAll stringGen $+                    \s -> numNewlines s + 1 == (length $ tokenize s undefined)+        , label "truncLine" $ property $ forAll lineGen $+                    \ts -> forAll (arbitrary :: Gen (Positive Int)) $+                    \width -> length (truncLine (fromIntegral width) ts) <=+                              (fromIntegral width)+        -- wrapping: a single line wrapped should always result in+        -- lines that are no greater than the wrapping width, unless+        -- they have a single token.+        , label "wrapLine" $ property $ forAll lineGen $+                    \ts -> forAll (choose (0, length ts + 1)) $+                    \width -> let ls = wrapLine w ts+                                  w = fromIntegral width+                                  f l = length (serialize [l]) <= w || length l == 1+                              in all f ls+        ]

@@ -0,0 +1,14 @@+module Tests.Util where++import Graphics.Vty+import Graphics.Vty.Widgets.Rendering++toImage :: DisplayRegion -> Widget -> Image+toImage sz w = fst $ mkImageSize upperLeft sz w+    where upperLeft = DisplayRegion 0 0++imageSize :: Widget -> DisplayRegion -> Bool+imageSize w sz =+    image_width img <= region_width sz && image_height img <= region_height sz+        where+          img = toImage sz w

@@ -1,5 +1,5 @@ Name:                vty-ui-Version:             0.3+Version:             0.4 Synopsis:            A user interface composition library for Vty Description:         An extensible library of user interface widgets                      for composing and laying out Vty user interfaces.@@ -25,8 +25,8 @@ Library   Build-Depends:     base >= 4 && < 5,-    vty >= 4.0 && < 4.1,-    containers >= 0.2 && < 0.3,+    vty >= 4.0 && < 4.5,+    containers >= 0.2 && < 0.4,     pcre-light >= 0.3 && < 0.4    GHC-Options:       -Wall@@ -52,8 +52,14 @@   if !flag(testing)     Buildable:     False   end-  Hs-Source-Dirs:  src,test+  Hs-Source-Dirs:  src,test,test/src   Main-is:         TestDriver.hs++  Other-Modules:+        Tests.Instances+        Tests.Util+        Tests.Text+        Tests.Tokenize  Executable vty-ui-demo   Hs-Source-Dirs:  src