vty-ui 1.5.1 → 1.6

raw patch · 54 files changed

+1991/−1191 lines, 54 filesdep +randomdep +textdep +vty-uidep ~QuickCheckdep ~containersdep ~directory

Dependencies added: random, text, vty-ui

Dependency ranges changed: QuickCheck, containers, directory, mtl, stm, unix, vty

Files

• demos/ComplexDemo.hs +169/−0
• demos/DialogDemo.hs +40/−0
• demos/DirBrowserDemo.hs +17/−0
• demos/EditDemo.hs +40/−0
• demos/ListDemo.hs +137/−0
• demos/PhoneInputDemo.hs +80/−0
• demos/ProgressBarDemo.hs +58/−0
• doc/Makefile +4/−4
• doc/ch1/api_notes.tex +11/−1
• doc/ch1/getting_started.tex +10/−5
• doc/ch3/implementing_composite_widgets.tex +4/−4
• doc/ch3/implementing_event_handlers.tex +3/−3
• doc/ch3/new_widget_type.tex +29/−23
• doc/ch3/widgetimpl_api.tex +6/−0
• doc/ch4/DirBrowser.tex +3/−1
• doc/ch4/Edit.tex +15/−3
• doc/ch4/FormattedText.tex +5/−5
• doc/ch5/TextClip.tex +47/−0
• doc/ch5/TextZipper.tex +67/−0
• doc/ch5/main.tex +8/−0
• doc/macros.tex +1/−1
• doc/vty-ui-users-manual.tex +1/−0
• src/ComplexDemo.hs +0/−163
• src/DialogDemo.hs +0/−38
• src/DirBrowserDemo.hs +0/−17
• src/EditDemo.hs +0/−39
• src/Graphics/Vty/Widgets/All.hs +4/−0
• src/Graphics/Vty/Widgets/Borders.hs +41/−27
• src/Graphics/Vty/Widgets/Button.hs +5/−2
• src/Graphics/Vty/Widgets/CheckBox.hs +28/−19
• src/Graphics/Vty/Widgets/Core.hs +53/−22
• src/Graphics/Vty/Widgets/Dialog.hs +5/−4
• src/Graphics/Vty/Widgets/DirBrowser.hs +53/−25
• src/Graphics/Vty/Widgets/Edit.hs +183/−354
• src/Graphics/Vty/Widgets/List.hs +8/−7
• src/Graphics/Vty/Widgets/ProgressBar.hs +65/−35
• src/Graphics/Vty/Widgets/Table.hs +5/−5
• src/Graphics/Vty/Widgets/Text.hs +15/−15
• src/Graphics/Vty/Widgets/TextClip.hs +116/−0
• src/Graphics/Vty/Widgets/TextZipper.hs +297/−0
• src/Graphics/Vty/Widgets/Util.hs +40/−1
• src/ListDemo.hs +0/−134
• src/PhoneInputDemo.hs +0/−78
• src/ProgressBarDemo.hs +0/−56
• src/Text/Trans/Tokenize.hs +47/−30
• test/TestDriver.hs +6/−0
• test/src/Tests/Edit.hs +46/−0
• test/src/Tests/FormattedText.hs +7/−5
• test/src/Tests/Instances.hs +14/−0
• test/src/Tests/TextClip.hs +60/−0
• test/src/Tests/TextZipper.hs +43/−0
• test/src/Tests/Tokenize.hs +27/−14
• test/src/Tests/Util.hs +9/−2
• vty-ui.cabal +59/−49

@@ -0,0 +1,169 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import System.Exit ( exitSuccess )+import System.Locale+import qualified Data.Text as T+import Control.Monad+import Control.Concurrent+import Data.Time.Clock+import Data.Time.Format+import Graphics.Vty hiding (pad)+import Graphics.Vty.Widgets.All++-- Visual attributes.+fg = white+bg = black+focAttr = black `on` yellow+headerAttr = fgColor bright_green+msgAttr = fgColor blue++-- Multi-state checkbox value type+data FrostingType = Chocolate+                  | Vanilla+                  | Lemon+                    deriving (Eq, Show)++main :: IO ()+main = do+  let msg = "- <TAB> switches input elements\n\n\+            \- ordinary keystrokes edit\n\n\+            \- <SPC> toggles radio buttons and checkboxes\n\n\+            \- <ESC> quits"++      columns = [ column (ColFixed 25) `pad` (padAll 1)+                , column ColAuto `pad` (padAll 1)+                ]++  table <- newTable columns BorderFull >>=+           withNormalAttribute (bgColor blue) >>=+           withBorderAttribute (fgColor green)++  tw <- (textWidget wrap msg) >>= withNormalAttribute msgAttr+  mainBox <- vBox table tw >>= withBoxSpacing 1++  r1 <- newCheckbox "Cake"+  r2 <- newCheckbox "Death"+  radioHeader <- plainText T.empty >>= withNormalAttribute headerAttr++  rg <- newRadioGroup+  addToRadioGroup rg r1+  addToRadioGroup rg r2++  r3 <- newMultiStateCheckbox "Frosting" [ (Chocolate, 'C')+                                         , (Vanilla, 'V')+                                         , (Lemon, 'L')+                                         ]++  edit1 <- editWidget >>= withFocusAttribute (white `on` red)+  edit2 <- multiLineEditWidget+  edit2box <- boxFixed 30 3 edit2+  setEditLineLimit edit2 $ Just 3++  edit1Header <- textWidget wrap T.empty >>= withNormalAttribute headerAttr+  edit2Header <- textWidget wrap T.empty >>= withNormalAttribute headerAttr++  lst <- newList (fgColor bright_green)++  selector <- vLimit 3 lst+  listHeader <- plainText T.empty++  rs <- vBox r1 r2++  cbHeader <- plainText T.empty+  timeText <- plainText T.empty++  prog <- newProgressBar (white `on` red) (red `on` white)+  setProgressTextAlignment prog AlignCenter++  addHeadingRow_ table headerAttr ["Column 1", "Column 2"]+  addRow table $ radioHeader .|. rs+  addRow table $ cbHeader .|. r3+  addRow table $ edit1Header .|. edit1+  addRow table $ edit2Header .|. edit2box+  addRow table $ listHeader .|. customCell selector `pad` padNone+  addRow table $ emptyCell .|. timeText+  addRow table $ emptyCell .|. prog++  rg `onRadioChange` \cb -> do+      s <- getCheckboxLabel cb+      setText radioHeader $ T.concat [s, ", please."]++  r3 `onCheckboxChange` \v ->+      setText cbHeader $ T.pack $ concat ["you chose: ", show v]++  prog `onProgressChange` \val ->+      setProgressText prog $ T.concat [ "Progress ("+                                      , T.pack $ show val+                                      , " %)"+                                      ]++  edit1 `onChange` (setText edit1Header)+  edit2 `onChange` (setText edit2Header)++  lst `onSelectionChange` \ev ->+      case ev of+        SelectionOn _ k _ -> setText listHeader $ T.pack $ "You selected: " ++ k+        SelectionOff -> return ()++  lst `onItemActivated` \(ActivateItemEvent _ s _) ->+      setText listHeader $ T.pack $ "You activated: " ++ s++  setEditText edit1 "Foo"+  setEditText edit2 "Bar"+  setCheckboxChecked r1++  setCheckboxState r3 Chocolate+  -- It would be nice if we didn't have to do this, but the+  -- setCheckboxState call above will not notify any state-change+  -- handlers because the state isn't actually changing (from its+  -- original value of Chocolate, the first value in its state list).+  setText cbHeader $ "you chose: Chocolate"++  fgr <- newFocusGroup+  fgr `onKeyPressed` \_ k _ -> do+         case k of+           KEsc -> exitSuccess+           _ -> return False++  let strs = [ "Cookies"+             , "Cupcakes"+             , "Twinkies"+             , "M&Ms"+             , "Fritos"+             , "Cheetos"+             ]++  forM_ strs $ \s ->+      (addToList lst s =<< (plainText $ T.pack s))++  addToFocusGroup fgr r1+  addToFocusGroup fgr r2+  addToFocusGroup fgr r3+  addToFocusGroup fgr edit1+  addToFocusGroup fgr edit2+  addToFocusGroup fgr lst++  ui <- centered =<< hLimit 70 mainBox++  forkIO $ forever $ do+         schedule $ do+           t <- getCurrentTime+           setText timeText $ T.pack $+                   formatTime defaultTimeLocale rfc822DateFormat t+         threadDelay $ 1 * 1000 * 1000++  forkIO $ forever $ do+         let act i = do+               threadDelay $ 1 * 1000 * 1000+               schedule $ setProgress prog (i `mod` 101)+               act $ i + 4+         act 0++  c <- newCollection+  _ <- addToCollection c ui fgr++  runUi c $ defaultContext { focusAttr = focAttr+                           , normalAttr = fg `on` bg+                           }

@@ -0,0 +1,40 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import qualified Data.Text as T+import Graphics.Vty hiding (Button)+import Graphics.Vty.Widgets.All++main :: IO ()+main = do+  e <- editWidget+  fg <- newFocusGroup+  addToFocusGroup fg e++  u <- plainText "Enter some text and press enter." <--> return e+       >>= withBoxSpacing 1++  pe <- padded u (padLeftRight 2)+  (d, dFg) <- newDialog pe "<enter text>"+  setNormalAttribute d (white `on` blue)++  c <- centered =<< withPadding (padLeftRight 10) (dialogWidget d)++  -- When the edit widget changes, set the dialog's title.+  e `onChange` setDialogTitle d++  -- When the user presses Enter in the edit widget, accept the+  -- dialog.+  e `onActivate` (const $ acceptDialog d)++  -- Exit either way.+  d `onDialogAccept` const shutdownUi+  d `onDialogCancel` const shutdownUi++  coll <- newCollection+  _ <- addToCollection coll c =<< (mergeFocusGroups fg dFg)++  runUi coll $ defaultContext { focusAttr = black `on` yellow }++  (putStrLn . ("You entered: " ++) . T.unpack) =<< getEditText e

@@ -0,0 +1,17 @@+module Main where++import Graphics.Vty+import Graphics.Vty.Widgets.All++main :: IO ()+main = do+  (b, fg) <- newDirBrowser defaultBrowserSkin++  c <- newCollection+  _ <- addToCollection c (dirBrowserWidget b) fg++  b `onBrowseAccept` error+  b `onBrowseCancel` error++  runUi c $ defaultContext { focusAttr = white `on` blue+                           }

@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Graphics.Vty hiding (Button)+import Graphics.Vty.Widgets.All++main :: IO ()+main = do+  e1 <- multiLineEditWidget+  e2 <- multiLineEditWidget+  setEditLineLimit e2 $ Just 3+  e3 <- editWidget++  fg <- newFocusGroup+  _ <- addToFocusGroup fg e1+  _ <- addToFocusGroup fg e2+  _ <- addToFocusGroup fg e3++  be1 <- bordered =<< boxFixed 40 5 e1+  be2 <- bordered =<< boxFixed 40 3 e2+  be3 <- bordered =<< boxFixed 40 1 e3++  c <- centered =<< ((plainText "Multi-Line Editor (unlimited lines):")+                         <--> (return be1)+                         <--> (plainText "Multi-Line Editor (3 lines):")+                         <--> (return be2)+                         <--> (plainText "Single-Line Editor:")+                         <--> (return be3)+                         <--> (plainText "- Esc to quit\n\n- TAB to switch editors") >>= withBoxSpacing 1+                    )++  coll <- newCollection+  _ <- addToCollection coll c fg++  fg `onKeyPressed` \_ k _ ->+      case k of+        KEsc -> shutdownUi >> return True+        _ -> return False++  runUi coll $ defaultContext { focusAttr = fgColor yellow }

@@ -0,0 +1,137 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import System.Exit ( exitSuccess )+import qualified Data.Text as T+import Graphics.Vty+import Graphics.Vty.Widgets.All++data AppElements =+    AppElements { theList :: Widget (List T.Text FormattedText)+                , theBody :: Widget FormattedText+                , theFooter :: Widget FormattedText+                , theListLimit :: Widget (VLimit (List T.Text FormattedText))+                , uis :: Collection+                }++titleAttr = bright_white `on` blue+focAttr = black `on` green+bodyAttr = white `on` black+selAttr = black `on` yellow+keyAttr = fgColor magenta++message1 :: T.Text+message1 = "This demonstration shows how list widgets behave. \n\+           \See the keystrokes below to try the demo."++message2 :: [(T.Text, Attr)]+message2 = [ ("- Press ", def_attr), ("q", keyAttr), (" to quit\n", def_attr)+           , ("- Press ", def_attr), ("+", keyAttr)+           , (" / ", def_attr), ("a", keyAttr)+           , (" to add a list item\n", def_attr)+           , ("- Press ", def_attr), ("-", keyAttr)+           , (" / ", def_attr), ("d", keyAttr)+           , (" to remove the selected list item\n", def_attr)+           , ("- Press ", def_attr)+           , ("up", keyAttr), (" / ", def_attr)+           , ("down", keyAttr), (" / ", def_attr)+           , ("page up", keyAttr), (" / ", def_attr)+           , ("page down", keyAttr)+           , (" to navigate the list\n", def_attr)+           ]++buildUi appst = do+  msg1 <- plainText message1+  setTextFormatter msg1 wrap++  msg2 <- plainTextWithAttrs message2+  setTextFormatter msg2 wrap++  mainUi <- (hBorder >>= withBorderAttribute titleAttr)+         <--> (return $ theList appst)+         <--> ((return $ theFooter appst)+               <++> (hBorder >>= withBorderAttribute titleAttr))++  centered =<< hLimit 55 =<<+             ((return msg1)+                  <--> ((vLimit 25 mainUi >>= bordered)+                        <--> return msg2 >>= withBoxSpacing 1)+                    >>= withBoxSpacing 1)++-- Construct the application statea using the message map.+mkAppElements :: IO AppElements+mkAppElements = do+  lw <- newTextList selAttr []+  b <- textWidget wrap T.empty+  ft <- plainText T.empty >>= withNormalAttribute titleAttr+  ll <- vLimit 5 lw++  c <- newCollection++  return $ AppElements { theList = lw+                       , theBody = b+                       , theFooter = ft+                       , theListLimit = ll+                       , uis = c+                       }++updateBody :: AppElements -> Int -> IO ()+updateBody st i = do+  let msg = "This is the text for list entry " ++ (show $ i + 1)+  setText (theBody st) $ T.pack msg++updateFooterNums :: AppElements -> Widget (List a b) -> IO ()+updateFooterNums st w = do+  result <- getSelected w+  sz <- getListSize w+  let msg = case result of+              Nothing -> "0/0"+              Just (i, _) -> (show $ i + 1) ++ "/" ++ (show sz)+  setText (theFooter st) $ T.pack msg++main :: IO ()+main = do+  st <- mkAppElements++  ui <- buildUi st+  fg <- newFocusGroup++  _ <- addToCollection (uis st) ui fg+  _ <- addToFocusGroup fg (theList st)++  (theList st) `onSelectionChange` \_ -> updateFooterNums st $ theList st+  (theList st) `onItemAdded` \_ -> updateFooterNums st $ theList st+  (theList st) `onItemRemoved` \_ -> updateFooterNums st $ theList st++  let removeCurrentItem = do+         result <- getSelected (theList st)+         case result of+           Nothing -> return ()+           Just (i, _) -> removeFromList (theList st) i >> return ()+      addNewItem =+          (plainText "a list item") >>=+                    addToList (theList st) "unused"++  (theList st) `onKeyPressed` \_ k _ -> do+         case k of+           (KASCII 'q') -> exitSuccess+           (KASCII '-') -> removeCurrentItem >> return True+           (KASCII 'd') -> removeCurrentItem >> return True+           (KASCII '+') -> addNewItem >> return True+           (KASCII 'a') -> addNewItem >> return True+           _ -> return False++  -- We need to call these handlers manually because while they will+  -- be called automatically as items are added to the list in the+  -- future, the items currently in the list didn't call these because+  -- they weren't registered at the time the items were added.  And+  -- that was impossible because the list was created and populated+  -- before we even got a reference to it, so we couldn't have set up+  -- event handlers.+  updateFooterNums st (theList st)++  -- Enter the event loop.+  runUi (uis st) $ defaultContext { normalAttr = bodyAttr+                                  , focusAttr = focAttr+                                  }

@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++-- This demo is discussed in the vty-ui user's manual.++import Control.Monad+import qualified Data.Text as T++import Graphics.Vty hiding (pad)+import Graphics.Vty.Widgets.All++data PhoneNumber = PhoneNumber T.Text T.Text T.Text+                   deriving (Show)++-- This type isn't pretty, but we have to specify the type of the+-- complete interface.  Initially you can let the compiler tell you+-- what it is.+type T = Box (Box+              (Box (Box (HFixed Edit) FormattedText) (HFixed Edit))+              FormattedText) (HFixed Edit)++data PhoneInput =+   PhoneInput { phoneInputWidget :: Widget T+              , edit1 :: Widget Edit+              , edit2 :: Widget Edit+              , edit3 :: Widget Edit+              , activateHandlers :: Handlers PhoneNumber+              }++newPhoneInput :: IO (PhoneInput, Widget FocusGroup)+newPhoneInput = do+   ahs <- newHandlers+   e1 <- editWidget+   e2 <- editWidget+   e3 <- editWidget+   ui <- (hFixed 4 e1) <++>+         (plainText "-") <++>+         (hFixed 4 e2) <++>+         (plainText "-") <++>+         (hFixed 5 e3)++   let w = PhoneInput ui e1 e2 e3 ahs+       doFireEvent = const $ do+         num <- mkPhoneNumber+         fireEvent w (return . activateHandlers) num++       mkPhoneNumber = do+         s1 <- getEditText e1+         s2 <- getEditText e2+         s3 <- getEditText e3+         return $ PhoneNumber s1 s2 s3++   e1 `onActivate` doFireEvent+   e2 `onActivate` doFireEvent+   e3 `onActivate` doFireEvent++   e1 `onChange` \s -> when (T.length s == 3) $ focus e2+   e2 `onChange` \s -> when (T.length s == 3) $ focus e3++   fg <- newFocusGroup+   mapM_ (addToFocusGroup fg) [e1, e2, e3]+   return (w, fg)++onPhoneInputActivate :: PhoneInput+                     -> (PhoneNumber -> IO ()) -> IO ()+onPhoneInputActivate input handler =+    addHandler (return . activateHandlers) input handler++main :: IO ()+main = do+  (p, fg) <- newPhoneInput+  p `onPhoneInputActivate` (error . show)++  ui <- padded (phoneInputWidget p) (padLeftRight 5 `pad` padTopBottom 2)++  c <- newCollection+  _ <- addToCollection c ui fg++  runUi c $ defaultContext { focusAttr = white `on` blue+                           }

@@ -0,0 +1,58 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-missing-signatures #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import qualified Data.Text as T+import Control.Concurrent (forkIO, threadDelay)+import Control.Monad (forever)++import System.Exit ( exitSuccess )+import Graphics.Vty+import Graphics.Vty.Widgets.All++-- Visual attributes.+focAttr = black `on` green+bodyAttr = bright_green `on` black+completeAttr = white `on` red+incompleteAttr = red `on` white++setupProgessBar :: IO (Widget ProgressBar)+setupProgessBar = do+  pb <- newProgressBar completeAttr incompleteAttr+  setProgressTextAlignment pb AlignCenter++  pb `onProgressChange` \val ->+      setProgressText pb $ T.pack $ "Progress (" ++ show val ++ " %)"++  return pb++setupProgressBarThread :: Widget ProgressBar -> IO ()+setupProgressBarThread pb = do+  forkIO $ forever $ do+    let act i = do+          threadDelay $ 1 * 1000 * 1000+          schedule $ setProgress pb (i `mod` 101)+          act $ i + 4+    act 0+  return ()++setupDialog :: (Show a) => Widget a -> IO (Dialog, Widget FocusGroup)+setupDialog ui = do+  (dlg, fg) <- newDialog ui "Progress Bar Demo"+  dlg `onDialogAccept` const exitSuccess+  dlg `onDialogCancel` const exitSuccess+  return (dlg, fg)++main :: IO ()+main = do+  pb <- setupProgessBar+  setupProgressBarThread pb++  (dlg, dlgFg) <- setupDialog pb++  c <- newCollection+  _ <- addToCollection c (dialogWidget dlg) dlgFg++  runUi c $ defaultContext { normalAttr = bodyAttr+                           , focusAttr = focAttr+                           }

@@ -1,9 +1,9 @@ -vty-ui-users-manual.pdf: *.tex ch[1234]/*.tex+vty-ui-users-manual.pdf: *.tex ch?/*.tex 	# Run it twice so the TOC gets generated properly-	pdflatex -shell-escape vty-ui-users-manual.tex-	pdflatex -shell-escape vty-ui-users-manual.tex+	pdflatex -halt-on-error -shell-escape vty-ui-users-manual.tex+	pdflatex -halt-on-error -shell-escape vty-ui-users-manual.tex  clean: 	rm -f *~ *.dvi *.pdf *.log *.aux *.toc *.out-	rm -f ch[1234]/*.aux ch[1234]/*~+	rm -f ch?/*.aux ch?/*~

@@ -1,5 +1,7 @@ \section{Conventions and API Notes} +\subsection{Widget Types}+ When you create a widget in \vtyui, the result with almost always have a type like \fw{Widget a}.  The type variable \fw{a} represents the specific type of state the widget can carry, and therefore which@@ -15,12 +17,20 @@ \fw{Widget a} whenever you need to refer to a widget; this makes it possible to mutate widget state when events occur in your application. +\subsection{Return Values}+ Regarding return values, even if a function is of type \fw{...\ -> IO   a}, we say it is ``in the \fw{IO} monad'' and \textit{returns} \fw{a}.  We won't bother saying that a function \textit{returns \fw{IO     a}}. +\subsection{Library Modules}+ Lastly, we will refer to the many \vtyui\ library modules throughout this document.  We will almost always omit the \fw{Graphics.Vty.Widgets} module namespace prefix and will instead-refer to the modules by their short names.+refer to the modules by their short names.  In addition, many modules+in this library use \fw{Data.Text} values to represent text strings.+We assume that \fw{Data.Text} is imported under the qualified name+\fw{T}.  We also assume the use of the \fw{OverloadedStrings} compiler+language extension to avoid the repeated use of \fw{T.pack}.

@@ -8,8 +8,8 @@  import Graphics.Vty.Widgets.All \end{haskellcode} -The \fw{All} module exports everything exported by the library; if you-prefer, you may import specific modules depending on your needs.+The \fw{All} module exports almost everything exported by the library.+If you prefer, you can always import specific modules.  As a demonstration, we'll create a program which presents an editing widget in the middle of the screen.  You'll be able to provide some@@ -17,6 +17,8 @@ will print what you entered.  The code for this program is as follows:  \begin{haskellcode}+ import qualified Data.Text as T+  main :: IO ()  main = do    e <- editWidget@@ -29,7 +31,7 @@    addToCollection c ui fg     e `onActivate` \this ->-     getEditText this >>= (error . ("You entered: " ++))+     getEditText this >>= (error . ("You entered: " ++) . T.unpack)     runUi c defaultContext \end{haskellcode}@@ -106,7 +108,7 @@  \begin{haskellcode}  e `onActivate` \this -> getEditText this >>=-   (error . ("You entered: " ++))+   (error . ("You entered: " ++) . T.unpack) \end{haskellcode}  This binds an event handler to the ``activation'' of the \fw{Edit}@@ -114,7 +116,10 @@ and presses \fw{Enter}.  The handler for this event is an \fw{IO} action which takes the \fw{Edit} widget itself as its only parameter. The \fw{getEditText} function gets the current text of the \fw{Edit}-widget, and we use \fw{error} to abort the program and print the text.+widget, and we use \fw{error} to abort the program and print the+text.\footnote{In general I wouldn't recommend the use of \fw{error}+  to do this, but the \vtyui\ event loop will still cleanly shut down+  and clean up Vty in the event of any exception.}  \begin{haskellcode}  runUi c defaultContext

@@ -41,7 +41,7 @@ implementing \fw{WidgetImpl}'s interface.  First we provide the types:  \begin{haskellcode}- data PhoneNumber = PhoneNumber String String String+ data PhoneNumber = PhoneNumber T.Text T.Text T.Text                     deriving (Show)   -- This type isn't pretty, but we have to specify the type@@ -78,9 +78,6 @@          (plainText "-") <++>          (hFixed 5 e3) -   e1 `onChange` \s -> when (length s == 3) $ focus e2-   e2 `onChange` \s -> when (length s == 3) $ focus e3-    let w = PhoneInput ui e1 e2 e3 ahs        doFireEvent = const $ do          num <- mkPhoneNumber@@ -95,6 +92,9 @@    e1 `onActivate` doFireEvent    e2 `onActivate` doFireEvent    e3 `onActivate` doFireEvent++   e1 `onChange` \s -> when (T.length s == 3) $ focus e2+   e2 `onChange` \s -> when (T.length s == 3) $ focus e3     fg <- newFocusGroup    mapM_ (addToFocusGroup fg) [e1, e2, e3]

@@ -68,9 +68,9 @@  We've introduced a new operator here, \fw{<\string~\string~}.  This operator takes any \fw{Widget a} and a function on its state type,-\fw{a -> b}, and runs the function and returns the value, \fw{b},-inside calling monad.  \fw{addHandler} needs a value of type-\fw{Handlers TemperatureEvent}, and to get that we must use+applies the function to the state, and returns the result.+\fw{add\-Handler} needs a value of type \fw{Handlers+  Temperature\-Event}, and to get that we must use \fw{<\string~\string~}.  The \fw{addHandler} function takes a \fw{Handlers a} and a handler of

@@ -8,20 +8,20 @@ As an example, consider a widget that displays a numeric counter.  The widget state will be the value of the counter.  We'll start with the following state type:\footnote{You might wonder why we don't just use-  \fw{Int}; the reason is because that's too general.  Other widgets-  might represent the temperature with an \fw{Int}, and then your-  counter API functions -- taking a widget of type \fw{Widget Int} ---  would work on their widgets, which is probably not what you want!}+  \fw{Int}, i.e., \fw{Widget Int}; the reason is because that's too+  general.  Other widgets might represent the temperature with an+  \fw{Int}, and then your counter API functions -- taking a widget of+  type \fw{Widget Int} -- would work on other types of widgets, which+  is probably not what you want!}  \begin{haskellcode}  data Counter = Counter Int \end{haskellcode}  The next step is to write a widget constructor function.  This-function will return a value of type \fw{Widget Counter}, which-indicates that it is a \fw{Widget} with state type \fw{Counter}.-We'll allow the constructor to take the counter's initial value.-Here's what the function will look like in full:+function will return a value of type \fw{Widget Counter}.  The+constructor will take the counter's initial value.  Here's the+function in full:  \begin{haskellcode}  newCounter :: Int -> IO (Widget Counter)@@ -48,15 +48,15 @@ where all of the widget logic is actually implemented.  You implement this logic by overriding the fields of the \fw{WidgetImpl} type, such as \fw{render\_}.  We call \fw{newWidget}'s result \fw{wRef} because-it is a reference to a widget object, and this helps distinguish it-from the actual widget data in the next step.+it is a reference to a widget, and this helps distinguish it from the+actual widget data in the next step.  The \fw{newWidget} function takes an initial state of the widget (of type \fw{a}) and a transformation function \fw{WidgetImpl a ->   WidgetImpl a}, creates a new \fw{WidgetImpl}, sets its \fw{state} to the initial state provided, and transforms it with the transformation function.  We do this to specify the behavior of the widget beyond the-defaults, which are specified in the \fw{newWidget} function.+defaults provided by the \fw{newWidget} function.  Here is the \fw{render\_} function which will actually construct a Vty \fw{Image} to be displayed in the terminal:@@ -65,14 +65,15 @@  render_ =    \this size ctx -> do      (Counter v) <- getState this-     let s = show v-         width = fromEnum $ region_width size - length s-         truncated = take width s-     return $ string (getNormalAttr ctx) truncated+     let s = T.pack $ show v+         width = (fromEnum $ region_width size) -+                 (fromEnum $ textWidth s)+         (truncated, _, _) = clip1d (Phys 0) (Phys width) s+     return $ string (getNormalAttr ctx) $ T.unpack truncated \end{haskellcode}  The type of \fw{render\_} is \fw{Widget a -> DisplayRegion ->-  RenderContext -> IO Image}.  The types are as follows:+  RenderContext -> IO Image}.  The arguments are as follows:  \begin{itemize} \item \fw{Widget a} - the widget being rendered, i.e., the \fw{Widget@@ -88,8 +89,8 @@   widget sizes are used to compute widget positions, so sizes must be   accurate. -  A widget may render to an \fw{Image} \textit{smaller} than the-  specified size; many do.+  A widget must render to an \fw{Image} \textit{no larger} than the+  specified size. \item \fw{RenderContext} - the rendering context passed to \fw{runUi}   as explained in Section \ref{sec:event_loop}.  In the \fw{render\_}   function, we use this to determine which screen attributes to use.@@ -114,17 +115,22 @@ the latest state value at the time \fw{render\_} is called.  \begin{haskellcode}- let s = show v-     width = fromEnum $ region_width size - length s-     truncated = take width s+ let s = T.pack $ show v+     width = (fromEnum $ region_width size) -+             (fromEnum $ textWidth s)+     (truncated, _, _) = clip1d (Phys 0) (Phys width) s \end{haskellcode}  To ensure that the \fw{Image} we generate does not exceed \fw{size} as described above, we use the width of the region to limit how many-characters we take from the string representation of the counter.+characters we take from the string representation of the counter.  We+also introduce a function to calculate the width of our counter+string, \fw{textWidth}, and a function to clip the string to the+desired width, \fw{clip1d}.  For more information on text clipping,+see Section \ref{sec:textclip}.  \begin{haskellcode}- return $ string (getNormalAttr ctx) truncated+ return $ string (getNormalAttr ctx) $ T.unpack truncated \end{haskellcode}  The \fw{string} function is a Vty library function which takes an

@@ -7,6 +7,7 @@ \begin{haskellcode}  data WidgetImpl a = WidgetImpl {        state :: a+     , visibie :: Bool      , render_ :: Widget a -> DisplayRegion -> RenderContext                -> IO Image      , growHorizontal_ :: a -> IO Bool@@ -39,6 +40,11 @@ \item \fw{focused} -- \fw{True} if this widget is focused.  As   explained in Section \ref{sec:focus}, although one widget has the   user's focus, internally many widgets may share it in a hierarchy.+\item \fw{visible} -- \fw{True} if this widget is visible.  Visible+  widgets will be rendered as usual, but invisible widgets+  automatically render to empty images and do not grow horizontally or+  vertically.  This field can be manipulated with \fw{setVisible} and+  read with \fw{getVisible}. \item \fw{currentSize} -- the ``current'' size of the widget, i.e.,   the size of the \fw{Image} \textit{after} the last time the widget   was rendered.

@@ -146,7 +146,9 @@  \begin{haskellcode}  browser `onBrowseAccept` \path ->-   reportBrowserError browser $ "not a valid document: " ++ path+   reportBrowserError browser $ T.concat [ "not a valid document: "+                                         , T.pack path+                                         ] \end{haskellcode}  \subsubsection{Growth Policy}

@@ -77,11 +77,23 @@   \fw{setEditLineLimit \$ Just 0} is a no-op. \end{itemize} +\subsubsection{Wide Character Support}++Some characters, such as those from some Asian character sets, require+two columns instead of one when displayed in a terminal.  The+\fw{Edit} widget supports such characters with one caveat: when a wide+character straddles the left or right viewing boundary of an \fw{Edit}+widget, an indicator (\fw{\$}) will be displayed in its place to+indicate that a wide character lies on the boundary and can be+revealed by scrolling further in the appropriate direction.  Such+indicators are only visual and do not affect the underlying text, so+e.g. calls to \fw{getEditText} will return the text as expected.+ \subsubsection{Growth Policy}  Single-line \fw{Edit} widgets -- those created by \fw{editWidget} -- grow only horizontally and are always one row high.  Multi-line edit-widgets -- those created by \fw{multiLineEditWidget} -- always grow in-both dimensions.  To manage this behavior, you can use one of the-``fixed'' family of widgets to control their sizes (see Section+widgets -- those created by \fw{multi\-Line\-Edit\-Widget} -- always+grow in both dimensions.  To manage this behavior, you can use one of+the ``fixed'' family of widgets to control their sizes (see Section \ref{sec:fixed}).

@@ -20,8 +20,8 @@ The contents of a text widget can be set in one of three ways: \begin{itemize} \item Initially, as a parameter to \fw{plainText} and \fw{textWidget}-\item As a \fw{String} parameter to \fw{setText}-\item As a list parameter of \fw{(String, Attr)} with+\item As a \fw{Text} parameter to \fw{setText}+\item As a list parameter of \fw{(Text, Attr)} with   \fw{setTextWithAttrs} \end{itemize} @@ -32,8 +32,8 @@ defaults to the ``normal'' attribute of the widget (see Section \ref{sec:attributes} for more information on attributes). -The \fw{setText} function merely takes a \fw{String}, tokenizes it,-and assigns the default attribute to all tokens.+The \fw{setText} function merely takes a \fw{Text} value, tokenizes+it, and assigns the default attribute to all tokens.  The \fw{setTextWithAttrs} function provides finer control over the initial attribute assignment to the text because it lets you specify@@ -70,7 +70,7 @@ \end{haskellcode}  In addition, the formatter for a text widget can be set at any time-with \fw{setTextFormatter}:+with \fw{set\-Text\-Formatter}:  \begin{haskellcode}  setTextFormatter t someFormatter

@@ -0,0 +1,47 @@+\section{Text Clipping}+\label{sec:textclip}++Most widgets in \vtyui\ render some form of text.  When we render+text, we have to reason about the amount of space -- columns -- that+the text will consume in the terminal so that we can render coherent+interfaces.  However, this is tricky because some characters use one+column of space and others use+two.\footnote{\url{http://www.unicode.org/reports/tr11/}} To account+for this possibility, any code which deals with computing the space+required for text must consider the width of \textit{each character}.++In cases where we have to consider character width, the most common+operation we're trying to perform is to \textit{clip} a text string to+ensure that it fits within a given region.  The \fw{TextClip} module+provides types and functions to do this in one and two dimensions:++\begin{itemize}+\item \fw{ClipRect} - the type of two-dimensional clipping regions.+  Allows you to specify a top-left corner, a clipping width, and a+  clipping height.+\item \fw{clip1d} - performs one-dimensional clipping on a single line+  of text.+\item \fw{clip2d} - performs two-dimensional clipping on a list of+  lines of text using a \fw{Clip\-Rect}.+\end{itemize}++The functions in the \fw{TextClip} module deal in physical values+expressed using the \fw{Phys} type.  This type designates a+\textit{physical width} as opposed to a logical one.  We use this+distinction to gain compile-time clarity about which integer values+refer to logical characters and which ones refer to terminal column+counts.++Both the \fw{clip1d} and \fw{clip2d} functions return text strings+truncated so that their characters fit into the specified physical+space.  They also return \fw{Bool} indicators which can be used to+determine whether clipping occurred in the ``middle'' of wide+characters.  The \fw{Edit} widget uses this feature to annotate+truncated strings to indicate that a wide character can be found on+either end of a truncated line of text.++In simple widgets, we could technically ignore text clipping details+if we know that we'll always be rendering strings which use+single-column characters.  However, we should get in the habit of+always using clipping functions in case we need to start showing+multi-column characters.

@@ -0,0 +1,67 @@+\section{The Text Zipper}++The \fw{TextZipper} module provides a+\textit{zipper}\footnote{\url{http://www.haskell.org/haskellwiki/Zipper}}+data structure to manage the text editing process of multi-line text+buffers.  A \fw{TextZipper} stores text and a \textit{cursor position}+at which editing operations are applied.  The zipper implementation+works for any string representation type that provides implementations+of \fw{drop}, \fw{take}, \fw{length}, \fw{last}, \fw{init}, and+\fw{null}.  The module provides a default implementation (used by the+\fw{Edit} widget) based on the \fw{Data.Text.Text} type.  Its+constructor, \fw{textZipper}, takes a list of \fw{Text} values and+creates a zipper.++\begin{haskellcode}+ let z = textZipper []+\end{haskellcode}++To extract the text content of the zipper, use \fw{getText}:++\begin{haskellcode}+ let theLines = getText z+\end{haskellcode}++The module provides the following \textit{editing transformations}:++\begin{itemize}+\item \fw{moveCursor (row, col)} - Move the cursor to the specified+  cursor position.  Invalid positions will be ignored.+\item \fw{insertChar c} - Insert \fw{c} at the cursor position.+\item \fw{breakLine} - Insert a line break at the cursor position.+\item \fw{killToEOL} - Kill (delete) all text after the cursor+  position up to the end of the current line.+\item \fw{gotoEOL} - Move the cursor past the end of the current line.+\item \fw{gotoBOL} - Move the cursor to just before the beginning of+  the current line.+\item \fw{deletePrevChar} - Delete the character preceding the cursor+  position.  If the cursor is at the beginning of a line, the current+  line will be appended onto the previous line.+\item \fw{deleteChar} - Delete the character at the cursor position.+  If the cursor is at the end of a line, the following line will be+  appended onto the current line.+\item \fw{moveRight} - Move the cursor one position to the right,+  wrapping to the following line if necessary.+\item \fw{moveLeft} - Move the cursor one position to the left,+  wrapping to the preceding line if necessary.+\item \fw{moveUp} - Move the cursor up by one row.+\item \fw{moveDown} - Move the cursor down by one row.+\end{itemize}++These transformations can be composed in natural ways to create a+sequence of editing transformations.  For example:++\begin{haskellcode}+ import Control.Arrow++ doEdits :: TextZipper a -> TextZipper a+ doEdits = foldl (>>>) id [ moveRight+                          , insertChar 'x'+                          , insertChar 'z'+                          , moveLeft+                          , insertChar 'y'+                          , deletePrevChar+                          ]+ -- Later:+ let edited = doEdits $ textZipper theLines+\end{haskellcode}

@@ -0,0 +1,8 @@+\chapter{Other Topics}+\label{chap:other}++This chapter contains supplementary material on various aspects of+\vtyui.++\input{ch5/TextClip}+\input{ch5/TextZipper}

@@ -1,6 +1,6 @@ % Custom macros. -\newcommand{\vtyuiversion}{1.5}+\newcommand{\vtyuiversion}{1.6}  \newcommand{\fw}[1]{\texttt{#1}} \newcommand{\vtyui}{\fw{vty-ui}}

@@ -33,5 +33,6 @@ \include{ch2/main} \include{ch3/main} \include{ch4/main}+\include{ch5/main}  \end{document}

@@ -1,163 +0,0 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}-module Main where--import System.Exit ( exitSuccess )-import System.Locale-import Control.Monad-import Control.Concurrent-import Data.Time.Clock-import Data.Time.Format-import Graphics.Vty hiding (pad)-import Graphics.Vty.Widgets.All---- Visual attributes.-fg = white-bg = black-focAttr = black `on` yellow-headerAttr = fgColor bright_green-msgAttr = fgColor blue---- Multi-state checkbox value type-data FrostingType = Chocolate-                  | Vanilla-                  | Lemon-                    deriving (Eq, Show)--main :: IO ()-main = do-  let msg = "- <TAB> switches input elements\n\n\-            \- ordinary keystrokes edit\n\n\-            \- <SPC> toggles radio buttons and checkboxes\n\n\-            \- <ESC> quits"--      columns = [ column (ColFixed 25) `pad` (padAll 1)-                , column ColAuto `pad` (padAll 1)-                ]--  table <- newTable columns BorderFull >>=-           withNormalAttribute (bgColor blue) >>=-           withBorderAttribute (fgColor green)--  tw <- (textWidget wrap msg) >>= withNormalAttribute msgAttr-  mainBox <- vBox table tw >>= withBoxSpacing 1--  r1 <- newCheckbox "Cake"-  r2 <- newCheckbox "Death"-  radioHeader <- plainText "" >>= withNormalAttribute headerAttr--  rg <- newRadioGroup-  addToRadioGroup rg r1-  addToRadioGroup rg r2--  r3 <- newMultiStateCheckbox "Frosting" [ (Chocolate, 'C')-                                         , (Vanilla, 'V')-                                         , (Lemon, 'L')-                                         ]--  edit1 <- editWidget >>= withFocusAttribute (white `on` red)-  edit2 <- multiLineEditWidget-  edit2box <- boxFixed 30 3 edit2-  setEditLineLimit edit2 $ Just 3--  edit1Header <- textWidget wrap [] >>= withNormalAttribute headerAttr-  edit2Header <- textWidget wrap [] >>= withNormalAttribute headerAttr--  lst <- newList (fgColor bright_green)--  selector <- vLimit 3 lst-  listHeader <- plainText ""--  rs <- vBox r1 r2--  cbHeader <- plainText ""-  timeText <- plainText ""--  prog <- newProgressBar (white `on` red) (red `on` white)-  setProgressTextAlignment prog AlignCenter--  addHeadingRow_ table headerAttr ["Column 1", "Column 2"]-  addRow table $ radioHeader .|. rs-  addRow table $ cbHeader .|. r3-  addRow table $ edit1Header .|. edit1-  addRow table $ edit2Header .|. edit2box-  addRow table $ listHeader .|. customCell selector `pad` padNone-  addRow table $ emptyCell .|. timeText-  addRow table $ emptyCell .|. prog--  rg `onRadioChange` \cb -> do-      s <- getCheckboxLabel cb-      setText radioHeader $ s ++ ", please."--  r3 `onCheckboxChange` \v ->-      setText cbHeader $ "you chose: " ++ show v--  prog `onProgressChange` \val ->-      setProgressText prog $ "Progress (" ++ show val ++ " %)"--  edit1 `onChange` (setText edit1Header)-  edit2 `onChange` (setText edit2Header)--  lst `onSelectionChange` \ev ->-      case ev of-        SelectionOn _ k _ -> setText listHeader $ "You selected: " ++ k-        SelectionOff -> return ()--  lst `onItemActivated` \(ActivateItemEvent _ s _) ->-      setText listHeader $ "You activated: " ++ s--  setEditText edit1 "Foo"-  setEditText edit2 "Bar"-  setCheckboxChecked r1--  setCheckboxState r3 Chocolate-  -- It would be nice if we didn't have to do this, but the-  -- setCheckboxState call above will not notify any state-change-  -- handlers because the state isn't actually changing (from its-  -- original value of Chocolate, the first value in its state list).-  setText cbHeader $ "you chose: Chocolate"--  fgr <- newFocusGroup-  fgr `onKeyPressed` \_ k _ -> do-         case k of-           KEsc -> exitSuccess-           _ -> return False--  let strs = [ "Cookies"-             , "Cupcakes"-             , "Twinkies"-             , "M&Ms"-             , "Fritos"-             , "Cheetos"-             ]--  forM_ strs $ \s ->-      (addToList lst s =<< plainText s)--  addToFocusGroup fgr r1-  addToFocusGroup fgr r2-  addToFocusGroup fgr r3-  addToFocusGroup fgr edit1-  addToFocusGroup fgr edit2-  addToFocusGroup fgr lst--  ui <- centered =<< hLimit 70 mainBox--  forkIO $ forever $ do-         schedule $ do-           t <- getCurrentTime-           setText timeText $ formatTime defaultTimeLocale rfc822DateFormat t-         threadDelay $ 1 * 1000 * 1000--  forkIO $ forever $ do-         let act i = do-               threadDelay $ 1 * 1000 * 1000-               schedule $ setProgress prog (i `mod` 101)-               act $ i + 4-         act 0--  c <- newCollection-  _ <- addToCollection c ui fgr--  runUi c $ defaultContext { focusAttr = focAttr-                           , normalAttr = fg `on` bg-                           }

@@ -1,38 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}-module Main where--import Graphics.Vty hiding (Button)-import Graphics.Vty.Widgets.All--main :: IO ()-main = do-  e <- editWidget-  fg <- newFocusGroup-  addToFocusGroup fg e--  u <- plainText "Enter some text and press enter." <--> return e-       >>= withBoxSpacing 1--  pe <- padded u (padLeftRight 2)-  (d, dFg) <- newDialog pe "<enter text>"-  setNormalAttribute d (white `on` blue)--  c <- centered =<< withPadding (padLeftRight 10) (dialogWidget d)--  -- When the edit widget changes, set the dialog's title.-  e `onChange` setDialogTitle d--  -- When the user presses Enter in the edit widget, accept the-  -- dialog.-  e `onActivate` (const $ acceptDialog d)--  -- Exit either way.-  d `onDialogAccept` const shutdownUi-  d `onDialogCancel` const shutdownUi--  coll <- newCollection-  _ <- addToCollection coll c =<< (mergeFocusGroups fg dFg)--  runUi coll $ defaultContext { focusAttr = black `on` yellow }--  (putStrLn . ("You entered: " ++)) =<< getEditText e

@@ -1,17 +0,0 @@-module Main where--import Graphics.Vty-import Graphics.Vty.Widgets.All--main :: IO ()-main = do-  (b, fg) <- newDirBrowser defaultBrowserSkin--  c <- newCollection-  _ <- addToCollection c (dirBrowserWidget b) fg--  b `onBrowseAccept` error-  b `onBrowseCancel` error--  runUi c $ defaultContext { focusAttr = white `on` blue-                           }

@@ -1,39 +0,0 @@-module Main where--import Graphics.Vty hiding (Button)-import Graphics.Vty.Widgets.All--main :: IO ()-main = do-  e1 <- multiLineEditWidget-  e2 <- multiLineEditWidget-  setEditLineLimit e2 $ Just 3-  e3 <- editWidget--  fg <- newFocusGroup-  _ <- addToFocusGroup fg e1-  _ <- addToFocusGroup fg e2-  _ <- addToFocusGroup fg e3--  be1 <- bordered =<< boxFixed 40 5 e1-  be2 <- bordered =<< boxFixed 40 3 e2-  be3 <- bordered =<< boxFixed 40 1 e3--  c <- centered =<< ((plainText "Multi-Line Editor (unlimited lines):")-                         <--> (return be1)-                         <--> (plainText "Multi-Line Editor (3 lines):")-                         <--> (return be2)-                         <--> (plainText "Single-Line Editor:")-                         <--> (return be3)-                         <--> (plainText "- Esc to quit\n\n- TAB to switch editors") >>= withBoxSpacing 1-                    )--  coll <- newCollection-  _ <- addToCollection coll c fg--  fg `onKeyPressed` \_ k _ ->-      case k of-        KEsc -> shutdownUi >> return True-        _ -> return False--  runUi coll $ defaultContext { focusAttr = fgColor yellow }

@@ -6,6 +6,8 @@     , module Graphics.Vty.Widgets.List     , module Graphics.Vty.Widgets.Borders     , module Graphics.Vty.Widgets.Text+    , module Graphics.Vty.Widgets.TextClip+    , module Graphics.Vty.Widgets.TextZipper     , module Graphics.Vty.Widgets.Edit     , module Graphics.Vty.Widgets.Util     , module Graphics.Vty.Widgets.Table@@ -32,6 +34,8 @@ import Graphics.Vty.Widgets.List import Graphics.Vty.Widgets.Borders import Graphics.Vty.Widgets.Text+import Graphics.Vty.Widgets.TextClip+import Graphics.Vty.Widgets.TextZipper import Graphics.Vty.Widgets.Edit import Graphics.Vty.Widgets.Util import Graphics.Vty.Widgets.Table

@@ -20,6 +20,8 @@     ) where +import qualified Data.Text as T+ import Graphics.Vty import Graphics.Vty.Widgets.Core import Graphics.Vty.Widgets.Box@@ -32,7 +34,7 @@ class HasBorderAttr a where     setBorderAttribute :: a -> Attr -> IO () -data HBorder = HBorder Attr String+data HBorder = HBorder Attr T.Text                deriving (Show)  instance HasBorderAttr (Widget HBorder) where@@ -45,23 +47,23 @@  -- | Adds a label to a horizontal border.  The label will be -- horizontally centered.-withHBorderLabel :: String -> Widget HBorder -> IO (Widget HBorder)+withHBorderLabel :: T.Text -> Widget HBorder -> IO (Widget HBorder) withHBorderLabel label w = setHBorderLabel w label >> return w  -- | Adds a label to a horizontal border.  The label will be -- horizontally centered.-setHBorderLabel :: Widget HBorder -> String -> IO ()+setHBorderLabel :: Widget HBorder -> T.Text -> IO () setHBorderLabel w label =     updateWidgetState w $ \(HBorder a _) -> HBorder a label  -- | Adds a label to the top border of a bordered widget.  The label -- will be horizontally centered.-withBorderedLabel :: String -> Widget (Bordered a) -> IO (Widget (Bordered a))+withBorderedLabel :: T.Text -> Widget (Bordered a) -> IO (Widget (Bordered a)) withBorderedLabel label w = setBorderedLabel w label >> return w  -- | Adds a label to the top border of a bordered widget.  The label -- will be horizontally centered.-setBorderedLabel :: Widget (Bordered a) -> String -> IO ()+setBorderedLabel :: Widget (Bordered a) -> T.Text -> IO () setBorderedLabel w label =     updateWidgetState w $ \(Bordered a ch _) -> Bordered a ch label @@ -69,7 +71,7 @@ -- attribute and character. hBorder :: IO (Widget HBorder) hBorder = do-  let initSt = HBorder def_attr ""+  let initSt = HBorder def_attr T.empty   wRef <- newWidget initSt $ \w ->       w { growHorizontal_ = const $ return True         , render_ = renderHBorder@@ -85,22 +87,30 @@                          , attr                          , normalAttr ctx                          ]-      noTitle = char_fill attr' (skinHorizontal $ skin ctx) (region_width s) 1-  case null str of-    True -> return noTitle-    False -> do-      let title = " " ++ str ++ " "-      case (toEnum $ length title) > region_width s of-        True -> return noTitle-        False -> do-                  let remaining = region_width s - (toEnum $ length title)-                      side1 = remaining `div` 2-                      side2 = if remaining `mod` 2 == 0 then side1 else side1 + 1-                  return $ horiz_cat [ char_fill attr' (skinHorizontal $ skin ctx) side1 1-                                     , string attr' title-                                     , char_fill attr' (skinHorizontal $ skin ctx) side2 1-                                     ]+      ch = skinHorizontal $ skin ctx+      noTitle = T.pack $ replicate (fromEnum $ region_width s) ch +  wStr <- case T.null str of+            True -> return noTitle+            False -> do+              let title = T.concat [ T.pack " "+                                   , str+                                   , T.pack " "+                                   ]+              case (textWidth title) > (Phys $ fromEnum $ region_width s) of+                True -> return noTitle+                False -> do+                       let remaining = (Phys $ fromEnum $ region_width s) - (textWidth title)+                           Phys side1 = remaining `div` Phys 2+                           side2 = if remaining `mod` Phys 2 == Phys 0 then side1 else side1 + 1+                       return $ T.concat [ T.pack $ replicate side1 ch+                                         , title+                                         , T.pack $ replicate side2 ch+                                         ]++  w <- plainTextWithAttrs [(wStr, attr')]+  render w s ctx+ data VBorder = VBorder Attr                deriving (Show) @@ -125,7 +135,7 @@         }   return wRef -data Bordered a = (Show a) => Bordered Attr (Widget a) String+data Bordered a = (Show a) => Bordered Attr (Widget a) T.Text  instance Show (Bordered a) where     show (Bordered attr _ l) = concat [ "Bordered { attr = "@@ -142,7 +152,7 @@ -- |Wrap a widget in a bordering box. bordered :: (Show a) => Widget a -> IO (Widget (Bordered a)) bordered child = do-  let initSt = Bordered def_attr child ""+  let initSt = Bordered def_attr child T.empty   wRef <- newWidget initSt $ \w ->       w { growVertical_ = const $ growVertical child         , growHorizontal_ = const $ growHorizontal child@@ -189,10 +199,14 @@   let adjusted = DisplayRegion (image_width childImage + 2)                  (image_height childImage) -  tlCorner <- plainText [skinCornerTL sk] >>= withNormalAttribute attr'-  trCorner <- plainText [skinCornerTR sk] >>= withNormalAttribute attr'-  blCorner <- plainText [skinCornerBL sk] >>= withNormalAttribute attr'-  brCorner <- plainText [skinCornerBR sk] >>= withNormalAttribute attr'+  tlCorner <- plainText (T.singleton $ skinCornerTL sk)+              >>= withNormalAttribute attr'+  trCorner <- plainText (T.singleton $ skinCornerTR sk)+              >>= withNormalAttribute attr'+  blCorner <- plainText (T.singleton $ skinCornerBL sk)+              >>= withNormalAttribute attr'+  brCorner <- plainText (T.singleton $ skinCornerBR sk)+              >>= withNormalAttribute attr'    hb <- hBorder >>= withHBorderLabel label   setBorderAttribute hb attr'

@@ -11,6 +11,7 @@     ) where +import qualified Data.Text as T import Graphics.Vty.Widgets.Core import Graphics.Vty.Widgets.Text import Graphics.Vty.Widgets.Padding@@ -34,7 +35,7 @@ pressButton b = fireEvent b (return . buttonPressedHandlers) b  -- |Set the text label on a button.-setButtonText :: Button -> String -> IO ()+setButtonText :: Button -> T.Text -> IO () setButtonText b s = setText (buttonText b) s  instance HasNormalAttr Button where@@ -44,7 +45,7 @@     setFocusAttribute b a = setFocusAttribute (buttonWidget b) a  -- |Create a button.  Get its underlying widget with 'buttonWidget'.-newButton :: String -> IO Button+newButton :: T.Text -> IO Button newButton msg = do   t <- plainText msg   setTextAppearFocused t True@@ -53,6 +54,8 @@        withPadding (padLeftRight 3) >>=        withNormalAttribute (white `on` black) >>=        withFocusAttribute (blue `on` white)++  updateWidget w $ \st -> st { getCursorPosition_ = const $ return Nothing }    hs <- newHandlers 

@@ -1,4 +1,5 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable,+  OverloadedStrings #-} -- |This module provides ''check box'' widgets and ''radio button'' -- widgets.  In addition, this module provides a generalized -- ''multi-state'' check box type which allows you to set multiple@@ -40,11 +41,13 @@ import Data.IORef import Data.List ( findIndex ) import Data.Maybe+import qualified Data.Text as T import Control.Monad import Control.Exception import Data.Typeable import Graphics.Vty import Graphics.Vty.Widgets.Core+import Graphics.Vty.Widgets.Text import Graphics.Vty.Widgets.Events import Graphics.Vty.Widgets.Util @@ -126,9 +129,10 @@                            , rightBracketChar :: Char                            , checkboxStates :: [(a, Char)]                            , currentState :: a-                           , checkboxLabel :: String+                           , checkboxLabel :: T.Text                            , checkboxChangeHandlers :: Handlers a                            , checkboxFrozen :: Bool+                           , innerTextWidget :: Widget FormattedText                            }  instance Show a => Show (CheckBox a) where@@ -141,12 +145,12 @@                      ]  -- |Create a new checkbox with the specified text label.-newCheckbox :: String -> IO (Widget (CheckBox Bool))+newCheckbox :: T.Text -> IO (Widget (CheckBox Bool)) newCheckbox label = newMultiStateCheckbox label [(False, ' '), (True, 'x')]  -- |Create a new multi-state checkbox. newMultiStateCheckbox :: (Eq a) =>-                         String -- ^The checkbox label.+                         T.Text -- ^The checkbox label.                       -> [(a, Char)] -- ^The list of valid states that                                      -- the checkbox can be in, along                                      -- with the visual representation@@ -155,6 +159,7 @@ newMultiStateCheckbox _ [] = throw EmptyCheckboxStates newMultiStateCheckbox label states = do   cchs <- newHandlers+  t <- plainText ""   let initSt = CheckBox { checkboxLabel = label                         , checkboxChangeHandlers = cchs                         , leftBracketChar = '['@@ -162,36 +167,40 @@                         , checkboxStates = states                         , currentState = fst $ states !! 0                         , checkboxFrozen = False+                        , innerTextWidget = t                         }    wRef <- newWidget initSt $ \w ->       w { getCursorPosition_ =             \this -> do               pos <- getCurrentPosition this-              return $ Just (pos `plusWidth` 1)+              ch <- leftBracketChar <~~ this+              return $ Just (pos `plusWidth` (toEnum $ fromEnum $ chWidth ch))          , keyEventHandler = radioKeyEvent         , render_ =             \this sz ctx -> do-              f <- focused <~ this               st <- getState this--              let attr = mergeAttrs [ overrideAttr ctx-                                    , normalAttr ctx-                                    ]--                  fAttr = if f-                          then focusAttr ctx-                          else attr+              tw <- innerTextWidget <~~ this -                  v = currentState st+              let v = currentState st                   ch = fromJust $ lookup v (checkboxStates st) -                  s = [leftBracketChar st, ch, rightBracketChar st, ' '] ++-                      (checkboxLabel st)+                  s = T.concat [ T.pack [ leftBracketChar st+                                        , ch+                                        , rightBracketChar st+                                        , ' '+                                        ]+                               , checkboxLabel st+                               ] -              return $ string fAttr $ take (fromEnum $ region_width sz) s+              setText tw s+              render tw sz ctx         }++  wRef `relayFocusEvents` t+  setTextAppearFocused t True+   return wRef  modifyElem :: [a] -> Int -> (a -> a) -> [a]@@ -223,7 +232,7 @@                                      }  -- |Get a checkbox's text label.-getCheckboxLabel :: Widget (CheckBox a) -> IO String+getCheckboxLabel :: Widget (CheckBox a) -> IO T.Text getCheckboxLabel = (checkboxLabel <~~)  radioKeyEvent :: (Eq a) => Widget (CheckBox a) -> Key -> [Modifier] -> IO Bool

@@ -31,6 +31,8 @@     , growHorizontal     , getCursorPosition     , showWidget+    , getVisible+    , setVisible     , (<~)     , (<~~) @@ -156,6 +158,8 @@ data WidgetImpl a = WidgetImpl {       state :: !a     -- ^The state of the widget.+    , visible :: !Bool+    -- ^Whether the widget is visible.     , render_ :: Widget a -> DisplayRegion -> RenderContext -> IO Image     -- ^The rendering routine of the widget.  Takes the widget itself,     -- a region indicating how much space the rendering process has to@@ -221,19 +225,37 @@                     , " }"                     ] +-- |Set the visibility of a widget.  Invisible widgets do not grow in+-- either direction, always render to an empty image, and never+-- declare a cursor position.+setVisible :: Widget a -> Bool -> IO ()+setVisible wRef v = updateWidget wRef $ \st -> st { visible = v }++-- |Get the visibility of a widget.+getVisible :: Widget a -> IO Bool+getVisible = (visible <~)+ -- |Does a widget grow horizontally? growHorizontal :: Widget a -> IO Bool growHorizontal w = do-  act <- growHorizontal_ <~ w-  st <- state <~ w-  act st+  v <- visible <~ w+  case v of+    True -> do+           act <- growHorizontal_ <~ w+           st <- state <~ w+           act st+    False -> return False  -- |Does a widget grow vertically? growVertical :: Widget a -> IO Bool growVertical w = do-  act <- growVertical_ <~ w-  st <- state <~ w-  act st+  v <- visible <~ w+  case v of+    True -> do+           act <- growVertical_ <~ w+           st <- state <~ w+           act st+    False -> return False  -- |Render a widget.  This function should be called by widget -- implementations, since it does more than 'render_'; this function@@ -249,23 +271,27 @@ render wRef sz ctx = do   impl <- readIORef wRef -  -- Merge the override attributes with the context.  If the overrides-  -- haven't been set (still def_attr), they will have no effect on-  -- the context attributes.-  norm <- normalAttribute <~ wRef-  foc <- focusAttribute <~ wRef-  let newCtx = ctx { normalAttr = mergeAttr norm $ normalAttr ctx-                   , focusAttr = mergeAttr foc $ focusAttr ctx-                   }+  v <- visible <~ wRef+  case v of+    False -> return empty_image+    True -> do+           -- Merge the override attributes with the context.  If the+           -- overrides haven't been set (still def_attr), they will+           -- have no effect on the context attributes.+           norm <- normalAttribute <~ wRef+           foc <- focusAttribute <~ wRef+           let newCtx = ctx { normalAttr = mergeAttr norm $ normalAttr ctx+                            , focusAttr = mergeAttr foc $ focusAttr ctx+                            } -  img <- render_ impl wRef sz newCtx-  let imgsz =  DisplayRegion (image_width img) (image_height img)+           img <- render_ impl wRef sz newCtx+           let imgsz =  DisplayRegion (image_width img) (image_height img) -  when (image_width img > region_width sz ||-        image_height img > region_height sz) $ throw $ ImageTooBig (show impl) sz imgsz+           when (image_width img > region_width sz ||+                 image_height img > region_height sz) $ throw $ ImageTooBig (show impl) sz imgsz -  setCurrentSize wRef $ DisplayRegion (image_width img) (image_height img)-  return img+           setCurrentSize wRef $ DisplayRegion (image_width img) (image_height img)+           return img  -- |Render a widget and set its position after rendering is complete. -- This is exported for internal use; widget implementations should@@ -326,6 +352,7 @@                      , currentSize = DisplayRegion 0 0                      , currentPosition = DisplayRegion 0 0                      , focused = False+                     , visible = True                      , gainFocusHandlers = gfhs                      , loseFocusHandlers = lfhs                      , keyEventHandler = \_ _ _ -> return False@@ -614,8 +641,12 @@ -- |Get the desired cursor position, if any, for a widget. getCursorPosition :: Widget a -> IO (Maybe DisplayRegion) getCursorPosition wRef = do-  ci <- getCursorPosition_ <~ wRef-  ci wRef+  v <- visible <~ wRef+  case v of+    True -> do+           ci <- getCursorPosition_ <~ wRef+           ci wRef+    False -> return Nothing  -- |Return the current focus entry of a focus group. currentEntry :: Widget FocusGroup -> IO (Widget FocusEntry)

@@ -13,6 +13,7 @@     ) where +import qualified Data.Text as T import Graphics.Vty.Widgets.Centering import Graphics.Vty.Widgets.Button import Graphics.Vty.Widgets.Padding@@ -22,7 +23,7 @@ import Graphics.Vty.Widgets.Core  data Dialog = Dialog { dialogWidget :: Widget (Bordered Padded)-                     , setDialogTitle :: String -> IO ()+                     , setDialogTitle :: T.Text -> IO ()                      , dialogAcceptHandlers :: Handlers Dialog                      , dialogCancelHandlers :: Handlers Dialog                      }@@ -33,10 +34,10 @@ -- |Create a new dialog with the specified embedded interface and -- title.  Returns the dialog itself and the 'FocusGroup' to which its -- buttons were added, for use in your application.-newDialog :: (Show a) => Widget a -> String -> IO (Dialog, Widget FocusGroup)+newDialog :: (Show a) => Widget a -> T.Text -> IO (Dialog, Widget FocusGroup) newDialog body title = do-  okB <- newButton "OK"-  cancelB <- newButton "Cancel"+  okB <- newButton $ T.pack "OK"+  cancelB <- newButton $ T.pack "Cancel"    buttonBox <- (return $ buttonWidget okB) <++> (return $ buttonWidget cancelB)   setBoxSpacing buttonBox 4

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- |This module provides a directory browser interface widget.  For -- full details, please see the Vty-ui User's Manual. module Graphics.Vty.Widgets.DirBrowser@@ -21,6 +22,7 @@ import qualified Data.Map as Map import qualified Control.Exception as E import Control.Monad+import qualified Data.Text as T import Graphics.Vty import Graphics.Vty.Widgets.Core import Graphics.Vty.Widgets.List@@ -79,11 +81,21 @@                                -- ^Used for device entries.                                , browserSockAttr :: Attr                                -- ^Used for socket entries.+                               , browserShowHeader :: Bool+                               -- ^Whether the browser header should+                               -- be shown.+                               , browserShowFooter :: Bool+                               -- ^Whether the browser footer should+                               -- be shown.                                , browserCustomAnnotations :: [ (FilePath -> FileStatus -> Bool-                                                               , FilePath -> FileStatus -> IO String+                                                               , FilePath -> FileStatus -> IO T.Text                                                                , Attr)                                                              ]                                -- ^File annotations.+                               , browserIncludeEntry :: FilePath -> FileStatus -> Bool+                               -- ^The predicate which determines+                               -- which entries get listed in the+                               -- browser.                                }  -- |The default browser skin with (hopefully) sane attribute defaults.@@ -97,12 +109,15 @@                                  , browserNamedPipeAttr = fgColor yellow                                  , browserCharDevAttr = fgColor red                                  , browserSockAttr = fgColor magenta+                                 , browserShowHeader = True+                                 , browserShowFooter = True                                  , browserCustomAnnotations = []+                                 , browserIncludeEntry = (const . const) True                                  }  -- |Apply annotations to a browser skin. withAnnotations :: BrowserSkin-                -> [(FilePath -> FileStatus -> Bool, FilePath -> FileStatus -> IO String, Attr)]+                -> [(FilePath -> FileStatus -> Bool, FilePath -> FileStatus -> IO T.Text, Attr)]                 -> BrowserSkin withAnnotations sk as = sk { browserCustomAnnotations = browserCustomAnnotations sk ++ as } @@ -111,13 +126,15 @@ newDirBrowser :: BrowserSkin -> IO (DirBrowser, Widget FocusGroup) newDirBrowser bSkin = do   path <- getCurrentDirectory-  pathWidget <- plainText ""-  errorText <- plainText "" >>= withNormalAttribute (browserErrorAttr bSkin)-  header <- ((plainText " Path: ") <++> (return pathWidget) <++> (hFill ' ' 1))+  pathWidget <- plainText T.empty+  errorText <- plainText T.empty >>= withNormalAttribute (browserErrorAttr bSkin)+  header <- ((plainText " Path: ")+             <++> (return pathWidget) <++> (hFill ' ' 1))             >>= withNormalAttribute (browserHeaderAttr bSkin) -  fileInfo <- plainText ""-  footer <- ((plainText " ") <++> (return fileInfo) <++> (hFill ' ' 1) <++> (return errorText))+  fileInfo <- plainText T.empty+  footer <- ((plainText " ")+             <++> (return fileInfo) <++> (hFill ' ' 1) <++> (return errorText))             >>= withNormalAttribute (browserHeaderAttr bSkin)    l <- newList (browserUnfocusedSelAttr bSkin)@@ -145,8 +162,11 @@    l `onKeyPressed` handleBrowserKey b   l `onSelectionChange` (\e -> clearError b >> handleSelectionChange b e)-  b `onBrowserPathChange` setText (dirBrowserPathDisplay b)+  b `onBrowserPathChange` (setText (dirBrowserPathDisplay b) . T.pack) +  setVisible header $ browserShowHeader bSkin+  setVisible footer $ browserShowFooter bSkin+   fg <- newFocusGroup   _ <- addToFocusGroup fg ui @@ -156,11 +176,14 @@ -- |Report an error in the browser's error-reporting area.  Useful for -- reporting application-specific errors with the user's file -- selection.-reportBrowserError :: DirBrowser -> String -> IO ()-reportBrowserError b msg = setText (dirBrowserErrorWidget b) $ "Error: " ++ msg+reportBrowserError :: DirBrowser -> T.Text -> IO ()+reportBrowserError b msg = setText (dirBrowserErrorWidget b) $+                           T.concat [ "Error: "+                                    , msg+                                    ]  clearError :: DirBrowser -> IO ()-clearError b = setText (dirBrowserErrorWidget b) ""+clearError b = setText (dirBrowserErrorWidget b) T.empty  -- |Register handlers to be invoked when the user makes a selection. onBrowseAccept :: DirBrowser -> (FilePath -> IO ()) -> IO ()@@ -189,21 +212,24 @@ handleSelectionChange b ev = do   case ev of     SelectionOff -> setText (dirBrowserFileInfo b) "-"-    SelectionOn _ path _ -> setText (dirBrowserFileInfo b) =<< getFileInfo b path+    SelectionOn _ path _ -> setText (dirBrowserFileInfo b) =<<+                            (getFileInfo b path) -getFileInfo :: DirBrowser -> FilePath -> IO String+getFileInfo :: DirBrowser -> FilePath -> IO T.Text getFileInfo b path = do   cur <- getDirBrowserPath b   let newPath = cur </> path   st <- getSymbolicLinkStatus newPath   (_, mkAnn) <- fileAnnotation (dirBrowserSkin b) st cur path   ann <- mkAnn-  return $ path ++ ": " ++ ann+  return $ T.concat [ T.pack (path ++ ": ")+                    , ann+                    ] -builtInAnnotations :: FilePath -> BrowserSkin -> [(FilePath -> FileStatus -> Bool, FilePath -> FileStatus -> IO String, Attr)]+builtInAnnotations :: FilePath -> BrowserSkin -> [(FilePath -> FileStatus -> Bool, FilePath -> FileStatus -> IO T.Text, Attr)] builtInAnnotations cur sk =     [ (\_ s -> isRegularFile s-      , \_ s -> return $ "regular file, " +++      , \_ s -> return $ T.pack $ "regular file, " ++                 (show $ fileSize s) ++ " bytes"       , def_attr)     , (\_ s -> isSymbolicLink s,@@ -213,7 +239,7 @@                       else do                         linkPath <- readSymbolicLink p                         canonicalizePath $ cur </> linkPath-          return $ "symbolic link to " ++ linkDest)+          return $ T.pack $ "symbolic link to " ++ linkDest)       , browserLinkAttr sk)     , (\_ s -> isDirectory s, \_ _ -> return "directory", browserDirAttr sk)     , (\_ s -> isBlockDevice s, \_ _ -> return "block device", browserBlockDevAttr sk)@@ -222,14 +248,14 @@     , (\_ s -> isSocket s, \_ _ -> return "socket", browserSockAttr sk)     ] -fileAnnotation :: BrowserSkin -> FileStatus -> FilePath -> FilePath -> IO (Attr, IO String)+fileAnnotation :: BrowserSkin -> FileStatus -> FilePath -> FilePath -> IO (Attr, IO T.Text) fileAnnotation sk st cur shortPath = do   let fullPath = cur </> shortPath        annotation = getAnnotation' fullPath st $ (browserCustomAnnotations sk) ++                    (builtInAnnotations cur sk) -      getAnnotation' _ _ [] = (def_attr, return "")+      getAnnotation' _ _ [] = (def_attr, return T.empty)       getAnnotation' pth stat ((f,mkAnn,a):rest) =           if f pth stat           then (a, mkAnn pth stat)@@ -262,7 +288,7 @@                       entries <- getDirectoryContents cPath                       return (True, entries))                      `E.catch` \e -> do-                             reportBrowserError b (ioeGetErrorString e)+                             reportBrowserError b (T.pack $ ioeGetErrorString e)                              return (False, [])    when res $ do@@ -304,11 +330,13 @@     forM_ entries $ \entry -> do       let fullPath = cur </> entry       f <- getSymbolicLinkStatus fullPath-      (attr, _) <- fileAnnotation (dirBrowserSkin b) f cur entry-      w <- plainText " " <++> plainText entry-      addToList (dirBrowserList b) entry w-      ch <- getSecondChild w-      setNormalAttribute ch attr+      when (browserIncludeEntry (dirBrowserSkin b) fullPath f) $+           do+             (attr, _) <- fileAnnotation (dirBrowserSkin b) f cur entry+             w <- plainText " " <++> plainText (T.pack entry)+             addToList (dirBrowserList b) entry w+             ch <- getSecondChild w+             setNormalAttribute ch attr  descend :: DirBrowser -> Bool -> IO () descend b shouldSelect = do

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-} -- |This module provides a text-editing widget.  Edit widgets can -- operate in single- and multi-line modes. --@@ -19,6 +19,21 @@ -- * @Del@ / @Control-d@ - delete the current character -- -- * @Backspace@ - delete the previous character+--+-- Edit widgets may be configured with a line limit which limits the+-- number of lines of text the widget will store.  It does not provide+-- any limit control on the length of its lines, though.+--+-- Edit widgets support multi-column characters.  (For some+-- information, see <http://www.unicode.org/reports/tr11/>.)  When the+-- edit widget scrolling reaches a point where a wide character cannot+-- be drawn because it is bisected by the editing window's boundary,+-- it will be replaced with an indicator (\"$\") until the scrolling+-- window is moved enough to reveal the character.  This is done to+-- preserve the relative alignment of all of the rows in the widget in+-- the presence of characters of different widths.  Note that this is+-- a visual aid only and does not affect the underlying text content+-- of the widget. module Graphics.Vty.Widgets.Edit     ( Edit     , editWidget@@ -26,47 +41,44 @@     , getEditText     , getEditCurrentLine     , setEditText-    , setEditCursorPosition     , getEditCursorPosition+    , setEditCursorPosition     , setEditLineLimit     , getEditLineLimit+    , applyEdit     , onActivate     , onChange     , onCursorMove+#ifdef TESTING+    , doClipping+    , indicatorChar+#endif     ) where  import Control.Applicative ((<$>)) import Control.Monad-import Data.List+import qualified Data.Text as T import Graphics.Vty import Graphics.Vty.Widgets.Core import Graphics.Vty.Widgets.Events import Graphics.Vty.Widgets.Util+import Graphics.Vty.Widgets.TextClip+import qualified Graphics.Vty.Widgets.TextZipper as Z -data Edit = Edit { currentText :: [String]-                 , cursorRow :: Int-                 , cursorColumn :: Int-                 , displayStart :: Int-                 , displayWidth :: Int-                 , topRow :: Int-                 , visibleRows :: Int+data Edit = Edit { contents :: Z.TextZipper T.Text+                 , clipRect :: ClipRect                  , activateHandlers :: Handlers (Widget Edit)-                 , changeHandlers :: Handlers String+                 , changeHandlers :: Handlers T.Text                  , cursorMoveHandlers :: Handlers (Int, Int)                  , lineLimit :: Maybe Int                  }  instance Show Edit where     show e = concat [ "Edit { "-                    , "currentText = ", show $ currentText e-                    , ", cursorColumn = ", show $ cursorColumn e-                    , ", cursorRow = ", show $ cursorRow e-                    , ", topRow = ", show $ topRow e+                    , "contents = ", show $ contents e                     , ", lineLimit = ", show $ lineLimit e-                    , ", visibleRows = ", show $ visibleRows e-                    , ", displayStart = ", show $ displayStart e-                    , ", displayWidth = ", show $ displayWidth e+                    , ", clipRect = ", show $ clipRect e                     , " }"                     ] @@ -76,13 +88,12 @@   chs <- newHandlers   cmhs <- newHandlers -  let initSt = Edit { currentText = [""]-                    , cursorRow = 0-                    , cursorColumn = 0-                    , displayStart = 0-                    , displayWidth = 0-                    , topRow = 0-                    , visibleRows = 1+  let initSt = Edit { contents = Z.textZipper []+                    , clipRect = ClipRect { clipLeft = 0+                                          , clipWidth = 0+                                          , clipTop = 0+                                          , clipHeight = 1+                                          }                     , activateHandlers = ahs                     , changeHandlers = chs                     , cursorMoveHandlers = cmhs@@ -97,57 +108,72 @@                 Just v | v == 1 -> return False                 _ -> return True -        , getCursorPosition_ =-            \this -> do-              f <- focused <~ this-              pos <- getCurrentPosition this-              curRow <- cursorRow <~~ this-              curCol <- cursorColumn <~~ this-              startCol <- displayStart <~~ this-              startRow <- topRow <~~ this+        , getCursorPosition_ = internalGetCursorPosition+        , render_ = renderEditWidget+        , keyEventHandler = editKeyEvent+        }+  return wRef -              if f then-                  return (Just $ pos `plusWidth` (toEnum (curCol - startCol)) `plusHeight` (toEnum (curRow - startRow))) else-                  return Nothing+internalGetCursorPosition :: Widget Edit -> IO (Maybe DisplayRegion)+internalGetCursorPosition this = do+  st <- getState this+  f <- focused <~ this+  pos <- getCurrentPosition this -        , render_ =-            \this size ctx -> do-              resize this ( fromEnum $ region_height size-                          , fromEnum $ region_width size )+  let (cursorRow, _) = Z.cursorPosition (contents st)+      Phys offset = physCursorCol st - clipLeft (clipRect st)+      newPos = pos+               `withWidth` (toEnum ((fromEnum $ region_width pos) + offset))+               `plusHeight` (toEnum (cursorRow - (fromEnum $ clipTop $ clipRect st))) -              st <- getState this+  return $ if f then Just newPos else Nothing -              let truncated l = take (displayWidth st)-                                (drop (displayStart st) l)+renderEditWidget :: Widget Edit -> DisplayRegion -> RenderContext -> IO Image+renderEditWidget this size ctx = do+  resize this ( Phys $ fromEnum $ region_height size+              , Phys $ fromEnum $ region_width size ) -                  visibleLines = take (visibleRows st) $-                                 drop (topRow st) (currentText st)-                  truncatedLines = truncated <$> visibleLines+  st <- getState this+  isFocused <- focused <~ this -                  nAttr = mergeAttrs [ overrideAttr ctx-                                     , normalAttr ctx-                                     ]+  let nAttr = mergeAttrs [ overrideAttr ctx+                         , normalAttr ctx+                         ]+      attr = if isFocused then focusAttr ctx else nAttr -                  totalAllowedLines = fromEnum $ region_height size-                  numEmptyLines = lim - length truncatedLines-                      where-                        lim = case lineLimit st of-                                Just v -> min v totalAllowedLines-                                Nothing -> totalAllowedLines+      clipped = doClipping (Z.getText $ contents st) (clipRect st) -                  emptyLines = replicate numEmptyLines ""+      totalAllowedLines = fromEnum $ region_height size+      numEmptyLines = lim - length clipped+          where+            lim = case lineLimit st of+                    Just v -> min v totalAllowedLines+                    Nothing -> totalAllowedLines -              isFocused <- focused <~ this-              let attr = if isFocused then focusAttr ctx else nAttr-                  lineWidget s = string attr s-                                 <|> char_fill attr ' ' (region_width size - (toEnum $ length s)) 1+      emptyLines = replicate numEmptyLines ""+      lineWidget s = let Phys physLineLength = sum $ chWidth <$> s+                     in string attr s <|>+                        char_fill attr ' ' (region_width size - toEnum physLineLength) 1 -              return $ vert_cat $ lineWidget <$> (truncatedLines ++ emptyLines)+  return $ vert_cat $ lineWidget <$> (clipped ++ emptyLines) -        , keyEventHandler = editKeyEvent-        }-  return wRef+doClipping :: [T.Text] -> ClipRect -> [String]+doClipping ls rect =+    let sliced True = [indicatorChar]+        sliced False = ""+        truncatedLines = clip2d rect ls +    in [ sliced lslice ++ (T.unpack r) ++ sliced rslice+         | (r, lslice, rslice) <- truncatedLines ]++-- |Convert a logical column number (corresponding to a character) to+-- a physical column number (corresponding to a terminal cell).+toPhysical :: Int -> [Char] -> Phys+toPhysical col line = sum $ chWidth <$> take col line++indicatorChar :: Char+indicatorChar = '$'+ -- |Construct a text widget for editing a single line of text. -- Single-line edit widgets will send activation events when the user -- presses @Enter@ (see 'onActivate').@@ -168,9 +194,9 @@   setEditLineLimit wRef Nothing   return wRef --- |Set the limit on the number of lines for the edit widget.  Nothing--- indicates no limit, while Just indicates a limit of the specified--- number of lines.+-- |Set the limit on the number of lines for the edit widget.+-- 'Nothing' indicates no limit, while 'Just' indicates a limit of the+-- specified number of lines. setEditLineLimit :: Widget Edit -> Maybe Int -> IO () setEditLineLimit _ (Just v) | v <= 0 = return () setEditLineLimit w v = updateWidgetState w $ \st -> st { lineLimit = v }@@ -179,11 +205,34 @@ getEditLineLimit :: Widget Edit -> IO (Maybe Int) getEditLineLimit = (lineLimit <~~) -resize :: Widget Edit -> (Int, Int) -> IO ()+resize :: Widget Edit -> (Phys, Phys) -> IO () resize e (newHeight, newWidth) = do-  updateWidgetState e $ \st -> st { visibleRows = newHeight }-  setDisplayWidth e newWidth+  updateWidgetState e $ \st ->+      let newRect = (clipRect st) { clipHeight = newHeight+                                  , clipWidth = newWidth+                                  }+          (cursorRow, _) = Z.cursorPosition $ contents st+          adjusted = updateRect (Phys cursorRow, physCursorCol st) newRect+      in st { clipRect = adjusted } +  updateWidgetState e $ \s ->+      let r = clipRect s+          (_, cursorColumn) = Z.cursorPosition $ contents s+          curLine = T.unpack $ Z.currentLine $ contents s+          (_, _, ri) = clip1d (clipLeft r) (clipWidth r) (T.pack curLine)+          newCharLen = if cursorColumn >= 0 && cursorColumn < length curLine+                       then chWidth $ curLine !! cursorColumn+                       else Phys 1++          newPhysCol = toPhysical cursorColumn curLine+          extra = if ri && newPhysCol >= ((clipLeft r) + (clipWidth r) - Phys 1)+                  then newCharLen - 1+                  else 0+          newLeft = clipLeft (clipRect s) + extra+      in s { clipRect = (clipRect s) { clipLeft = newLeft+                                     }+           }+ -- |Register handlers to be invoked when the edit widget has been -- ''activated'' (when the user presses Enter while the widget is -- focused).  These handlers will only be invoked when a single-line@@ -207,322 +256,102 @@  -- |Register handlers to be invoked when the edit widget's contents -- change.  Handlers will be passed the new contents.-onChange :: Widget Edit -> (String -> IO ()) -> IO ()+onChange :: Widget Edit -> (T.Text -> IO ()) -> IO () onChange = addHandler (changeHandlers <~~)  -- |Register handlers to be invoked when the edit widget's cursor -- position changes.  Handlers will be passed the new cursor position,--- relative to the beginning of the string (position 0).+-- relative to the beginning of the text (position (0, 0)). onCursorMove :: Widget Edit -> ((Int, Int) -> IO ()) -> IO () onCursorMove = addHandler (cursorMoveHandlers <~~)  -- |Get the current contents of the edit widget.  This returns all of -- the lines of text in the widget, separated by newlines.-getEditText :: Widget Edit -> IO String-getEditText = (((intercalate "\n") . currentText) <~~)+getEditText :: Widget Edit -> IO T.Text+getEditText = (((T.intercalate (T.pack "\n")) . Z.getText . contents) <~~)  -- |Get the contents of the current line of the edit widget (the line -- on which the cursor is positioned).-getEditCurrentLine :: Widget Edit -> IO String-getEditCurrentLine e = do-  ls <- currentText <~~ e-  curL <- cursorRow <~~ e-  return $ ls !! curL--setEditCurrentLine :: Widget Edit -> String -> IO ()-setEditCurrentLine e s = do-  ls <- currentText <~~ e-  curL <- cursorRow <~~ e--  updateWidgetState e $ \st ->-      st { currentText = repl curL s ls-         }+getEditCurrentLine :: Widget Edit -> IO T.Text+getEditCurrentLine = ((Z.currentLine . contents) <~~)  -- |Set the contents of the edit widget.  Newlines will be used to -- break up the text in multiline widgets.  If the edit widget has a -- line limit, only those lines within the limit will be set.-setEditText :: Widget Edit -> String -> IO ()+setEditText :: Widget Edit -> T.Text -> IO () setEditText wRef str = do-  oldS <- currentText <~~ wRef   lim <- lineLimit <~~ wRef-  s <- case lim of-    Nothing -> return str-    Just l -> return $ intercalate "\n" $ take l $ lines str-  updateWidgetState wRef $ \st -> st { currentText = if null s-                                                     then [""]-                                                     else lines s-                                     , cursorColumn = 0-                                     , cursorRow = 0+  let ls = case lim of+             Nothing -> T.lines str+             Just l -> take l $ T.lines str+  updateWidgetState wRef $ \st -> st { contents = Z.textZipper ls                                      }-  when (oldS /= lines s) $ do-    gotoBeginning wRef-    notifyChangeHandlers wRef+  notifyChangeHandlers wRef --- |Set the current edit widget cursor position.  The tuple is (row,--- column) with each starting at zero.  Invalid cursor positions will--- be ignored.-setEditCursorPosition :: Widget Edit -> (Int, Int) -> IO ()-setEditCursorPosition wRef (newRow, newCol) = do-  ls <- currentText <~~ wRef+-- |Get the edit widget's current cursor position (row, column).+getEditCursorPosition :: Widget Edit -> IO (Int, Int)+getEditCursorPosition = ((Z.cursorPosition . contents) <~~) -  -- First, check that the row is valid-  case newRow >= 0 && newRow < (length ls) of-    False -> return ()-    True -> do-      -- Then, if the row is valid, is the column valid for that row?-      -- It's legal for the new position to be *after* the last-      -- character (i.e., in the case of go-to-end)-      case newCol >= 0 && newCol <= (length (ls !! newRow)) of-        False -> return ()-        True -> do-              (oldRow, oldCol) <- getEditCursorPosition wRef-              when ((newRow, newCol) /= (oldRow, oldCol)) $-                   do-                     st <- getState wRef+-- |Set the cursor position to the specified row and column.  Invalid+-- cursor positions will be ignored.+setEditCursorPosition :: (Int, Int) -> Widget Edit -> IO ()+setEditCursorPosition pos = applyEdit (Z.moveCursor pos) -                     let newDisplayStart = if newCol >= (displayStart st + displayWidth st)-                                           then newCol - displayWidth st + 1-                                           else if newCol < displayStart st-                                                then newCol-                                                else displayStart st-                         newTopRow = if newRow < topRow st-                                     then newRow-                                     else if newRow >= (topRow st + visibleRows st)-                                          then newRow - visibleRows st + 1-                                          else topRow st+-- |Compute the physical cursor position (column) for the cursor in a+-- given edit widget state.  The physical position is relative to the+-- beginning of the current line (i.e., zero, as opposed to the+-- displayStart and related state).+physCursorCol :: Edit -> Phys+physCursorCol s =+    let curLine = T.unpack $ Z.currentLine $ contents s+        (_, cursorColumn) = Z.cursorPosition $ contents s+    in toPhysical cursorColumn curLine -                     updateWidgetState wRef $ \s ->-                         s { displayStart = newDisplayStart-                           , topRow = newTopRow-                           }+-- |Apply an editing transformation to the edit widget's text.  If the+-- transformation modifies the text or the cursor, the appropriate+-- event handlers will be notified.  If a line limit is in effect and+-- the transformation violates it, the transformation will be ignored.+applyEdit :: (Z.TextZipper T.Text -> Z.TextZipper T.Text)+          -> Widget Edit+          -> IO ()+applyEdit f this = do+  oldC <- contents <~~ this+  updateWidgetState this $ \s ->+      let newSt = s { contents = f (contents s) }+      in case lineLimit s of+           Nothing -> newSt+           Just l -> if length (Z.getText $ contents newSt) > l+                     then s+                     else newSt -                     updateWidgetState wRef $ \s ->-                         s { cursorRow = newRow-                           , cursorColumn = newCol-                           }-                     notifyCursorMoveHandlers wRef+  newC <- contents <~~ this --- |Get the edit widget's current cursor position (row, column).-getEditCursorPosition :: Widget Edit -> IO (Int, Int)-getEditCursorPosition e = do-  r <- cursorRow <~~ e-  c <- cursorColumn <~~ e-  return (r, c)+  when (Z.getText oldC /= Z.getText newC) $+       notifyChangeHandlers this -setDisplayWidth :: Widget Edit -> Int -> IO ()-setDisplayWidth this width =-    updateWidgetState this $ \s ->-        let newDispStart = if cursorColumn s - displayStart s >= width-                           then cursorColumn s - width + 1-                           else displayStart s-        in s { displayWidth = width-             , displayStart = newDispStart-             }+  when (Z.cursorPosition oldC /= Z.cursorPosition newC) $+       notifyCursorMoveHandlers this  editKeyEvent :: Widget Edit -> Key -> [Modifier] -> IO Bool editKeyEvent this k mods = do+  let run f = applyEdit f this >> return True   case (k, mods) of-    (KASCII 'a', [MCtrl]) -> gotoBeginning this >> return True-    (KASCII 'k', [MCtrl]) -> killToEOL this >> return True-    (KASCII 'e', [MCtrl]) -> gotoEnd this >> return True-    (KASCII 'd', [MCtrl]) -> delCurrentChar this >> return True-    (KLeft, []) -> moveCursorLeft this >> return True-    (KRight, []) -> moveCursorRight this >> return True-    (KUp, []) -> moveCursorUp this >> return True-    (KDown, []) -> moveCursorDown this >> return True-    (KBS, []) -> deletePreviousChar this >> return True-    (KDel, []) -> delCurrentChar this >> return True-    (KASCII ch, []) -> insertChar this ch >> return True-    (KHome, []) -> gotoBeginning this >> return True-    (KEnd, []) -> gotoEnd this >> return True+    (KASCII 'a', [MCtrl]) -> run Z.gotoBOL+    (KASCII 'k', [MCtrl]) -> run Z.killToEOL+    (KASCII 'e', [MCtrl]) -> run Z.gotoEOL+    (KASCII 'd', [MCtrl]) -> run Z.deleteChar+    (KLeft, []) -> run Z.moveLeft+    (KRight, []) -> run Z.moveRight+    (KUp, []) -> run Z.moveUp+    (KDown, []) -> run Z.moveDown+    (KBS, []) -> run Z.deletePrevChar+    (KDel, []) -> run Z.deleteChar+    (KASCII ch, []) -> run (Z.insertChar ch)+    (KHome, []) -> run Z.gotoBOL+    (KEnd, []) -> run Z.gotoEOL     (KEnter, []) -> do                    lim <- lineLimit <~~ this                    case lim of                      Just 1 -> notifyActivateHandlers this >> return True-                     _ -> insertLineAtPoint this >> return True+                     _ -> run Z.breakLine     _ -> return False--insertLineAtPoint :: Widget Edit -> IO ()-insertLineAtPoint e = do-  -- Bail if adding a new line would violate the line limit-  lim <- lineLimit <~~ e-  numLines <- (length . currentText) <~~ e--  let continue = case lim of-                   Just v | numLines + 1 > v -> False-                   _ -> True--  when continue $-       do-         -- Get information about current line so we can break the-         -- current line-         curL <- getEditCurrentLine e-         curCol <- cursorColumn <~~ e-         curRow <- cursorRow <~~ e-         let r1 = take curCol curL-             r2 = drop curCol curL-         setEditCurrentLine e r1-         updateWidgetState e $ \st ->-             st { currentText = inject (curRow + 1) r2 (currentText st)-                }-         notifyChangeHandlers e-         setEditCursorPosition e (curRow + 1, 0)--killToEOL :: Widget Edit -> IO ()-killToEOL this = do-  -- Preserve some state since setEditText changes it.-  curCol <- cursorColumn <~~ this-  curLine <- getEditCurrentLine this-  case null curLine of-    False -> do-      setEditCurrentLine this $ take curCol curLine-      notifyChangeHandlers this-    True -> do-      curRow <- cursorRow <~~ this-      numLines <- (length . currentText) <~~ this-      if curRow == 0 && numLines == 1 then-          return () else-          do-            let newRow = if curRow == numLines - 1 && numLines > 1-                         then curRow - 1-                         else curRow-            updateWidgetState this $ \st ->-                st { currentText = remove curRow (currentText st)-                   }-            notifyChangeHandlers this-            setEditCursorPosition this (newRow, 0)--deletePreviousChar :: Widget Edit -> IO ()-deletePreviousChar this = do-  curCol <- cursorColumn <~~ this-  curRow <- cursorRow <~~ this-  case curCol == 0 of-    True ->-        if curRow == 0-        then return ()-        else do-          curLine <- getEditCurrentLine this-          ls <- currentText <~~ this-          let prevLine = ls !! (curRow - 1)-          updateWidgetState this $ \st ->-              st { currentText = repl (curRow - 1) (prevLine ++ curLine)-                                 $ remove curRow (currentText st)-                 }-          setEditCursorPosition this (curRow - 1, length prevLine)-          notifyChangeHandlers this--    False -> do-      moveCursorLeft this-      delCurrentChar this--gotoBeginning :: Widget Edit -> IO ()-gotoBeginning wRef = do-  updateWidgetState wRef $ \s -> s { displayStart = 0-                                   }-  curL <- cursorRow <~~ wRef-  setEditCursorPosition wRef (curL, 0)--gotoEnd :: Widget Edit -> IO ()-gotoEnd wRef = do-  curLine <- getEditCurrentLine wRef-  curRow <- cursorRow <~~ wRef-  setEditCursorPosition wRef (curRow, length curLine)--moveCursorUp :: Widget Edit -> IO ()-moveCursorUp wRef = do-  st <- getState wRef-  let newRow = if cursorRow st == 0-               then 0-               else cursorRow st - 1--      prevLine = currentText st !! (cursorRow st - 1)-      newCol = if cursorRow st == 0 || (cursorColumn st <= length prevLine)-               then cursorColumn st-               else length prevLine--  setEditCursorPosition wRef (newRow, newCol)--moveCursorDown :: Widget Edit -> IO ()-moveCursorDown wRef = do-  st <- getState wRef-  let newRow = if cursorRow st == (length $ currentText st) - 1-               then (length $ currentText st) - 1-               else cursorRow st + 1--      nextLine = currentText st !! (cursorRow st + 1)-      newCol = if cursorRow st == (length $ currentText st) - 1-               then cursorColumn st-               else if cursorColumn st <= length nextLine-                    then cursorColumn st-                    else length nextLine--  setEditCursorPosition wRef (newRow, newCol)--moveCursorLeft :: Widget Edit -> IO ()-moveCursorLeft wRef = do-  st <- getState wRef-  let newRow = if cursorRow st == 0-               then 0-               else if cursorColumn st == 0-                    then cursorRow st - 1-                    else cursorRow st-      prevLine = currentText st !! (cursorRow st - 1)-      newCol = if cursorColumn st == 0-               then if cursorRow st == 0-                    then 0-                    else length prevLine-               else cursorColumn st - 1-  setEditCursorPosition wRef (newRow, newCol)--moveCursorRight :: Widget Edit -> IO ()-moveCursorRight wRef = do-  st <- getState wRef-  curL <- getEditCurrentLine wRef-  let newRow = if cursorRow st == (length $ currentText st) - 1-               then cursorRow st-               else if cursorColumn st == length curL-                    then cursorRow st + 1-                    else cursorRow st-      newCol = if cursorColumn st == length curL-               then if cursorRow st == (length $ currentText st) - 1-                    then cursorColumn st-                    else 0-               else cursorColumn st + 1-  setEditCursorPosition wRef (newRow, newCol)--insertChar :: Widget Edit -> Char -> IO ()-insertChar wRef ch = do-  curLine <- getEditCurrentLine wRef-  updateWidgetState wRef $ \st ->-      let newLine = inject (cursorColumn st) ch curLine-          newViewStart =-              if cursorColumn st == displayStart st + displayWidth st - 1-              then displayStart st + 1-              else displayStart st-      in st { displayStart = newViewStart-            , currentText = repl (cursorRow st) newLine (currentText st)-            }-  moveCursorRight wRef-  notifyChangeHandlers wRef--delCurrentChar :: Widget Edit -> IO ()-delCurrentChar wRef = do-  st <- getState wRef-  curLine <- getEditCurrentLine wRef-  case cursorColumn st < (length curLine) of-    True ->-        do-          let newLine = remove (cursorColumn st) curLine-          updateWidgetState wRef $ \s -> s { currentText = repl (cursorRow st) newLine (currentText st) }-          notifyChangeHandlers wRef-    False ->-        -- If we are on the last line, do nothing, but if we aren't,-        -- combine the next line with the current one-        if cursorRow st == (length $ currentText st) - 1-        then return ()-        else do-          let nextLine = currentText st !! (cursorRow st + 1)-          updateWidgetState wRef $ \s ->-              s { currentText = remove (cursorRow s + 1) $-                                repl (cursorRow st) (curLine ++ nextLine) (currentText s)-                }

@@ -14,7 +14,7 @@     , SelectionEvent(..)     , ActivateItemEvent(..)     -- ** List creation-    , newStringList+    , newTextList     , newList     , addToList     , insertIntoList@@ -42,6 +42,7 @@ import Data.Typeable import Control.Exception hiding (Handler) import Control.Monad+import qualified Data.Text as T import qualified Data.Vector as V import Graphics.Vty import Graphics.Vty.Widgets.Core@@ -419,13 +420,13 @@    return $ vert_cat (visible_imgs ++ [filler]) --- |A convenience function to create a new list using 'String's as the--- internal values and 'FormattedText' widgets to represent those+-- |A convenience function to create a new list using 'Text' values as+-- the internal values and 'FormattedText' widgets to represent those -- strings.-newStringList :: Attr -- ^The attribute of the selected item-              -> [String] -- ^The list items-              -> IO (Widget (List String FormattedText))-newStringList selAttr labels = do+newTextList :: Attr -- ^The attribute of the selected item+            -> [T.Text] -- ^The list items+            -> IO (Widget (List T.Text FormattedText))+newTextList selAttr labels = do   list <- newList selAttr   forM_ labels $ \l ->       (addToList list l =<< plainText l)

@@ -15,16 +15,23 @@ where  import Control.Monad+import qualified Data.Text as T import Graphics.Vty import Graphics.Vty.Widgets.Core import Graphics.Vty.Widgets.Events import Graphics.Vty.Widgets.Text import Graphics.Vty.Widgets.Alignment+import Graphics.Vty.Widgets.Util+import Graphics.Vty.Widgets.TextClip+import Text.Trans.Tokenize  data ProgressBar = ProgressBar { progressBarAmount :: Int                                , onChangeHandlers :: Handlers Int-                               , progressBarText :: String+                               , progressBarText :: T.Text                                , progressBarTextAlignment :: Alignment+                               , progCompleteAttr :: Attr+                               , progIncompleteAttr :: Attr+                               , progTextWidget :: Widget FormattedText                                }  instance Show ProgressBar where@@ -39,49 +46,72 @@ newProgressBar :: Attr -> Attr -> IO (Widget ProgressBar) newProgressBar completeAttr incompleteAttr = do   chs <- newHandlers-  t <- plainText ""-  let initSt = ProgressBar 0 chs "" AlignCenter+  t <- plainText T.empty+  let initSt = ProgressBar 0 chs T.empty AlignCenter completeAttr incompleteAttr t   wRef <- newWidget initSt $ \w ->           w { growHorizontal_ = const $ return True             , render_ =-                \this size ctx -> do-                  -- Divide the available width according to the-                  -- progress value-                  prog <- progressBarAmount <~~ this-                  txt <- progressBarText <~~ this-                  al <- progressBarTextAlignment <~~ this+                \this size ctx -> renderProgressBar size ctx =<< getState this+            } -                  let complete_width = fromEnum $ (toRational prog / toRational (100.0 :: Double)) *-                                       (toRational $ fromEnum $ region_width size)+  setProgress wRef 0+  return wRef -                      full_width = fromEnum $ region_width size-                      full_str = take full_width $ mkStr txt al+renderProgressBar :: DisplayRegion -> RenderContext -> ProgressBar -> IO Image+renderProgressBar size ctx st = do+  -- Divide the available width according to the progress value+  let prog = progressBarAmount st+      txt = progressBarText st+      al = progressBarTextAlignment st -                      mkStr s AlignLeft = s ++ replicate (full_width - length txt) ' '-                      mkStr s AlignRight = replicate (full_width - length txt) ' ' ++ s-                      mkStr s AlignCenter = concat [ half-                                                   , s-                                                   , half-                                                   , if length half * 2 < (full_width + length txt)-                                                     then " "-                                                     else ""-                                                   ]-                          where-                            half = replicate ((full_width - length txt) `div` 2) ' '+      complete_width =+          Phys $ fromEnum $ (toRational prog / toRational (100.0 :: Double)) *+                   (toRational $ fromEnum $ region_width size) -                      (complete_str, incomplete_str) = ( take complete_width full_str-                                                       , drop complete_width full_str-                                                       )+      full_width = Phys $ fromEnum $ region_width size+      full_str = truncateText full_width $ mkStr txt al -                  setTextWithAttrs t [ (complete_str, completeAttr)-                                     , (incomplete_str, incompleteAttr)-                                     ]-                  render t size ctx-            }+      mkStr s AlignLeft =+          let diff = fromEnum $ full_width - textWidth txt+          in T.concat [ s+                      , T.pack $ replicate diff ' '+                      ] -  setProgress wRef 0-  return wRef+      mkStr s AlignRight =+          let diff = fromEnum $ full_width - textWidth txt+          in T.concat [ T.pack $ replicate diff ' '+                      , s+                      ] +      mkStr s AlignCenter =+          T.concat [ half+                   , s+                   , half+                   , trailingSpc+                   ]+          where+            diff = fromEnum $ full_width - textWidth txt+            half = T.pack $ replicate (diff `div` 2) ' '+            used_width = textWidth half * 2 + textWidth txt+            trailingSpc =+                if used_width < full_width+                then T.singleton ' '+                else T.empty+++      (leftPart, _, _) = clip1d 0 complete_width full_str+      charCount = T.length leftPart++      (complete_str, incomplete_str) = ( T.take charCount full_str+                                       , T.drop charCount full_str+                                       )++  setTextWithAttrs (progTextWidget st)+                       [ (complete_str, progCompleteAttr st)+                       , (incomplete_str, progIncompleteAttr st)+                       ]+  render (progTextWidget st) size ctx+ -- |Register a handler to be invoked when the progress bar's progress -- value changes.  The handler will be passed the new progress value. onProgressChange :: Widget ProgressBar -> (Int -> IO ()) -> IO ()@@ -101,7 +131,7 @@     updateWidgetState p $ \st -> st { progressBarTextAlignment = al }  -- |Set the progress bar's text label.-setProgressText :: Widget ProgressBar -> String -> IO ()+setProgressText :: Widget ProgressBar -> T.Text -> IO () setProgressText p s =     updateWidgetState p $ \st -> st { progressBarText = s } 

@@ -26,6 +26,7 @@ where  import Data.Monoid+import qualified Data.Text as T import Data.Typeable import Data.Word import Data.List@@ -207,8 +208,7 @@  -- |Create a table widget using a list of column specifications and a -- border style.-newTable :: -            [ColumnSpec]+newTable :: [ColumnSpec]          -> BorderStyle          -> IO (Widget Table) newTable specs borderSty = do@@ -454,7 +454,7 @@ -- |Add a heading row to a table.  Adds a row using the specified -- |labels and attribute.  Returns the widgets it constructed as a -- |side-effect in case you want to do something with them.-addHeadingRow :: Widget Table -> Attr -> [String] -> IO [Widget FormattedText]+addHeadingRow :: Widget Table -> Attr -> [T.Text] -> IO [Widget FormattedText] addHeadingRow tbl attr labels = do   ws <- mapM (\s -> plainText s >>= withNormalAttribute attr) labels   addRow tbl ws@@ -462,7 +462,7 @@  -- |Add a heading row to a table.  Adds a row using the specified -- |labels and attribute.-addHeadingRow_ :: Widget Table -> Attr -> [String] -> IO ()+addHeadingRow_ :: Widget Table -> Attr -> [T.Text] -> IO () addHeadingRow_ tbl attr labels = addHeadingRow tbl attr labels >> return ()  applyCellAlignment :: Alignment -> TableCell -> IO TableCell@@ -523,7 +523,7 @@  renderCell :: DisplayRegion -> TableCell -> RenderContext -> IO Image renderCell region EmptyCell ctx = do-  w <- plainText ""+  w <- plainText T.empty   render w region ctx renderCell region (TableCell w _ _) ctx =     render w region ctx

@@ -1,9 +1,8 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns #-}--- |This module provides functionality for rendering 'String's as+-- |This module provides functionality for rendering 'Text' as -- 'Widget's, including functionality to make structural and/or visual--- changes at rendering time.  To get started, turn your ordinary--- 'String' into a 'Widget' with 'plainText'; for more control, use--- 'textWidget'.+-- changes at rendering time.  To get started, use 'plainText'; for+-- more control, use 'textWidget'. module Graphics.Vty.Widgets.Text     ( FormattedText     -- *Constructing Text Widgets@@ -26,6 +25,7 @@  import Control.Applicative import Data.Monoid+import qualified Data.Text as T import Graphics.Vty import Graphics.Vty.Widgets.Core import Text.Trans.Tokenize@@ -66,16 +66,16 @@                                         , " }"                                         ] --- |Construct a Widget directly from a String.  This is recommended if--- you don't need to use a 'Formatter'.-plainText :: String -> IO (Widget FormattedText)+-- |Construct a Widget directly from a Text value.  This is+-- recommended if you don't need to use a 'Formatter'.+plainText :: T.Text -> IO (Widget FormattedText) plainText = textWidget nullFormatter  -- |Construct a Widget directly from a list of strings and their -- attributes.-plainTextWithAttrs :: [(String, Attr)] -> IO (Widget FormattedText)+plainTextWithAttrs :: [(T.Text, Attr)] -> IO (Widget FormattedText) plainTextWithAttrs pairs = do-  w <- textWidget nullFormatter ""+  w <- textWidget nullFormatter T.empty   setTextWithAttrs w pairs   return w @@ -86,13 +86,13 @@ wrap :: Formatter wrap =     Formatter $ \sz ts -> do-      let width = fromEnum $ region_width sz+      let width = Phys $ fromEnum $ region_width sz       return $ wrapStream width ts  -- |Construct a text widget formatted with the specified formatters -- and initial content.  The formatters will be applied in the order -- given here (and, depending on the formatter, order might matter).-textWidget :: Formatter -> String -> IO (Widget FormattedText)+textWidget :: Formatter -> T.Text -> IO (Widget FormattedText) textWidget format s = do   let initSt = FormattedText { text = TS []                              , formatter = format@@ -130,7 +130,7 @@  -- |Set the text value of a 'FormattedText' widget.  The specified -- string will be 'tokenize'd.-setText :: Widget FormattedText -> String -> IO ()+setText :: Widget FormattedText -> T.Text -> IO () setText wRef s = setTextWithAttrs wRef [(s, def_attr)]  -- |Set the text value of a 'FormattedText' widget directly, in case@@ -138,7 +138,7 @@ -- attributes.  The specified strings will each be 'tokenize'd, and -- tokens resulting from each 'tokenize' operation will be given the -- specified attribute in the tuple.-setTextWithAttrs :: Widget FormattedText -> [(String, Attr)] -> IO ()+setTextWithAttrs :: Widget FormattedText -> [(T.Text, Attr)] -> IO () setTextWithAttrs wRef pairs = do   let streams = map (\(s, a) -> tokenize s a) pairs       ts = concat $ map streamEntities streams@@ -172,7 +172,7 @@       emptyLineLength = min (fromEnum $ region_width sz) maxLineLength        ls = map truncLine $ map (map entityToken) $ findLines newText-      truncLine = truncateLine (fromEnum $ region_width sz)+      truncLine = truncateLine (Phys $ fromEnum $ region_width sz)        -- When building images for empty lines, it's critical that we       -- *don't* use the empty_image, because that will cause empty@@ -188,7 +188,7 @@       nullImg = string def_attr ""        mkTokenImg :: Token Attr -> Image-      mkTokenImg tok = string (finalAttr tok) (tokenStr tok)+      mkTokenImg tok = string (finalAttr tok) (T.unpack $ tokenStr tok)    return $ if region_height sz == 0            then nullImg

@@ -0,0 +1,116 @@+-- |This module provides \"text clipping\" routines.  These routines+-- are responsible for ensuring that logical characters are clipped+-- properly when being laid out in a given physical region.  This is a+-- bit tricky because some Unicode characters use two terminal columns+-- and others (most) use one.  We have to take this into account when+-- truncating text to fit into rendering regions, so we concentrate+-- that logic here under the name of a \"clipping rectangle\" and+-- functions to apply it.+--+-- Clipping functionality is provided in two forms: one- and+-- two-dimensional clipping.  The former is useful for clipping a+-- single line of text at a given offset and up to a given width.  The+-- latter is useful for clipping a list of lines with respect to a 2-D+-- clipping rectangle.+module Graphics.Vty.Widgets.TextClip+    ( ClipRect(..)+    , clip1d+    , clip2d+    , updateRect+    )+where++import Control.Applicative+import Data.Maybe+import qualified Data.Text as T+import Graphics.Vty.Widgets.Util+    ( Phys(..)+    , chWidth+    )++-- |The type of clipping rectangles for 2-D clipping operations.  All+-- values are 'Phys' values to indicate that we are dealing explicitly+-- with physical column measurements rather than logical character+-- positions.+data ClipRect =+    ClipRect { clipLeft :: Phys+             -- ^The left margin of the clipping rectangle.+             , clipTop :: Phys+             -- ^The top row of the clipping rectangle.+             , clipWidth :: Phys+             -- ^The width, in columns, of the clipping rectangle.+             , clipHeight :: Phys+             -- ^The height, in rows, of the clipping rectangle.+             }+    deriving (Eq, Show)++-- |One-dimensional text clipping.  Takes the left clipping margin, a+-- clipping width, and a text string.  For example, @clip1d n w s@+-- clips the string @s@ so that the result includes characters in @s@+-- starting at position @n@ and including characters using no more+-- than @w@ columns in width.  Returns the clipped text plus 'Bool's+-- indicating whether wide characters were \"sliced\" on either side+-- (left and right, respectively) of the clipping region.  This+-- function guarantees that the text returned will always fit within+-- the specified clipping region.  Since wide characters may be sliced+-- during clipping, this may return a text string smaller than the+-- clipping region.+clip1d :: Phys -> Phys -> T.Text -> (T.Text, Bool, Bool)+clip1d _ 0 _ = (T.empty, False, False)+clip1d start len t = (T.pack result2, lSlice, rSlice)++    where+      pairs = [ (c, chWidth c) | c <- T.unpack t ]++      exploded = concat $ mkExp <$> pairs+      mkExp (a, i) = Just a : replicate (fromEnum i - 1) Nothing++      -- First clip up to the starting position.+      clip1 = drop (fromEnum start) exploded+      -- Then clip according to the width.+      clip2 = take (fromEnum len) clip1+      -- Rest is whatever was left after clipping to the width.+      rest = drop (fromEnum len) clip1++      rSlice = length rest > 0 && head rest == Nothing+      lSlice = length clip1 > 0 && head clip1 == Nothing++      result1 = catMaybes clip2+      result2 = if rSlice+                then init result1+                else result1++-- |Two-dimensional text clipping.  Returns clipping data for each+-- line as returned by 'clip1d', with the added behavior that it+-- returns at most 'clipHeight' lines of text and uses 'clipTop' as+-- the offset when clipping rows.+clip2d :: ClipRect -> [T.Text] -> [(T.Text, Bool, Bool)]+clip2d rect ls = clip1d left len <$> visibleLines+        where+          visibleLines = take (fromEnum height) $ drop (fromEnum top) ls+          left = clipLeft rect+          top = clipTop rect+          len = clipWidth rect+          height = clipHeight rect++-- |Given a physical point and a clipping rectangle, adjust the+-- clipping rectangle so that the point falls just inside the+-- rectangle.  If the point is already within the rectangle, return+-- the rectangle unmodified.  NB: this assumes that the physical+-- position given has passed whatever validation checks are relevant+-- for the user of the 'ClipRect'.  This function just performs a+-- rectangle transformation.+updateRect :: (Phys, Phys) -> ClipRect -> ClipRect+updateRect (row, col) oldRect = adjustLeft $ adjustTop oldRect+    where+      adjustLeft old+          | col < clipLeft oldRect = old { clipLeft = col }+          | col >= clipLeft oldRect + clipWidth oldRect =+              old { clipLeft = col - clipWidth old + 1 }+          | otherwise = old++      adjustTop old+          | row < clipTop oldRect = old { clipTop = row }+          | row >= clipTop oldRect + clipHeight oldRect =+              old { clipTop = row - clipHeight old + 1 }+          | otherwise = old

@@ -0,0 +1,297 @@+-- |This module provides a two-dimensional text zipper data structure.+-- This structure represents a body of text and an editing cursor+-- which can be moved throughout the text, along with a set of editing+-- transformations.+--+-- Text zippers are generalized over the set of data types that might+-- be used to store lists of characters (e.g., 'String', 'T.Text',+-- etc.).  As a result, the most general way to create a text zipper+-- is to use 'mkZipper' and provide all of the functions required to+-- manipulate the underlying text data.+--+-- A default implementation using 'T.Text' is provided and is used+-- elsewhere in this library.+module Graphics.Vty.Widgets.TextZipper+    ( TextZipper++    -- *Construction and extraction+    , mkZipper+    , textZipper+    , getText+    , currentLine+    , cursorPosition++    -- *Navigation functions+    , moveCursor+    , insertChar+    , breakLine+    , killToEOL+    , gotoEOL+    , gotoBOL+    , deletePrevChar+    , deleteChar+    , moveRight+    , moveLeft+    , moveUp+    , moveDown+    )+where++import Data.Monoid+import qualified Data.Text as T++data TextZipper a =+    TZ { toLeft :: a+       , toRight :: a+       , above :: [a]+       , below :: [a]+       , fromChar :: Char -> a+       , drop_ :: Int -> a -> a+       , take_ :: Int -> a -> a+       , length_ :: a -> Int+       , last_ :: a -> Char+       , init_ :: a -> a+       , null_ :: a -> Bool+       }++instance (Eq a) => Eq (TextZipper a) where+    a == b = and [ toLeft a == toLeft b+                 , toRight a == toRight b+                 , above a == above b+                 , below a == below b+                 ]++instance (Show a) => Show (TextZipper a) where+    show tz = concat [ "TextZipper { "+                     , "above = "+                     , show $ above tz+                     , "below = "+                     , show $ below tz+                     , "toLeft = "+                     , show $ toLeft tz+                     , "toRight = "+                     , show $ toRight tz+                     , " }"+                     ]++-- |Create a zipper using a custom text storage type.  Takes the+-- initial text as well as all of the functions necessary to+-- manipulate the underlying text values.+mkZipper :: (Monoid a) =>+            (Char -> a)+         -- ^A singleton constructor.+         -> (Int -> a -> a)+         -- ^'drop'.+         -> (Int -> a -> a)+         -- ^'take'.+         -> (a -> Int)+         -- ^'length'.+         -> (a -> Char)+         -- ^'last'.+         -> (a -> a)+         -- ^'init'.+         -> (a -> Bool)+         -- ^'null'.+         -> [a]+         -- ^The initial lines of text.+         -> TextZipper a+mkZipper fromCh drp tk lngth lst int nl ls =+    let (first, rest) = if null ls+                        then (mempty, mempty)+                        else (head ls, tail ls)+    in TZ mempty first [] rest fromCh drp tk lngth lst int nl++-- |Get the text contents of the zipper.+getText :: (Monoid a) => TextZipper a -> [a]+getText tz = concat [ above tz+                    , [currentLine tz]+                    , below tz+                    ]++-- |Get the cursor position of the zipper; returns @(row, col)@.+-- @row@ ranges from @[0..num_rows-1]@ inclusive; @col@ ranges from+-- @[0..length of current line]@ inclusive.  Column values equal to+-- line width indicate a cursor that is just past the end of a line of+-- text.+cursorPosition :: TextZipper a -> (Int, Int)+cursorPosition tz = (length $ above tz, length_ tz $ toLeft tz)++-- |Move the cursor to the specified row and column.  Invalid cursor+-- positions will be ignored.  Valid cursor positions range as+-- described for 'cursorPosition'.+moveCursor :: (Monoid a) => (Int, Int) -> TextZipper a -> TextZipper a+moveCursor (row, col) tz =+    let t = getText tz+    in if row < 0+           || row > length t+           || col < 0+           || col > length_ tz (t !! row)+       then tz+       else tz { above = take row t+               , below = drop (row + 1) t+               , toLeft = take_ tz col (t !! row)+               , toRight = drop_ tz col (t !! row)+               }++lastLine :: TextZipper a -> Bool+lastLine = (== 0) . length . below++nextLine :: TextZipper a -> a+nextLine = head . below++-- |The line of text on which the zipper's cursor currently resides.+currentLine :: (Monoid a) => TextZipper a -> a+currentLine tz = (toLeft tz) `mappend` (toRight tz)++-- |Insert a character at the current cursor position.  Move the+-- cursor one position to the right.+insertChar :: (Monoid a) => Char -> TextZipper a -> TextZipper a+insertChar ch tz = tz { toLeft = toLeft tz `mappend` (fromChar tz ch) }++-- |Insert a line break at the current cursor position.+breakLine :: (Monoid a) => TextZipper a -> TextZipper a+breakLine tz =+    tz { above = above tz ++ [toLeft tz]+       , toLeft = mempty+       }++-- |Move the cursor to the end of the current line.+gotoEOL :: (Monoid a) => TextZipper a -> TextZipper a+gotoEOL tz = tz { toLeft = currentLine tz+                , toRight = mempty+                }++-- |Remove all text from the cursor position to the end of the current+-- line.  If the cursor is at the beginning of a line and the line is+-- empty, the entire line will be removed.+killToEOL :: (Monoid a) => TextZipper a -> TextZipper a+killToEOL tz+    | (null_ tz $ toLeft tz) && (null_ tz $ toRight tz) &&+      (not $ null $ below tz) =+          tz { toRight = head $ below tz+             , below = tail $ below tz+             }+    | otherwise = tz { toRight = mempty+                     }++-- |Delete the character preceding the cursor position, and move the+-- cursor backwards by one character.+deletePrevChar :: (Eq a, Monoid a) => TextZipper a -> TextZipper a+deletePrevChar tz+    | moveLeft tz == tz = tz+    | otherwise = deleteChar $ moveLeft tz++-- |Delete the character at the cursor position.  Leaves the cursor+-- position unchanged.  If the cursor is at the end of a line of text,+-- this combines the line with the line below.+deleteChar :: (Monoid a) => TextZipper a -> TextZipper a+deleteChar tz+    -- Can we just remove a char from the current line?+    | (not $ null_ tz (toRight tz)) =+        tz { toRight = drop_ tz 1 $ toRight tz+           }+    -- Do we need to collapse the previous line onto the current one?+    | null_ tz (toRight tz) && (not $ null $ below tz) =+        tz { toRight = head $ below tz+           , below = tail $ below tz+           }+    | otherwise = tz++-- |Move the cursor to the beginning of the current line.+gotoBOL :: (Monoid a) => TextZipper a -> TextZipper a+gotoBOL tz = tz { toLeft = mempty+                , toRight = currentLine tz+                }++-- |Move the cursor right by one position.  If the cursor is at the+-- end of a line, the cursor is moved to the first position of the+-- following line (if any).+moveRight :: (Monoid a) => TextZipper a -> TextZipper a+moveRight tz+    -- Are we able to keep moving right on the current line?+    | not (null_ tz (toRight tz)) =+        tz { toLeft = toLeft tz+                      `mappend` (take_ tz 1 $ toRight tz)+           , toRight = drop_ tz 1 (toRight tz)+           }+    -- If we are going to go beyond the end of the current line, can+    -- we move to the next one?+    | not $ null (below tz) =+        tz { above = above tz ++ [toLeft tz]+           , below = tail $ below tz+           , toLeft = mempty+           , toRight = nextLine tz+           }+    | otherwise = tz++-- |Move the cursor left by one position.  If the cursor is at the+-- beginning of a line, the cursor is moved to the last position of+-- the preceding line (if any).+moveLeft :: (Monoid a) => TextZipper a -> TextZipper a+moveLeft tz+    -- Are we able to keep moving left on the current line?+    | not $ null_ tz (toLeft tz) =+        tz { toLeft = init_ tz $ toLeft tz+           , toRight = fromChar tz (last_ tz (toLeft tz))+                       `mappend` toRight tz+           }+    -- If we are going to go beyond the beginning of the current line,+    -- can we move to the end of the previous one?+    | not $ null (above tz) =+        tz { above = init $ above tz+           , below = currentLine tz : below tz+           , toLeft = last $ above tz+           , toRight = mempty+           }+    | otherwise = tz++-- |Move the cursor up by one row.  If there no are rows above the+-- current one, move to the first position of the current row.  If the+-- row above is shorter, move to the end of that row.+moveUp :: (Monoid a) => TextZipper a -> TextZipper a+moveUp tz+    -- Is there a line above at least as long as the current one?+    | (not $ null (above tz)) &&+      (length_ tz $ last $ above tz) >= length_ tz (toLeft tz) =+        tz { below = currentLine tz : below tz+           , above = init $ above tz+           , toLeft = take_ tz (length_ tz $ toLeft tz) (last $ above tz)+           , toRight = drop_ tz (length_ tz $ toLeft tz) (last $ above tz)+           }+    -- Or if there is a line above, just go to the end of it+    | (not $ null (above tz)) =+        tz { above = init $ above tz+           , below = currentLine tz : below tz+           , toLeft = last $ above tz+           , toRight = mempty+           }+    -- If nothing else, go to the beginning of the current line+    | otherwise = gotoBOL tz++-- |Move the cursor down by one row.  If there are no rows below the+-- current one, move to the last position of the current row.  If the+-- row below is shorter, move to the end of that row.+moveDown :: (Monoid a) => TextZipper a -> TextZipper a+moveDown tz+    -- Is there a line below at least as long as the current one?+    | (not $ lastLine tz) &&+      (length_ tz $ nextLine tz) >= length_ tz (toLeft tz) =+        tz { below = tail $ below tz+           , above = above tz ++ [currentLine tz]+           , toLeft = take_ tz (length_ tz $ toLeft tz) (nextLine tz)+           , toRight = drop_ tz (length_ tz $ toLeft tz) (nextLine tz)+           }+    -- Or if there is a line below, just go to the end of it+    | (not $ null (below tz)) =+        tz { above = above tz ++ [currentLine tz]+           , below = tail $ below tz+           , toLeft = nextLine tz+           , toRight = mempty+           }+    -- If nothing else, go to the end of the current line+    | otherwise = gotoEOL tz++-- |Construct a zipper from 'T.Text' values.+textZipper :: [T.Text] -> TextZipper T.Text+textZipper =+    mkZipper T.singleton T.drop T.take T.length T.last T.init T.null

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-} module Graphics.Vty.Widgets.Util     ( on     , fgColor@@ -13,11 +13,50 @@     , remove     , inject     , repl+    , takeMaxText+    , takeMaxChars+    , chWidth+    , strWidth+    , textWidth+    , Phys(..)     ) where +import Control.Applicative import Data.Word+import qualified Data.Text as T import Graphics.Vty+import Graphics.Vty.Image+    ( safe_wcwidth+    )++-- A newtype to wrap physical screen coordinates, as opposed to+-- character-logical coordinates.  Used when transforming cursor+-- coordinates to screen coordinates and when computing the physical+-- width of characters and strings.+newtype Phys = Phys Int+    deriving (Num, Eq, Show, Ord, Integral, Enum, Real)++chWidth :: Char -> Phys+chWidth = Phys . fromEnum . safe_wcwidth++textWidth :: T.Text -> Phys+textWidth = strWidth . T.unpack++strWidth :: String -> Phys+strWidth = sum . (chWidth <$>)++takeMaxChars :: Phys -> [Char] -> [Char]+takeMaxChars mx xs = f' (Phys 0) xs+    where+      f' _ [] = []+      f' acc (c:cs) = let w = chWidth c+                      in if acc + w <= mx+                         then c : f' (acc + w) cs+                         else []++takeMaxText :: Phys -> T.Text -> T.Text+takeMaxText mx xs = T.pack $ takeMaxChars mx $ T.unpack xs  -- |Infix attribute constructor.  Use: foregroundColor `on` -- backgroundColor.

@@ -1,134 +0,0 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}-module Main where--import System.Exit ( exitSuccess )-import Graphics.Vty-import Graphics.Vty.Widgets.All--data AppElements =-    AppElements { theList :: Widget (List String FormattedText)-                , theBody :: Widget FormattedText-                , theFooter :: Widget FormattedText-                , theListLimit :: Widget (VLimit (List String FormattedText))-                , uis :: Collection-                }--titleAttr = bright_white `on` blue-focAttr = black `on` green-bodyAttr = white `on` black-selAttr = black `on` yellow-keyAttr = fgColor magenta--message1 :: String-message1 = "This demonstration shows how list widgets behave. \n\-           \See the keystrokes below to try the demo."--message2 :: [(String, Attr)]-message2 = [ ("- Press ", def_attr), ("q", keyAttr), (" to quit\n", def_attr)-           , ("- Press ", def_attr), ("+", keyAttr)-           , (" / ", def_attr), ("a", keyAttr)-           , (" to add a list item\n", def_attr)-           , ("- Press ", def_attr), ("-", keyAttr)-           , (" / ", def_attr), ("d", keyAttr)-           , (" to remove the selected list item\n", def_attr)-           , ("- Press ", def_attr)-           , ("up", keyAttr), (" / ", def_attr)-           , ("down", keyAttr), (" / ", def_attr)-           , ("page up", keyAttr), (" / ", def_attr)-           , ("page down", keyAttr)-           , (" to navigate the list\n", def_attr)-           ]--buildUi appst = do-  msg1 <- plainText message1-  setTextFormatter msg1 wrap--  msg2 <- plainTextWithAttrs message2-  setTextFormatter msg2 wrap--  mainUi <- (hBorder >>= withBorderAttribute titleAttr)-         <--> (return $ theList appst)-         <--> ((return $ theFooter appst)-               <++> (hBorder >>= withBorderAttribute titleAttr))--  centered =<< hLimit 55 =<<-             ((return msg1)-                  <--> ((vLimit 25 mainUi >>= bordered)-                        <--> return msg2 >>= withBoxSpacing 1)-                    >>= withBoxSpacing 1)---- Construct the application statea using the message map.-mkAppElements :: IO AppElements-mkAppElements = do-  lw <- newStringList selAttr []-  b <- textWidget wrap ""-  ft <- plainText "" >>= withNormalAttribute titleAttr-  ll <- vLimit 5 lw--  c <- newCollection--  return $ AppElements { theList = lw-                       , theBody = b-                       , theFooter = ft-                       , theListLimit = ll-                       , uis = c-                       }--updateBody :: AppElements -> Int -> IO ()-updateBody st i = do-  let msg = "This is the text for list entry " ++ (show $ i + 1)-  setText (theBody st) msg--updateFooterNums :: AppElements -> Widget (List a b) -> IO ()-updateFooterNums st w = do-  result <- getSelected w-  sz <- getListSize w-  let msg = case result of-              Nothing -> "0/0"-              Just (i, _) -> (show $ i + 1) ++ "/" ++ (show sz)-  setText (theFooter st) msg--main :: IO ()-main = do-  st <- mkAppElements--  ui <- buildUi st-  fg <- newFocusGroup--  _ <- addToCollection (uis st) ui fg-  _ <- addToFocusGroup fg (theList st)--  (theList st) `onSelectionChange` \_ -> updateFooterNums st $ theList st-  (theList st) `onItemAdded` \_ -> updateFooterNums st $ theList st-  (theList st) `onItemRemoved` \_ -> updateFooterNums st $ theList st--  let removeCurrentItem = do-         result <- getSelected (theList st)-         case result of-           Nothing -> return ()-           Just (i, _) -> removeFromList (theList st) i >> return ()-      addNewItem = do-         addToList (theList st) "unused" =<< plainText "a list item"--  (theList st) `onKeyPressed` \_ k _ -> do-         case k of-           (KASCII 'q') -> exitSuccess-           (KASCII '-') -> removeCurrentItem >> return True-           (KASCII 'd') -> removeCurrentItem >> return True-           (KASCII '+') -> addNewItem >> return True-           (KASCII 'a') -> addNewItem >> return True-           _ -> return False--  -- We need to call these handlers manually because while they will-  -- be called automatically as items are added to the list in the-  -- future, the items currently in the list didn't call these because-  -- they weren't registered at the time the items were added.  And-  -- that was impossible because the list was created and populated-  -- before we even got a reference to it, so we couldn't have set up-  -- event handlers.-  updateFooterNums st (theList st)--  -- Enter the event loop.-  runUi (uis st) $ defaultContext { normalAttr = bodyAttr-                                  , focusAttr = focAttr-                                  }

@@ -1,78 +0,0 @@-module Main where---- This demo is discussed in the vty-ui user's manual.--import Control.Monad--import Graphics.Vty hiding (pad)-import Graphics.Vty.Widgets.All--data PhoneNumber = PhoneNumber String String String-                   deriving (Show)---- This type isn't pretty, but we have to specify the type of the--- complete interface.  Initially you can let the compiler tell you--- what it is.-type T = Box (Box-              (Box (Box (HFixed Edit) FormattedText) (HFixed Edit))-              FormattedText) (HFixed Edit)--data PhoneInput =-   PhoneInput { phoneInputWidget :: Widget T-              , edit1 :: Widget Edit-              , edit2 :: Widget Edit-              , edit3 :: Widget Edit-              , activateHandlers :: Handlers PhoneNumber-              }--newPhoneInput :: IO (PhoneInput, Widget FocusGroup)-newPhoneInput = do-   ahs <- newHandlers-   e1 <- editWidget-   e2 <- editWidget-   e3 <- editWidget-   ui <- (hFixed 4 e1) <++>-         (plainText "-") <++>-         (hFixed 4 e2) <++>-         (plainText "-") <++>-         (hFixed 5 e3)--   let w = PhoneInput ui e1 e2 e3 ahs-       doFireEvent = const $ do-         num <- mkPhoneNumber-         fireEvent w (return . activateHandlers) num--       mkPhoneNumber = do-         s1 <- getEditText e1-         s2 <- getEditText e2-         s3 <- getEditText e3-         return $ PhoneNumber s1 s2 s3--   e1 `onActivate` doFireEvent-   e2 `onActivate` doFireEvent-   e3 `onActivate` doFireEvent--   e1 `onChange` \s -> when (length s == 3) $ focus e2-   e2 `onChange` \s -> when (length s == 3) $ focus e3--   fg <- newFocusGroup-   mapM_ (addToFocusGroup fg) [e1, e2, e3]-   return (w, fg)--onPhoneInputActivate :: PhoneInput-                     -> (PhoneNumber -> IO ()) -> IO ()-onPhoneInputActivate input handler =-    addHandler (return . activateHandlers) input handler--main :: IO ()-main = do-  (p, fg) <- newPhoneInput-  p `onPhoneInputActivate` (error . show)--  ui <- padded (phoneInputWidget p) (padLeftRight 5 `pad` padTopBottom 2)--  c <- newCollection-  _ <- addToCollection c ui fg--  runUi c $ defaultContext { focusAttr = white `on` blue-                           }

@@ -1,56 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-missing-signatures #-}-module Main where--import Control.Concurrent (forkIO, threadDelay)-import Control.Monad (forever)--import System.Exit ( exitSuccess )-import Graphics.Vty-import Graphics.Vty.Widgets.All---- Visual attributes.-focAttr = black `on` green-bodyAttr = bright_green `on` black-completeAttr = white `on` red-incompleteAttr = red `on` white--setupProgessBar :: IO (Widget ProgressBar)-setupProgessBar = do-  pb <- newProgressBar completeAttr incompleteAttr-  setProgressTextAlignment pb AlignCenter--  pb `onProgressChange` \val ->-      setProgressText pb $ "Progress (" ++ show val ++ " %)"--  return pb--setupProgressBarThread :: Widget ProgressBar -> IO ()-setupProgressBarThread pb = do-  forkIO $ forever $ do-    let act i = do-          threadDelay $ 1 * 1000 * 1000-          schedule $ setProgress pb (i `mod` 101)-          act $ i + 4-    act 0-  return ()--setupDialog :: (Show a) => Widget a -> IO (Dialog, Widget FocusGroup)-setupDialog ui = do-  (dlg, fg) <- newDialog ui "Progress Bar Demo"-  dlg `onDialogAccept` const exitSuccess-  dlg `onDialogCancel` const exitSuccess-  return (dlg, fg)--main :: IO ()-main = do-  pb <- setupProgessBar-  setupProgressBarThread pb--  (dlg, dlgFg) <- setupDialog pb--  c <- newCollection-  _ <- addToCollection c (dialogWidget dlg) dlgFg--  runUi c $ defaultContext { normalAttr = bodyAttr-                           , focusAttr = focAttr-                           }

@@ -19,6 +19,7 @@      -- * Manipulation     , truncateLine+    , truncateText     , wrapStream     , findLines #ifdef TESTING@@ -28,22 +29,25 @@     ) where +import Control.Applicative import Data.List     ( inits     )+import qualified Data.Text as T+import Graphics.Vty.Widgets.Util  -- |The type of text tokens.  These should consist of printable -- characters and NOT presentation characters (e.g., newlines).  Each -- type of token should have as its contents a string of characters -- all of the same type.  Tokens are generalized over an attribute -- type which can be used to annotate each token.-data Token a = S { tokenStr :: !String+data Token a = S { tokenStr :: !T.Text                  -- ^The token's string.                  , tokenAttr :: !a                  -- ^The token's attribute.                  }              -- ^Non-whitespace tokens.-             | WS { tokenStr :: !String+             | WS { tokenStr :: !T.Text                   -- ^The token's string.                   , tokenAttr :: !a                   -- ^The token's attribute.@@ -90,8 +94,8 @@  -- |Get the length of a token's string. tokenLen :: Token a -> Int-tokenLen (S s _) = length s-tokenLen (WS s _) = length s+tokenLen (S s _) = T.length s+tokenLen (WS s _) = T.length s  wsChars :: [Char] wsChars = [' ', '\t']@@ -121,32 +125,41 @@  -- |Given a text stream, serialize the stream to its original textual -- representation.  This discards token attribute metadata.-serialize :: TextStream a -> String-serialize (TS es) = concat $ map serializeEntity es+serialize :: TextStream a -> T.Text+serialize (TS es) = T.concat $ serializeEntity <$> es     where-      serializeEntity NL = "\n"+      serializeEntity NL = T.pack "\n"       serializeEntity (T (WS s _)) = s       serializeEntity (T (S s _)) = s  -- |Tokenize a string and apply a default attribute to every token in -- the resulting text stream.-tokenize :: String -> a -> TextStream a+tokenize :: T.Text -> a -> TextStream a tokenize s def = TS $ findEntities s     where-      findEntities [] = []-      findEntities str@(c:_) = nextEntity : findEntities (drop nextLen str)+      findEntities str+          | T.null str = []+          | otherwise = nextEntity : findEntities (T.drop nextLen str)           where+            c = T.head str             (nextEntity, nextLen) = if isWs c-                                    then (T (WS nextWs def), length nextWs)+                                    then (T (WS nextWs def), T.length nextWs)                                     else if c == '\n'                                          then (NL, 1)-                                         else (T (S nextStr def), length nextStr)-            nextWs = takeWhile isWs str-            nextStr = takeWhile (\ch -> not $ ch `elem` ('\n':wsChars)) str+                                         else (T (S nextStr def), T.length nextStr)+            nextWs = T.takeWhile isWs str+            nextStr = T.takeWhile (\ch -> not $ ch `elem` ('\n':wsChars)) str +-- |Same as 'truncateLine' but for 'Text' values.+truncateText :: Phys -> T.Text -> T.Text+truncateText width t =+    let TS ts = tokenize t ()+        tokens = entityToken <$> ts+    in T.concat $ tokenStr <$> truncateLine width tokens+ -- |Given a list of tokens, truncate the list so that its underlying -- string representation does not exceed the specified column width.-truncateLine :: Int -> [Token a] -> [Token a]+truncateLine :: Phys -> [Token a] -> [Token a] truncateLine l _ | l < 0 = error $ "truncateLine cannot truncate at length = " ++ show l truncateLine _ [] = [] truncateLine width ts =@@ -158,14 +171,14 @@     -- If there are no passing cases (i.e., remaining is null), just     -- return 'width' characters of the first token.     if null remaining-    then [first_tok { tokenStr = take width $ tokenStr first_tok }]+    then [first_tok { tokenStr = takeMaxText width $ tokenStr first_tok }]     else if length tokens == length ts          then tokens-         else if null $ tokenStr lastToken+         else if T.null $ tokenStr lastToken               then tokens               else tokens ++ [lastToken]     where-      lengths = map (length . tokenStr) ts+      lengths = map (sum . (chWidth <$>) . T.unpack . tokenStr) ts       cases = reverse $ inits lengths       remaining = dropWhile ((> width) . sum) cases       tokens = take (length $ head remaining) ts@@ -173,28 +186,32 @@        first_tok = ts !! 0       last_tok = ts !! (length tokens)-      lastToken = last_tok { tokenStr = take (width - truncLength) $ tokenStr last_tok }+      lastToken = last_tok { tokenStr = takeMaxText (width - truncLength) $+                                        tokenStr last_tok+                           }  -- |Given a text stream and a wrapping width, return a new -- 'TextStream' with newlines inserted in appropriate places to wrap--- the text at the specified column.  This function results in text--- wrapped without leading or trailing whitespace on wrapped lines,--- although it preserves leading whitespace in the text which was not--- the cause of the wrapping transformation.-wrapStream :: (Eq a) => Int -> TextStream a -> TextStream a+-- the text at the specified column (not character position).+--+-- This function results in text wrapped without leading or trailing+-- whitespace on wrapped lines, although it preserves leading+-- whitespace in the text which was not the cause of the wrapping+-- transformation.+wrapStream :: (Eq a) => Phys -> TextStream a -> TextStream a wrapStream width (TS stream) = TS $ reverse $ dropWhile (== NL) $ reverse $ wrapAll' 0 stream     where-      wrapAll' :: Int -> [TextStreamEntity a] -> [TextStreamEntity a]+      wrapAll' :: Phys -> [TextStreamEntity a] -> [TextStreamEntity a]       wrapAll' _ [] = []       wrapAll' _ (NL:rest) = NL : wrapAll' 0 rest       wrapAll' accum (T t:rest) =-          if (length $ tokenStr t) + accum > width+          if (textWidth $ tokenStr t) + accum > width           then if isWhitespace t                then [NL] ++ wrapAll' 0 (dropWhile isWsEnt rest)-               else if accum == 0 && ((length $ tokenStr t) >= width)-                    then [T t, NL] ++ wrapAll' 0 (dropWhile isWsEnt rest)-                    else [NL, T t] ++ wrapAll' (length $ tokenStr t) rest-          else T t : wrapAll' (accum + (length $ tokenStr t)) rest+               else if accum == 0 && ((textWidth $ tokenStr t) >= width)+                    then [T t] ++ wrapAll' (textWidth $ tokenStr t) (dropWhile isWsEnt rest)+                    else [NL, T t] ++ wrapAll' (textWidth $ tokenStr t) rest+          else T t : wrapAll' (accum + (textWidth $ tokenStr t)) rest  partitions :: (a -> Bool) -> [a] -> [[a]] partitions _ [] = []

@@ -7,10 +7,16 @@  import qualified Tests.FormattedText as FormattedText import qualified Tests.Tokenize as Tokenize+import qualified Tests.Edit as Edit+import qualified Tests.TextClip as TextClip+import qualified Tests.TextZipper as TextZipper  tests :: [Property] tests = concat [ FormattedText.tests                , Tokenize.tests+               , Edit.tests+               , TextClip.tests+               , TextZipper.tests                ]  main :: IO ()

@@ -0,0 +1,46 @@+module Tests.Edit where++import Control.Applicative+import Data.Char ( isPrint )+import Test.QuickCheck+import Tests.Instances ()+import qualified Data.Text as T++import Graphics.Vty.Widgets.Edit+import Graphics.Vty.Widgets.Util+import Graphics.Vty.Widgets.TextClip++stringGen :: Gen String+stringGen = listOf1 charGen++textGen :: Gen T.Text+textGen = T.pack <$> (listOf $ oneof [ pure 'a'+                                     , pure ' '+                                     , pure '台'+                                     ])++charGen :: Gen Char+charGen = oneof [ arbitrary `suchThat` (\c -> isPrint c)+                , pure '台'+                ]++doClippingTest :: Property+doClippingTest =+    property $ forAll textGen $ \t ->+        forAll (choose (Phys 0, textWidth t + Phys 10)) $ \leftCrop ->+        forAll (choose (Phys 0, textWidth t + Phys 10)) $ \resWidth ->+            let rect = ClipRect { clipLeft = leftCrop+                                , clipWidth = resWidth+                                , clipTop = 0+                                , clipHeight = 1+                                }+                [(_, ls, rs)] = clip2d rect [t]+                [res] = doClipping [t] rect+            in strWidth res == 0+                   || and [ not ls || (ls && head res == indicatorChar)+                          , not rs || (rs && last res == indicatorChar)+                          ]++tests :: [Property]+tests = [ label "doClipping clips and adds indicators" doClippingTest+        ]

@@ -4,6 +4,7 @@ import Test.QuickCheck.Monadic  import Control.Applicative+import qualified Data.Text as T  import Graphics.Vty import Graphics.Vty.Widgets.Text@@ -42,11 +43,12 @@         img3 <- run $ render w2 sz defaultContext         return $ img1 == img3 && img1 /= img2 -textString :: Gen String-textString = listOf $ oneof [ pure 'a'-                            , pure '\n'-                            , pure ' '-                            ]+textString :: Gen T.Text+textString = T.pack <$> (listOf $ oneof [ pure 'a'+                                        , pure '\n'+                                        , pure ' '+                                        , pure '台'+                                        ])  tests :: [Property] tests = [ label "text: newlines rendered correctly" textHeight

@@ -2,9 +2,11 @@ module Tests.Instances where  import Test.QuickCheck+import System.Random import Control.Applicative ( (<*>), (<$>), pure )  import Graphics.Vty+import Graphics.Vty.Widgets.Util  instance (Show a, Arbitrary a, Eq a) => Arbitrary (MaybeDefault a) where     arbitrary = oneof [ pure Default@@ -24,3 +26,15 @@     arbitrary = DisplayRegion <$> coord <*> coord         where           coord = sized $ \n -> fromIntegral <$> choose (0, n)++instance Random Phys where+    random g =+        let (val, g') = random g+        in (Phys val, g')++    randomR (Phys a, Phys b) g =+        let (val, g') = randomR (a, b) g+        in (Phys val, g')++instance Arbitrary Phys where+    arbitrary = Phys <$> arbitrary

@@ -0,0 +1,60 @@+module Tests.TextClip+    ( tests+    )+where++import Control.Applicative+import Test.QuickCheck++import Tests.Instances ()+import qualified Data.Text as T+import Graphics.Vty.Widgets.TextClip+import Graphics.Vty.Widgets.Util++rectGen :: Gen ClipRect+rectGen = ClipRect+          <$> (arbitrary `suchThat` (>= Phys 0))+          <*> (arbitrary `suchThat` (>= Phys 0))+          <*> (arbitrary `suchThat` (>= Phys 0))+          <*> (arbitrary `suchThat` (>= Phys 0))++textGen :: Gen T.Text+textGen = T.pack <$> (listOf $ oneof [ pure 'a'+                                     , pure ' '+                                     , pure '台'+                                     ])++docGen :: Gen [T.Text]+docGen = listOf1 textGen++clip1dWidth :: Property+clip1dWidth =+    forAll rectGen $ \rect ->+        forAll textGen $ \t ->+            let (r, _, _) = clip1d (clipLeft rect) (clipWidth rect) t+            in textWidth r <= clipWidth rect++clipSliceLeft :: Bool+clipSliceLeft =+    let (_, ls, _) = clip1d (Phys 1) (Phys 2) $ T.pack "台台"+    in ls++clipSliceRight :: Bool+clipSliceRight =+    let (_, _, rs) = clip1d (Phys 1) (Phys 2) $ T.pack "台台"+    in rs++clip2dBounds :: Property+clip2dBounds =+    forAll rectGen $ \rect ->+        forAll docGen $ \t ->+            let result = clip2d rect t+                check (r, _, _) = textWidth r <= clipWidth rect+            in all check result && (Phys $ length result) <= clipHeight rect++tests :: [Property]+tests = [ label "clip1d guarantees width bound" clip1dWidth+        , label "clip1d indicates left slices" $ property clipSliceLeft+        , label "clip1d indicates right slices" $ property clipSliceRight+        , label "clip2d guarantees width and height bounds" clip2dBounds+        ]

@@ -0,0 +1,43 @@+module Tests.TextZipper+    ( tests+    )+where++import Control.Applicative+import Test.QuickCheck++import Tests.Instances ()+import qualified Data.Text as T+import Graphics.Vty.Widgets.TextZipper++textGen :: Gen T.Text+textGen = T.pack <$> (listOf $ oneof [ pure 'a'+                                     , pure ' '+                                     ])++docGen :: Gen [T.Text]+docGen = listOf1 textGen++validCursorPositions :: [T.Text] -> Gen (Int, Int)+validCursorPositions ts = do+  r <- elements [0..length ts - 1]+  c <- elements [0..T.length (ts !! r)]+  return (r, c)++cursorCheck :: Property+cursorCheck =+    forAll docGen $ \doc ->+        forAll (validCursorPositions doc) $ \pos ->+            pos == cursorPosition (moveCursor pos $ textZipper doc)++insertDelCheck :: Property+insertDelCheck =+    forAll docGen $ \doc ->+        forAll (validCursorPositions doc) $ \pos ->+            let orig = moveCursor pos $ textZipper doc+            in orig == (deletePrevChar $ insertChar 'X' orig)++tests :: [Property]+tests = [ label "get/set cursor position are consistent" cursorCheck+        , label "insert/delete are inverses" insertDelCheck+        ]

@@ -1,40 +1,52 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings #-} module Tests.Tokenize where +import Control.Applicative import Data.Char ( isPrint ) import Test.QuickCheck-+import Tests.Util import Text.Trans.Tokenize+import Graphics.Vty.Widgets.Util+import qualified Data.Text as T  lineGen :: Gen [Token ()] lineGen = listOf1 $ oneof [wsgen, strgen]     where       strgen = do         s <- stringGen-        return $ S s ()+        return $ S (T.pack s) ()        wsgen = do         s <- listOf1 $ elements " \t"-        return $ WS s ()+        return $ WS (T.pack s) ()  stringGen :: Gen String stringGen = listOf1 charGen +textGen :: Gen T.Text+textGen = T.pack <$> stringGen+ charGen :: Gen Char-charGen = arbitrary `suchThat` (\c -> isPrint c)+charGen = oneof [ arbitrary `suchThat` (\c -> isPrint c)+                , pure '台'+                ]  tests :: [Property]-tests = [ label "tokenize and serialize work" $ property $ forAll stringGen $+tests = [ label "tokenize and serialize work" $+                property $ forAll textGen $                     \s -> (serialize $ tokenize s ()) == s -        , label "truncateLine leaves short lines unchanged" $ property $ forAll lineGen $-                    \ts -> ts == truncateLine (length $ serialize (TS (map T ts))) ts+        , label "truncateLine leaves short lines unchanged" $+                property $ forAll lineGen $+                    \ts -> ts == truncateLine (lineLength ts) ts          -- Bound the truncation width at twice the size of the input         -- since huge cases are silly.-        , label "truncateLine truncates long lines" $ property $ forAll lineGen $-                    \ts -> forAll (choose (0, 2 * (length $ serialize (TS (map T ts))))) $-                           \width -> length (serialize $ (TS (map T $ truncateLine width ts))) <= width+        , label "truncateLine truncates long lines" $+                property $ forAll lineGen $+                    \ts -> forAll (choose (0, 2 * (lineLength ts))) $+                           \width -> (lineLength $ truncateLine width ts) <= width          , label "wrapStream does the right thing with whitespace" $ property $                 and [ wrapStream 5 (TS [T (S "foo" ()), T (WS " " ()), T (S "bar" ())]) ==@@ -90,8 +102,9 @@         -- be broken up.         , label "wrapLine wraps long lines when possible" $                 property $ forAll lineGen $-                    \ts -> forAll (choose ((length $ tokenStr $ ts !! 0), (length $ serialize (TS $ map T ts)) - 1)) $-                           \width -> let ls = findLines new-                                         TS new = wrapStream width $ TS $ map T ts-                                     in all (\l -> (length (serialize $ TS l)) <= width || (length l == 1)) ls+                    \ts -> forAll (choose ((textWidth $ tokenStr $ ts !! 0), (lineLength ts - Phys 1))) $+                           \width -> let TS new = wrapStream width $ TS $ T <$> ts+                                         ls = findLines new+                                         check l = (lineLength $ entityToken <$> l) <= width || (length l == 1)+                                     in all check ls         ]

@@ -1,7 +1,11 @@ module Tests.Util where +import Control.Applicative+import qualified Data.Text as T import Graphics.Vty import Graphics.Vty.Widgets.Core+import Graphics.Vty.Widgets.Util+import Text.Trans.Tokenize import Test.QuickCheck import Test.QuickCheck.Monadic import Tests.Instances ()@@ -14,8 +18,8 @@ count _ [] = 0 count f (a:as) = count f as + if f a then 1 else 0 -numNewlines :: String -> Int-numNewlines = count (== '\n')+numNewlines :: T.Text -> Int+numNewlines = count (== '\n') . T.unpack  sizeTest :: (Show a) => IO (Widget a) -> PropertyM IO Bool sizeTest mkWidget =@@ -26,3 +30,6 @@           return $ image_height img == 0 && image_width img == 0 else           return $ image_width img <= region_width sz &&                  image_height img <= region_height sz++lineLength :: [Token a] -> Phys+lineLength = sum . (textWidth <$>) . (tokenStr <$>)

@@ -1,5 +1,5 @@ Name:                vty-ui-Version:             1.5.1+Version:             1.6 Synopsis:   An interactive terminal user interface library for Vty @@ -23,7 +23,7 @@ Build-Type:          Simple License:             BSD3 License-File:        LICENSE-Cabal-Version:       >= 1.6+Cabal-Version:       >= 1.8 Homepage:            http://jtdaugherty.github.com/vty-ui/  Data-Files:@@ -65,6 +65,9 @@     doc/ch4/Padded.tex     doc/ch4/ProgressBar.tex     doc/ch4/Table.tex+    doc/ch5/main.tex+    doc/ch5/TextClip.tex+    doc/ch5/TextZipper.tex     doc/macros.tex     doc/Makefile     doc/vty-ui-users-manual.tex@@ -75,8 +78,8 @@   type:     git   location: git://github.com/jtdaugherty/vty-ui.git -Flag testing-    Description:     Build for testing+Flag no-tests+    Description:     Skip build of testing executable     Default:         False  Flag demos@@ -86,15 +89,16 @@ Library   Build-Depends:     base >= 4 && < 5,-    vty >= 4.6 && < 4.8,-    containers >= 0.2 && < 0.5,+    vty >= 4.7.0.18,+    containers >= 0.2 && < 0.6,     regex-base >= 0.93 && < 0.94,-    directory >= 1.0 && < 1.2,+    directory >= 1.0 && < 1.3,     filepath >= 1.1 && < 1.4,-    unix >= 2.4 && < 2.6,-    mtl >= 2.0 && < 2.1,-    stm >= 2.1 && < 2.3,+    unix >= 2.4 && < 2.7,+    mtl >= 2.0 && < 2.2,+    stm >= 2.1 && < 2.5,     array >= 0.3.0.0 && < 0.5.0.0,+    text >= 0.11,     vector >= 0.9    GHC-Options:       -Wall@@ -104,6 +108,8 @@           Graphics.Vty.Widgets.All           Graphics.Vty.Widgets.Alignment           Graphics.Vty.Widgets.Text+          Graphics.Vty.Widgets.TextClip+          Graphics.Vty.Widgets.TextZipper           Graphics.Vty.Widgets.Core           Graphics.Vty.Widgets.Box           Graphics.Vty.Widgets.List@@ -129,115 +135,119 @@  Executable vty-ui-tests   Build-Depends:-    QuickCheck >= 2.4 && < 2.5+    base >= 4 && < 5,+    QuickCheck >= 2.4 && < 2.6,+    random >= 1.0,+    text,+    vty,+    vty-ui    CPP-Options: -DTESTING   GHC-Options: -Wall -  if !flag(testing)+  if flag(no-tests)     Buildable:     False   end   Hs-Source-Dirs:  src,test,test/src   Main-is:         TestDriver.hs-  if os(darwin)-    Extra-Lib-Dirs:  /usr/lib    Other-Modules:         Tests.Instances         Tests.Util+        Tests.Edit         Tests.FormattedText         Tests.Tokenize+        Tests.TextClip+        Tests.TextZipper  Executable vty-ui-list-demo-  Hs-Source-Dirs:  src+  Hs-Source-Dirs:  demos   GHC-Options:     -Wall   Main-is:         ListDemo.hs-  if os(darwin)-    Extra-Lib-Dirs:  /usr/lib   Build-Depends:     base >= 4 && < 5,-    mtl >= 2.0 && < 2.1,-    vty >= 4.6 && < 4.8+    mtl >= 2.0 && < 2.2,+    vty >= 4.7.0.18,+    text,+    vty-ui   if !flag(demos)     Buildable: False  Executable vty-ui-progressbar-demo-  Hs-Source-Dirs:  src+  Hs-Source-Dirs:  demos   GHC-Options:     -Wall   Main-is:         ProgressBarDemo.hs-  if os(darwin)-    Extra-Lib-Dirs:  /usr/lib   Build-Depends:     base >= 4 && < 5,-    mtl >= 2.0 && < 2.1,-    vty >= 4.6 && < 4.8+    mtl >= 2.0 && < 2.2,+    vty >= 4.7.0.18,+    text,+    vty-ui   if !flag(demos)     Buildable: False  Executable vty-ui-complex-demo-  Hs-Source-Dirs:  src+  Hs-Source-Dirs:  demos   GHC-Options:     -Wall   Main-is:         ComplexDemo.hs-  if os(darwin)-    Extra-Lib-Dirs:  /usr/lib   Build-Depends:     base >= 4 && < 5,-    mtl >= 2.0 && < 2.1,+    mtl >= 2.0 && < 2.2,     bytestring >= 0.9 && < 1.0,     time >= 1.1 && < 1.5,     old-locale >= 1.0 && < 1.1,-    vty >= 4.6 && < 4.8+    vty >= 4.7.0.18,+    text,+    vty-ui   if !flag(demos)     Buildable: False  Executable vty-ui-dirbrowser-demo-  Hs-Source-Dirs:  src+  Hs-Source-Dirs:  demos   GHC-Options:     -Wall   Main-is:         DirBrowserDemo.hs-  if os(darwin)-    Extra-Lib-Dirs:  /usr/lib   Build-Depends:     base >= 4 && < 5,-    mtl >= 2.0 && < 2.1,-    vty >= 4.6 && < 4.8+    mtl >= 2.0 && < 2.2,+    vty >= 4.7.0.18,+    vty-ui   if !flag(demos)     Buildable: False  Executable vty-ui-phoneinput-demo-  Hs-Source-Dirs:  src+  Hs-Source-Dirs:  demos   GHC-Options:     -Wall   Main-is:         PhoneInputDemo.hs-  if os(darwin)-    Extra-Lib-Dirs:  /usr/lib   Build-Depends:     base >= 4 && < 5,-    mtl >= 2.0 && < 2.1,-    vty >= 4.6 && < 4.8+    mtl >= 2.0 && < 2.2,+    vty >= 4.7.0.18,+    text,+    vty-ui   if !flag(demos)     Buildable: False  Executable vty-ui-dialog-demo-  Hs-Source-Dirs:  src+  Hs-Source-Dirs:  demos   GHC-Options:     -Wall   Main-is:         DialogDemo.hs-  if os(darwin)-    Extra-Lib-Dirs:  /usr/lib   Build-Depends:     base >= 4 && < 5,-    mtl >= 2.0 && < 2.1,-    vty >= 4.6 && < 4.8+    mtl >= 2.0 && < 2.2,+    vty >= 4.7.0.18,+    text,+    vty-ui   if !flag(demos)     Buildable: False  Executable vty-ui-edit-demo-  Hs-Source-Dirs:  src+  Hs-Source-Dirs:  demos   GHC-Options:     -Wall   Main-is:         EditDemo.hs-  if os(darwin)-    Extra-Lib-Dirs:  /usr/lib   Build-Depends:     base >= 4 && < 5,-    mtl >= 2.0 && < 2.1,-    vty >= 4.6 && < 4.8+    mtl >= 2.0 && < 2.2,+    vty >= 4.7.0.18,+    vty-ui   if !flag(demos)     Buildable: False