packages feed

vty-ui 1.4 → 1.9

raw patch · 73 files changed

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009-2011, Jonathan Daugherty.+Copyright (c) 2009-2013, Jonathan Daugherty. All rights reserved.  Redistribution and use in source and binary forms, with or without
+ demos/CollectionDemo.hs view
@@ -0,0 +1,72 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import System.Exit+import qualified Data.Text as T+import Graphics.Vty hiding (Button)+import Graphics.Vty.Widgets.All++items :: [T.Text]+items = [ "Arrow keys change list items"+        , "Esc quits"+        , "Ctrl-n goes to the next interface"+        ]++mkFirstUI = do+  u <- plainText $ T.unlines items+  pe <- padded u (padLeftRight 2)+  (d, dFg) <- newDialog pe "This is a dialog"+  setNormalAttribute d (white `on` blue)+  c <- centered =<< withPadding (padLeftRight 10) (dialogWidget d)+  d `onDialogAccept` const shutdownUi+  d `onDialogCancel` const shutdownUi+  return (c, dFg)++mkSecondUI = do+  fg <- newFocusGroup+  lst <- newTextList items 1+  setSelectedUnfocusedAttr lst $ Just (green `on` blue)+  addToFocusGroup fg lst+  c <- centered =<< vLimit 10 =<< hLimit 50 =<< bordered lst+  return (c, fg)++mkThirdUI = do+  fg <- newFocusGroup+  cb1 <- newCheckbox $ items !! 0+  cb2 <- newCheckbox $ items !! 1+  cb3 <- newCheckbox $ items !! 2+  addToFocusGroup fg cb1+  addToFocusGroup fg cb2+  addToFocusGroup fg cb3++  c <- centered =<< vLimit 10 =<< hLimit 50 =<< bordered =<< (+         (return cb1) <--> (return cb2) <--> (return cb3)+       )++  return (c, fg)++main :: IO ()+main = do+  coll <- newCollection++  (ui1, fg1) <- mkFirstUI+  switchToFirst <- addToCollection coll ui1 fg1++  (ui2, fg2) <- mkSecondUI+  switchToSecond <- addToCollection coll ui2 fg2++  (ui3, fg3) <- mkThirdUI+  switchToThird <- addToCollection coll ui3 fg3++  let keyHandler nextUI = \_ k mods ->+        case (k, mods) of+            (KChar 'n', [MCtrl]) -> nextUI >> return True+            (KEsc, []) -> exitSuccess+            _ -> return False++  fg1 `onKeyPressed` (keyHandler switchToSecond)+  fg2 `onKeyPressed` (keyHandler switchToThird)+  fg3 `onKeyPressed` (keyHandler switchToFirst)++  runUi coll $ defaultContext { focusAttr = black `on` yellow }
+ demos/ComplexDemo.hs view
@@ -0,0 +1,174 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import System.Exit ( exitSuccess )+{-+ - As of time-1.5, Data.Time.Format re-exports the names we use from+ - System.Locale; to be compatible with both time-1.4 and time-1.5, we refer to+ - them by a qualified reference to 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 brightGreen+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 1+  setSelectedUnfocusedAttr lst $ Just (fgColor brightGreen)++  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+                           }
+ demos/DialogDemo.hs view
@@ -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
+ demos/DirBrowserDemo.hs view
@@ -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+                           }
+ demos/EditDemo.hs view
@@ -0,0 +1,46 @@+{-# 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+  e4 <- editWidget+  setEditRewriter e4 (const '*')++  fg <- newFocusGroup+  _ <- addToFocusGroup fg e1+  _ <- addToFocusGroup fg e2+  _ <- addToFocusGroup fg e3+  _ <- addToFocusGroup fg e4++  be1 <- bordered =<< boxFixed 40 5 e1+  be2 <- bordered =<< boxFixed 40 3 e2+  be3 <- bordered =<< boxFixed 40 1 e3+  be4 <- bordered =<< boxFixed 40 1 e4++  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 "Password input:")+                         <--> (return be4)+                         <--> (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 }
+ demos/ListDemo.hs view
@@ -0,0 +1,135 @@+{-# 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+                , uis :: Collection+                }++titleAttr = brightWhite `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 ", defAttr), ("q", keyAttr), (" to quit\n", defAttr)+           , ("- Press ", defAttr), ("+", keyAttr)+           , (" / ", defAttr), ("a", keyAttr)+           , (" to add a list item\n", defAttr)+           , ("- Press ", defAttr), ("-", keyAttr)+           , (" / ", defAttr), ("d", keyAttr)+           , (" to remove the selected list item\n", defAttr)+           , ("- Press ", defAttr)+           , ("up", keyAttr), (" / ", defAttr)+           , ("down", keyAttr), (" / ", defAttr)+           , ("page up", keyAttr), (" / ", defAttr)+           , ("page down", keyAttr)+           , (" to navigate the list\n", defAttr)+           ]++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 [] 1+  setSelectedUnfocusedAttr lw $ Just selAttr+  b <- textWidget wrap T.empty+  ft <- plainText T.empty >>= withNormalAttribute titleAttr++  c <- newCollection++  return $ AppElements { theList = lw+                       , theBody = b+                       , theFooter = ft+                       , 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+           (KChar 'q') -> exitSuccess+           (KChar '-') -> removeCurrentItem >> return True+           (KChar 'd') -> removeCurrentItem >> return True+           (KChar '+') -> addNewItem >> return True+           (KChar '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+                                  }
+ demos/PhoneInputDemo.hs view
@@ -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+                           }
+ demos/ProgressBarDemo.hs view
@@ -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 = brightGreen `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+                           }
doc/Makefile view
@@ -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?/*~
doc/ch1/api_notes.tex view
@@ -1,9 +1,11 @@ \section{Conventions and API Notes} -When you create a widget in \vtyui, the result with almost always have+\subsection{Widget Types}++When you create a widget in \vtyui, the result will 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-operations can be performed on it.  For example, a text widget has+operations can be performed on it.  For example, a text widget has the type \fw{Widget FormattedText}.  Throughout this document, we'll refer frequently to widgets by their state type (e.g., ``\fw{Edit} widgets''). In most cases we are referring to a value whose type is,@@ -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}.
doc/ch1/getting_started.tex view
@@ -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}@@ -95,7 +97,7 @@ Every \vtyui\ program requires a \fw{Collection}.  \begin{haskellcode}- addToCollection ui fg+ addToCollection c ui fg \end{haskellcode}  This adds the top-level user interface widget, \fw{ui}, to the@@ -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
doc/ch2/event_loop.tex view
@@ -72,7 +72,7 @@ they are not set, the widgets default to using those specified by the rendering context.  The only exception is the ``override'' attribute. Instead of ``falling back'' to this attribute, the presence of this-attribute reuqires widgets to use it.  For example, this attribute is+attribute requires widgets to use it.  For example, this attribute is used in the \fw{List} widget so that the currently-selected list item can be highlighted, which requires the \fw{List} to override the item's default attribute configuration.@@ -137,7 +137,7 @@ \fw{someAttr `withStyle` underline} & adding a style \\ \hline \end{tabular} -The Vty \fw{def\_attr} value's default configuration is used as a+The Vty \fw{defAttr} value's default configuration is used as a basis for all partially-specified attributes.  The functions described above are defined in the \fw{Util} module. @@ -182,3 +182,36 @@ Some built-in widgets will almost always be used in this way; for an example, take a look at the \fw{ProgressBar} widget in the \fw{ProgressBar} module (see Section \ref{sec:progress_bars}).++\subsection{Handling Resize Events}++When \vtyui\ renders a widget, you can be notified if its size changes.  This+might be useful if, for example, you want to change the visual style or state+of a widget when its size crosses a threshold.  To do this, register a resize+event handler on the widget with \fw{onResize} as follows:++\begin{haskellcode}+ w <- someWidget+ w `onResize` \(oldSize, newSize) -> do+   ...+\end{haskellcode}++The resize handler will be given the old size before the change and the new+size after the change.  Initially every widget has size \fw{(0, 0)} so your+handler will always run at least once with an "old" size of \fw{(0, 0)} and a+"new" size of the widget's initial size.++The \fw{onResize} mechanism has a serious caveat.  Consider a resize handler+which results in another size change, such as a call to \fw{setText} which+makes a text widget larger.  Such a change would spur another size change and+would result in a non-terminating sequence of calls which would probably crash+your program or, if not, just use all of your CPU.  To avoid this, ensure that+any resize handlers don't result in size changes; you can change the visual+style, attributes, etc., of your widget, but if you change contents enough, a+resize handler loop will result.++Finally, since resize handlers run during the rendering process, any changes to+widgets which require a redraw to be visible on the screen will need to use the+\fw{schedule} function (see Section \ref{sec:concurrency}).  This will ensure+that visual changes to a widget made during rendering will force another+rendering.
doc/ch2/focus_groups.tex view
@@ -68,7 +68,7 @@ \begin{haskellcode}  fg <- newFocusGroup  fg `onKeyPressed` \_ key _ ->-   if key == KASCII 'q' then+   if key == KChar 'q' then      exitSuccess else return False \end{haskellcode} @@ -107,9 +107,9 @@ You might wonder why this is useful.  Consider a situation in which you want to add some padding to an input widget, such as an \fw{Edit} widget, but when the \fw{Edit} widget is focused you want to highlight-the padding, too, to make them appear as a single widget.  Since+the padding too, to make them appear as a single widget.  Since padding widgets (see Section \ref{sec:padding}) relay events to their-children, you could focus the padding widget and the edit widget would+children, you could focus the padding widget, and the edit widget would automatically receive the focus as well as user input events.  This kind of focus and event ``inheritance'' makes it possible to create new, composite widgets in a flexible way, while getting the desired
doc/ch2/handling_user_input.tex view
@@ -28,12 +28,12 @@  \begin{haskellcode}  w `onKeyPressed` \_ key _ ->-   if key == KASCII 'f' then+   if key == KChar 'f' then      (launchTheMissiles >> return True) else      return False   w `onKeyPressed` \_ key _ ->-   if key == KASCII 'q' then+   if key == KChar 'q' then      exitSuccess else return False \end{haskellcode}
doc/ch3/deferring_to_children.tex view
@@ -24,17 +24,15 @@ \begin{haskellcode}  newWrapper :: Widget a -> IO (Widget (Wrapper a))  newWrapper child = do-   wRef <- newWidget $ \w ->-     w { state = Wrapper child-       , growHorizontal_ = growHorizontal child+   wRef <- newWidget (Wrapper child) $ \w ->+     w { growHorizontal_ = growHorizontal child        , growVertical_ = growVertical child        , setCurrentPosition_ =-           \_ pos = setCurrentPosition child pos+           \_ pos -> setCurrentPosition child pos        , getCursorPosition_ =            const $ getCursorPosition child        , render_ =-           \_ sz ctx = do-             render child sz ctx+         \_ sz ctx -> render child sz ctx        }     wRef `relayFocusEvents` child
doc/ch3/implementing_composite_widgets.tex view
@@ -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,13 +78,6 @@          (plainText "-") <++>          (hFixed 5 e3) -   setEditMaxLength e1 3-   setEditMaxLength e2 3-   setEditMaxLength e3 4--   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@@ -99,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]
doc/ch3/implementing_event_handlers.tex view
@@ -44,11 +44,9 @@  newTempMonitor :: IO (Widget TempMonitor)  newTempMonitor = do    handlers <- newHandlers-   wRef <- newWidget $ \w ->-     w { state = TempMonitor { tempChangeHandlers = handlers-                             }-       }-+   let st = TempMonitor { tempChangeHandlers = handlers+                        }+   wRef <- newWidget st id    return wRef \end{haskellcode} @@ -70,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@@ -87,7 +85,7 @@    when (newTemp > maxTemp) $ error "It's too hot!" \end{haskellcode} -The last thing it do is to actually ``fire'' the event that these+The last thing it does is to actually ``fire'' the event that these handlers will handle; assuming the monitor widget has a \fw{setTemperature} function and some internal state to store the temperature, that function would create the \fw{TemperatureEvent} and@@ -99,7 +97,7 @@    -- Set the internal widget state.    -- ...    -- Then invoke the handlers:-   fireEvent wRef (tempChangeHandlers <~~) (TemperatureEvent newTemp)+   fireEvent wRef (tempChangeHandlers <~~) (Temp newTemp) \end{haskellcode}  Just as with \fw{addHandler}, we pass a handler list lookup function
doc/ch3/new_widget_type.tex view
@@ -8,27 +8,28 @@ 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+                deriving (Show) \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)  newCounter initialValue = do-   wRef <- newWidget $ \w ->-     w { state = Counter initialValue-       , render_ =+   let st = Counter initialValue+   newWidget st $ \w ->+     w { render_ =          \this size ctx -> do            (Counter v) <- getState this            return $ string (getNormalAttr ctx) (show v)@@ -39,45 +40,40 @@ the code:  \begin{haskellcode}- wRef <- newWidget $ \w -> ...+ let st = Counter initialValue+ newWidget st $ \w -> ... \end{haskellcode}  The \fw{Core} module's \fw{newWidget} function creates a new \fw{IORef} wrapping a \fw{WidgetImpl a}.  The \fw{WidgetImpl} type is 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\_} and \fw{state}.  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.--The \fw{newWidget} function takes a function \fw{WidgetImpl a ->-  WidgetImpl a} and updates the widget implementation contained in the-\fw{IORef}.  We use this to specify the behavior of the widget beyond-the defaults, which are specified in the \fw{newWidget} function.+as \fw{render\_}. The \fw{newWidget} function will return the+\fw{IORef} as \fw{Widget Counter}; \fw{Widget} is a type alias. -\begin{haskellcode}- state = Counter initialValue-\end{haskellcode}+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 provided by the \fw{newWidget} function. -Here we set the inital value of the counter and create the-\fw{Counter} state and store it in the \fw{WidgetImpl}.  We'll-reference this state later on in the rendering code and in any API-functions that we want to implement to mutate it.+Here is the \fw{render\_} function which will actually construct a Vty+\fw{Image} to be displayed in the terminal:  \begin{haskellcode}  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 $ regionWidth size) -+                 (fromEnum $ textWidth s)+         (truncated, _, _) = clip1d (Phys 0) (Phys width) s+     return $ string (getNormalAttr ctx) $ T.unpack truncated \end{haskellcode} -This actually does the job of rendering the counter value into a form-that can be displayed in the terminal.  The type of \fw{render\_} is-\fw{Widget a -> DisplayRegion -> RenderContext -> IO Image}.  The-types are as follows:+The type of \fw{render\_} is \fw{Widget a -> DisplayRegion ->+  RenderContext -> IO Image}.  The arguments are as follows:  \begin{itemize} \item \fw{Widget a} - the widget being rendered, i.e., the \fw{Widget@@ -93,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,19 +110,27 @@  The \fw{getState} function takes a \fw{Widget a} and returns its \fw{state} field.  In this case, it returns the \fw{Counter} value.+It's important to use \fw{getState} instead of just referring to+\fw{st} in the example above, since you'll need to make sure to get+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 $ regionWidth 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@@ -134,7 +138,7 @@ The \fw{getNormalAttr} function returns the normal attribute from the \fw{Render\-Context}, merged with the ``override'' attribute from the \fw{Render\-Context}, if it is set.  For more information on the-override attribute, see Section \vref{sec:attributes}.+override attribute, see Section \ref{sec:attributes}.  This concludes the basic implementation requirements for a new widget type; to make it useful, we'll need to add some functions to manage
doc/ch3/rendering.tex view
@@ -21,7 +21,7 @@   specified attribute. \item \fw{char} -- Creates an image from a character using the   specified attribute.-\item \fw{char\_fill} -- Creates an image with the specified width and+\item \fw{charFill} -- Creates an image with the specified width and   height, filled with the specified character and attribute. \item \fw{<->} -- Vertical concatenation of images. \item \fw{<|>} -- Horizontal concatenation of images.
doc/ch3/widgetimpl_api.tex view
@@ -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.@@ -48,10 +54,10 @@   Sometimes used when positioning child widgets and when positioning   the cursor, if any. \item \fw{normalAttribute} -- the widget's normal attribute.  Defaults-  to Vty's \fw{def\_attr} value, which merges transparently with the+  to Vty's \fw{defAttr} value, which merges transparently with the   \fw{RenderContext}'s normal attribute. \item \fw{focusAttribute} -- the widget's focus attribute.  Defaults-  to Vty's \fw{def\_attr} value, which merges transparently with the+  to Vty's \fw{defAttr} value, which merges transparently with the   \fw{RenderContext}'s focus attribute. \item \fw{keyEventHandler} -- the action responsible for handling key   events for this widget.  The default implementation merely starts
doc/ch4/DirBrowser.tex view
@@ -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}
doc/ch4/Edit.tex view
@@ -2,13 +2,17 @@ \label{sec:edit}  The \fw{Edit} module provides a line-editing widget, \fw{Widget Edit}.-This widget makes it possible to edit a single line of text with some-Emacs-style key bindings.+This widget makes it possible to edit text with some Emacs-style key+bindings. -An \fw{Edit} widget is simple to create:+An \fw{Edit} widget is simple to create.  You can create \fw{Edit}+widgets in two modes: single- and multi-line:  \begin{haskellcode}- e <- editWidget+ -- Single-line text editor:+ e1 <- editWidget+ -- Multi-line text editor:+ e2 <- multiLineEditWidget \end{haskellcode}  \fw{Edit} widgets can be laid out in the usual way:@@ -34,16 +38,21 @@   position. \item \fw{Backspace} -- delete the character just before the cursor   position and move the cursor position back by one character.-\item \fw{Enter} -- ``activate'' the \fw{Edit} widget.+\item \fw{Enter} -- ``activate'' the \fw{Edit} widget if it is a+  single-line widget; if it is multi-line, insert a new line at the+  cursor position. \end{itemize} +Note that \fw{Tab} will not be handled by \fw{Edit} widgets because it+is used to change focus.+ An \fw{Edit} widget can be monitored for three events:  \begin{itemize} \item ``Activation'' events -- triggered when the user presses-  \fw{Enter} in the \fw{Edit} widget.  Handlers are registered with-  the \fw{onActivate} function.  Event handlers receive the \fw{Edit}-  widget as a parameter.+  \fw{Enter} in a single-line \fw{Edit} widget.  Handlers are+  registered with the \fw{onActivate} function.  Event handlers+  receive the \fw{Edit} widget as a parameter. \item Text change -- when the contents of the \fw{Edit} widget change.   Handlers are registered with the \fw{onChange} function.  Event   handlers receive the new \fw{String} value in the \fw{Edit} widget.@@ -62,14 +71,29 @@   content of the \fw{Edit} widget. \item \fw{getEditCursorPosition}, \fw{setEditCursorPosition} --   manipulate the cursor position within the \fw{Edit} widget.-\item \fw{setEditMaxLength} -- set the maximum number of characters in-  the \fw{Edit} widget.  Once set, the limit cannot be removed but it-  can be changed to a different value.  If \fw{setEditMaxLength} is-  called with a limit which is less than the limit already set, the-  content of the \fw{Edit} widget will be truncated and any change-  event handlers will be notified.+\item \fw{getEditLineLimit}, \fw{setEditLineLimit} -- manipulate the+  limit on the number of lines that the text widget may hold.  Takes+  \fw{Maybe Int} where \fw{Nothing} indicates no limit.+  \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} -\fw{Edit} widgets grow only horizontally and are always one row high.+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{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}).
doc/ch4/Fixed.tex view
@@ -51,7 +51,7 @@ guarantee that the specified space is consumed.  \begin{haskellcode}- lst <- newList (green `on` black)+ lst <- newList 1  ui <- vFixed 5 lst \end{haskellcode}
doc/ch4/FormattedText.tex view
@@ -9,7 +9,7 @@ \fw{plainText} function and can be laid out in the usual way:  \begin{haskellcode}- t1 <- plainText "blue" >>= withNormalAttribute (fgColor blue)+ t1 <- plainText "blue" >>= withNormal (fgColor blue)  t2 <- plainText "green" >>= withNormalAttribute (fgColor green)  ui <- (return t1) <++> (return t2) \end{haskellcode}@@ -20,20 +20,20 @@ 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}  All text widget update functions \textit{tokenize} their inputs, finding contiguous sequences of whitespace and non-whitespace characters and newlines, and store the list of tokens in the widget.-Each token is assigned a default attribute of \fw{def\_attr}, which+Each token is assigned a default attribute of \fw{defAttr}, which 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@@ -48,9 +48,9 @@ \begin{haskellcode}  t <- plainText ""  setTextWithAttrs t [ ("foo", fgColor green)-                    , (" ", def_attr)+                    , (" ", defAttr)                     , ("bar", fgColor yellow)-                    , (" ", def_attr)+                    , (" ", defAttr)                     , ("baz", red `on` blue)                     ] \end{haskellcode}@@ -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
doc/ch4/List.tex view
@@ -36,17 +36,21 @@ Lists are created with the \fw{newList} function:  \begin{haskellcode}- lst <- newList attr+ lst <- newList 1 \end{haskellcode} -\fw{newList} takes one parameter: the attribute of the-currently-selected item to be used when the list is \textit{not}-focused.  The \fw{List} uses its own focus attribute (Section-\ref{sec:attributes}) as the attribute of the currently-selected item-when it has the focus.  The widget type of the list (\fw{b} above)-won't be chosen by the type system until you actually add something to-the list.+\fw{newList} takes one parameter: the height, in rows, of each widget in the+list.  The \fw{List} uses its own focus attribute (Section+\ref{sec:attributes}) as the attribute of the currently-selected item when it+has the focus.  The widget type of the list (\fw{b} above) won't be chosen by+the type system until you actually add something to the list. +The \fw{List} widget uses the default focus attribute of the rendering context+to render the selected item when the list has the focus.  To control how the+selected item appears when the list has or lacks focus, use see+\fw{set\-Selected\-Focused\-Attr} and+\fw{set\-Se\-lec\-ted\-Un\-fo\-cused\-Attr}.+ Items may be added to a \fw{List} with the \fw{addToList} function, which takes an internal value (e.g., \fw{String}) and a widget of the appropriate type:@@ -59,21 +63,19 @@ In addition, items may be inserted into a \fw{List} at any position with the \fw{insertIntoList} function. -There are two restrictions on the widget type that can be used with-\fw{List}s:+When it comes to how \fw{List}s render item widgets, there are two behaviors to+know about:  \begin{itemize}-\item The \fw{Widget b} type \textit{must not grow vertically}.  This-  is because all \fw{List} item widgets must take up a fixed amount of-  vertical space so the \fw{List} can manage scrolling.  If the widget-  grows vertically, \fw{addToList} will throw a \fw{ListError}-  exception.-\item All widgets added to the \fw{List} \textit{must have the same-  height}.  This is because the list uses the item height to calculate-  how many items can be displayed, given the space available to the-  rendered \fw{List}.  If you specify a widget whose rendered size-  doesn't match that of the rest of the wigets of the list, layout-  problems are likely to ensue.+\item \textit{All widgets rendered by the list must have the same height}.+  This is because the list uses the item height to calculate how many+  items can be displayed, given the space available to the rendered \fw{List}.+  This is why the height of list items must be passed to \fw{newList}.+\item \textit{The item widgets will be height-restricted}.  This is because all+  \fw{List} item widgets must take up a fixed amount of vertical space so the+  \fw{List} can manage scrolling state.  Internally the \fw{List} widget uses+  \fw{vLimit} and \fw{vFixed} wrappers to render each item widget to guarantee+  that all items have the same height. \end{itemize}  Items may be removed from \fw{List}s with the \fw{removeFromList}@@ -113,7 +115,7 @@   value, and widget of the currently-selected list item. \item \fw{getListItem} -- takes a \fw{Widget (List a b)} and an index   and returns \fw{Nothing} if the \fw{List} has no item at the-  specified index item or returns \fw{Just (pos, (val, widget))}+  specified index item or returns \fw{Just (val, widget)}   corresponding to the list index. \end{itemize}
doc/ch4/ProgressBar.tex view
@@ -5,19 +5,27 @@ you can use to indicate task progression in your applications.  \fw{ProgressBar}s can be created with the \fw{newProgressBar}-function.  The function takes two \fw{Color} arguments indicating the-colors to be used for the complete and incomplete portions of the+function.  The function takes two \fw{Attr} arguments indicating the+attributes to be used for the complete and incomplete portions of the progress bar, respectively:  \begin{haskellcode}- bar <- newProgressBar blue white+ bar <- newProgressBar (blue `on` white) (white `on` blue) \end{haskellcode} -\fw{ProgressBar}s are composite widgets; to lay them out in your-applications, use the \fw{progressBarWidget} function:+\fw{ProgressBar}s take \fw{Attr} values because these widgets support+text labels.  You can set the label and its alignment as follows:  \begin{haskellcode}- ui <- (plainText "Progress: ") <--> (return $ progressBarWidget bar)+ setProgressText bar "Working..."+ setProgressTextAlignment bar AlignCenter+\end{haskellcode}++\fw{ProgressBar}s can be laid out in your interface like any other+widget:++\begin{haskellcode}+ ui <- (plainText "Progress: ") <--> (return bar) \end{haskellcode}  A \fw{ProgressBar} tracks progress as an \fw{Int} n ($0 \le n \le
doc/ch4/Table.tex view
@@ -75,7 +75,7 @@ \end{haskellcode}  The \fw{ColumnSpec} type is also an instance of the \fw{Alignable}-type class provided by the \fw{Table} module.  This type class+type class provided by the \fw{Alignment} module.  This type class provides an \fw{align} function which we can use to set the default cell alignment for the column:
+ doc/ch5/TextClip.tex view
@@ -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.
+ doc/ch5/TextZipper.tex view
@@ -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}
+ doc/ch5/main.tex view
@@ -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}
doc/macros.tex view
@@ -1,9 +1,10 @@ % Custom macros. -\newcommand{\vtyuiversion}{1.4}+\newcommand{\vtyuiversion}{1.9}  \newcommand{\fw}[1]{\texttt{#1}} \newcommand{\vtyui}{\fw{vty-ui}}  % Defines 'haskellcode' environment to have these options.-\newminted{haskell}{samepage,fontsize=\small}+\definecolor{mintedBg}{rgb}{0.95,0.95,0.95}+\newminted{haskell}{samepage,fontsize=\small,bgcolor=mintedBg}
doc/title_page.tex view
@@ -1,6 +1,7 @@ \title{\vtyui\ User's Manual} \author{   For \vtyui\ version \vtyuiversion\\-  Jonathan Daugherty (\href{mailto:jtd@galois.com}{jtd@galois.com})+  by Jonathan Daugherty (\href{mailto:cygnus@foobox.com}{cygnus@foobox.com})\\+  (and contributors!) } \maketitle
doc/vty-ui-users-manual.tex view
@@ -6,6 +6,10 @@ % For smarter references. \usepackage{varioref} +% For better control over itemize environments.+\usepackage{enumitem}+\setlist[itemize]{topsep=0pt}+ % For syntax highlighting! \usepackage{minted} @@ -33,5 +37,6 @@ \include{ch2/main} \include{ch3/main} \include{ch4/main}+\include{ch5/main}  \end{document}
− src/ComplexDemo.hs 
@@ -1,161 +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 <- editWidget--  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 red white-  progLabel <- plainText ""--  addHeadingRow_ table headerAttr ["Column 1", "Column 2"]-  addRow table $ radioHeader .|. rs-  addRow table $ cbHeader .|. r3-  addRow table $ edit1Header .|. edit1-  addRow table $ edit2Header .|. edit2-  addRow table $ listHeader .|. customCell selector `pad` padNone-  addRow table $ emptyCell .|. timeText-  addRow table $ progLabel .|. (progressBarWidget prog)--  rg `onRadioChange` \cb -> do-      s <- getCheckboxLabel cb-      setText radioHeader $ s ++ ", please."--  r3 `onCheckboxChange` \v ->-      setText cbHeader $ "you chose: " ++ show v--  prog `onProgressChange` \val ->-      setText progLabel $ 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-                           }
− src/DialogDemo.hs 
@@ -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
− src/DirBrowserDemo.hs 
@@ -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-                           }
+ src/Graphics/Vty/Widgets/Alignment.hs view
@@ -0,0 +1,16 @@+-- |This module provides a type and a type class for expressing+-- alignment.  For concrete uses, see the Table and ProgressBar+-- modules.+module Graphics.Vty.Widgets.Alignment+    ( Alignment(..)+    , Alignable(..)+    )+where++-- |Column alignment values.+data Alignment = AlignCenter | AlignLeft | AlignRight+                 deriving (Show)++-- |The class of types whose values or contents can be aligned.+class Alignable a where+    align :: a -> Alignment -> a
src/Graphics/Vty/Widgets/All.hs view
@@ -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@@ -22,6 +24,7 @@     , module Graphics.Vty.Widgets.ProgressBar     , module Graphics.Vty.Widgets.DirBrowser     , module Graphics.Vty.Widgets.Group+    , module Graphics.Vty.Widgets.Alignment     ) where @@ -31,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@@ -47,3 +52,4 @@ import Graphics.Vty.Widgets.ProgressBar import Graphics.Vty.Widgets.DirBrowser import Graphics.Vty.Widgets.Group+import Graphics.Vty.Widgets.Alignment
src/Graphics/Vty/Widgets/Borders.hs view
@@ -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,38 +71,47 @@ -- attribute and character. hBorder :: IO (Widget HBorder) hBorder = do-  wRef <- newWidget $ \w ->-      w { state = HBorder def_attr ""-        , growHorizontal_ = const $ return True+  let initSt = HBorder defAttr T.empty+  wRef <- newWidget initSt $ \w ->+      w { growHorizontal_ = const $ return True         , render_ = renderHBorder+        , getCursorPosition_ = const $ return Nothing         }   return wRef  renderHBorder :: Widget HBorder -> DisplayRegion -> RenderContext -> IO Image-renderHBorder _ (DisplayRegion 0 _) _ = return empty_image-renderHBorder _ (DisplayRegion _ 0) _ = return empty_image+renderHBorder _ (0, _) _ = return emptyImage+renderHBorder _ (_, 0) _ = return emptyImage renderHBorder this s ctx = do   HBorder attr str <- getState this   let attr' = mergeAttrs [ overrideAttr ctx                          , 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 $ regionWidth 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 $ regionWidth s) of+                True -> return noTitle+                False -> do+                       let remaining = (Phys $ fromEnum $ regionWidth 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) @@ -112,20 +123,21 @@ -- attribute and character. vBorder :: IO (Widget VBorder) vBorder = do-  wRef <- newWidget $ \w ->-      w { state = VBorder def_attr-        , growVertical_ = const $ return True+  let initSt = VBorder defAttr+  wRef <- newWidget initSt $ \w ->+      w { growVertical_ = const $ return True+        , getCursorPosition_ = const $ return Nothing         , render_ = \this s ctx -> do                    VBorder attr <- getState this                    let attr' = mergeAttrs [ overrideAttr ctx                                           , attr                                           , normalAttr ctx                                           ]-                   return $ char_fill attr' (skinVertical $ skin ctx) 1 (region_height s)+                   return $ charFill attr' (skinVertical $ skin ctx) 1 (regionHeight s)         }   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,10 +154,9 @@ -- |Wrap a widget in a bordering box. bordered :: (Show a) => Widget a -> IO (Widget (Bordered a)) bordered child = do-  wRef <- newWidget $ \w ->-      w { state = Bordered def_attr child ""--        , growVertical_ = const $ growVertical child+  let initSt = Bordered defAttr child T.empty+  wRef <- newWidget initSt $ \w ->+      w { growVertical_ = const $ growVertical child         , growHorizontal_ = const $ growHorizontal child          , keyEventHandler =@@ -171,7 +182,7 @@ drawBordered :: (Show a) =>                 Bordered a -> DisplayRegion -> RenderContext -> IO Image drawBordered this s ctx-    | region_width s < 2 || region_height s < 2 = return empty_image+    | regionWidth s < 2 || regionHeight s < 2 = return emptyImage     | otherwise = do   let Bordered attr child label = this       attr' = mergeAttrs [ overrideAttr ctx@@ -183,17 +194,22 @@   -- Render the contained widget with enough room to draw borders.   -- Then, use the size of the rendered widget to constrain the space   -- used by the (expanding) borders.-  let constrained = DisplayRegion (region_width s - 2) (region_height s - 2)+  let constrained = (regionWidth s - 2, regionHeight s - 2)    childImage <- render child constrained ctx -  let adjusted = DisplayRegion (image_width childImage + 2)-                 (image_height childImage)+  let adjusted = ( imageWidth childImage + 2+                 , imageHeight 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'@@ -210,6 +226,6 @@    leftRight <- render vb adjusted ctx -  let middle = horiz_cat [leftRight, childImage, leftRight]+  let middle = horizCat [leftRight, childImage, leftRight] -  return $ vert_cat [top, middle, bottom]+  return $ vertCat [top, middle, bottom]
src/Graphics/Vty/Widgets/Box.hs view
@@ -28,7 +28,6 @@     ) where -import GHC.Word ( Word ) import Data.Typeable import Control.Exception import Control.Monad@@ -81,11 +80,11 @@                    -- growth comparison function                    , secondGrows :: IO Bool                    -- region dimension fetch function-                   , regDimension :: DisplayRegion -> Word+                   , regDimension :: DisplayRegion -> Int                    -- image dimension fetch function-                   , imgDimension :: Image -> Word+                   , imgDimension :: Image -> Int                    -- dimension modification function-                   , withDimension :: DisplayRegion -> Word -> DisplayRegion+                   , withDimension :: DisplayRegion -> Int -> DisplayRegion                    -- Oriented image concatenation                    , img_cat :: [Image] -> Image                    }@@ -134,27 +133,28 @@ box :: (Show a, Show b) =>        Orientation -> Int -> Widget a -> Widget b -> IO (Widget (Box a b)) box o spacing wa wb = do-  wRef <- newWidget $ \w ->-      w { state = Box { boxChildSizePolicy = defaultChildSizePolicy-                      , boxOrientation = o-                      , boxSpacing = spacing-                      , boxFirst = wa-                      , boxSecond = wb+  let initSt = Box { boxChildSizePolicy = defaultChildSizePolicy+                   , boxOrientation = o+                   , boxSpacing = spacing+                   , boxFirst = wa+                   , boxSecond = wb -                      , firstGrows =-                          (if o == Vertical then growVertical else growHorizontal) wa-                      , secondGrows =-                          (if o == Vertical then growVertical else growHorizontal) wb-                      , regDimension =-                          if o == Vertical then region_height else region_width-                      , imgDimension =-                          if o == Vertical then image_height else image_width-                      , withDimension =-                          if o == Vertical then withHeight else withWidth-                      , img_cat =-                          if o == Vertical then vert_cat else horiz_cat-                      }-        , growHorizontal_ = \b -> do+                   , firstGrows =+                       (if o == Vertical then growVertical else growHorizontal) wa+                   , secondGrows =+                       (if o == Vertical then growVertical else growHorizontal) wb+                   , regDimension =+                       if o == Vertical then snd else fst+                   , imgDimension =+                       if o == Vertical then imageHeight else imageWidth+                   , withDimension =+                       if o == Vertical then withHeight else withWidth+                   , img_cat =+                       if o == Vertical then vertCat else horizCat+                   }++  wRef <- newWidget initSt $ \w ->+      w { growHorizontal_ = \b -> do             case boxOrientation b of               Vertical -> do                 h1 <- growHorizontal $ boxFirst b@@ -208,9 +208,9 @@               setCurrentPosition (boxFirst b) pos               case boxOrientation b of                 Horizontal -> setCurrentPosition (boxSecond b) $-                              pos `plusWidth` ((region_width ch1_size) + (toEnum $ boxSpacing b))+                              pos `plusWidth` ((fst ch1_size) + (toEnum $ boxSpacing b))                 Vertical -> setCurrentPosition (boxSecond b) $-                            pos `plusHeight` ((region_height ch1_size) + (toEnum $ boxSpacing b))+                            pos `plusHeight` ((snd ch1_size) + (toEnum $ boxSpacing b))         }    wRef `relayFocusEvents` wa@@ -289,34 +289,34 @@   let spAttr = getNormalAttr ctx       spacing = boxSpacing this       spacer = case spacing of-                 0 -> empty_image+                 0 -> emptyImage                  _ -> case boxOrientation this of-                         Horizontal -> let h = max (image_height img1) (image_height img2)-                                       in char_fill spAttr ' ' (toEnum spacing) h-                         Vertical -> let w = max (image_width img1) (image_width img2)-                                     in char_fill spAttr ' ' w (toEnum spacing)+                         Horizontal -> let h = max (imageHeight img1) (imageHeight img2)+                                       in charFill spAttr ' ' (toEnum spacing) h+                         Vertical -> let w = max (imageWidth img1) (imageWidth img2)+                                     in charFill spAttr ' ' w (toEnum spacing)        -- Use the larger of the two images to determine padding in the       -- opposite dimension.  E.g. if this is a vertical box, we want       -- to pad the images such that they have the same width.       common_opposite_dim = case boxOrientation this of-                              Horizontal -> max (image_height img1) (image_height img2)-                              Vertical -> max (image_width img1) (image_width img2)+                              Horizontal -> max (imageHeight img1) (imageHeight img2)+                              Vertical -> max (imageWidth img1) (imageWidth img2)        padded_img1 = case boxOrientation this of                       Horizontal -> img1 <->-                                    (char_fill spAttr ' ' (image_width img1)-                                     (common_opposite_dim - image_height img1))+                                    (charFill spAttr ' ' (imageWidth img1)+                                     (common_opposite_dim - imageHeight img1))                       Vertical -> img1 <|>-                                  (char_fill spAttr ' ' (common_opposite_dim - image_width img1)-                                   (image_height img1))+                                  (charFill spAttr ' ' (common_opposite_dim - imageWidth img1)+                                   (imageHeight img1))       padded_img2 = case boxOrientation this of                       Horizontal -> img2 <->-                                    (char_fill spAttr ' ' (image_width img2)-                                     (common_opposite_dim - image_height img2))+                                    (charFill spAttr ' ' (imageWidth img2)+                                     (common_opposite_dim - imageHeight img2))                       Vertical -> img2 <|>-                                  (char_fill spAttr ' ' (common_opposite_dim - image_width img2)-                                   (image_height img2))+                                  (charFill spAttr ' ' (common_opposite_dim - imageWidth img2)+                                   (imageHeight img2))     return $ (img_cat this) [padded_img1, spacer, padded_img2]@@ -332,7 +332,7 @@     -- If the box is too large to fit in the available space (since it     -- has fixed dimensions and can't be scaled), return the empty     -- image.-    | toEnum firstDim + toEnum secondDim > regDimension this s = return (empty_image, empty_image)+    | toEnum firstDim + toEnum secondDim > regDimension this s = return (emptyImage, emptyImage)     | otherwise = do   let withDim = withDimension this   img1 <- render (boxFirst this) (s `withDim` (toEnum firstDim)) ctx@@ -340,8 +340,8 @@    -- pad the images so they fill the space appropriately.   let fill img amt = case boxOrientation this of-                   Vertical -> char_fill (getNormalAttr ctx) ' ' (image_width img) amt-                   Horizontal -> char_fill (getNormalAttr ctx) ' ' amt (image_height img)+                   Vertical -> charFill (getNormalAttr ctx) ' ' (imageWidth img) amt+                   Horizontal -> charFill (getNormalAttr ctx) ' ' amt (imageHeight img)       firstDimW = toEnum firstDim       secondDimW = toEnum secondDim       img1_size = (imgDimension this) img1@@ -379,7 +379,7 @@         b_img <- render b s' ctx          return $ if renderDimension a_img >= regDim actualSpace-                 then [a_img, empty_image]+                 then [a_img, emptyImage]                  else [a_img, b_img]        renderHalves = do
src/Graphics/Vty/Widgets/Button.hs view
@@ -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
src/Graphics/Vty/Widgets/Centering.hs view
@@ -11,7 +11,6 @@     ) where -import GHC.Word ( Word ) import Graphics.Vty.Widgets.Core import Graphics.Vty import Graphics.Vty.Widgets.Util@@ -24,9 +23,8 @@ -- |Wrap another widget to center it horizontally. hCentered :: (Show a) => Widget a -> IO (Widget (HCentered a)) hCentered ch = do-  wRef <- newWidget $ \w ->-      w { state = HCentered ch-        , growHorizontal_ = const $ return True+  wRef <- newWidget (HCentered ch) $ \w ->+      w { growHorizontal_ = const $ return True          , growVertical_ = \(HCentered child) -> growVertical child @@ -35,12 +33,12 @@                    img <- render child s ctx                     let attr' = getNormalAttr ctx-                       (half, half') = centered_halves region_width s (image_width img)+                       (half, half') = centered_halves regionWidth s (imageWidth img)                     return $ if half > 0-                            then horiz_cat [ char_fill attr' ' ' half (image_height img)+                            then horizCat [ charFill attr' ' ' half (imageHeight img)                                            , img-                                           , char_fill attr' ' ' half' (image_height img)+                                           , charFill attr' ' ' half' (imageHeight img)                                            ]                             else img @@ -49,9 +47,13 @@               HCentered child <- getState this               s <- getCurrentSize this               chSz <- getCurrentSize child-              let (half, _) = centered_halves region_width s (region_width chSz)+              let (half, _) = centered_halves regionWidth s (regionWidth chSz)                   chPos = pos `plusWidth` half               setCurrentPosition child chPos++        , getCursorPosition_ = \this -> do+              HCentered child <- getState this+              getCursorPosition child         }   wRef `relayKeyEvents` ch   wRef `relayFocusEvents` ch@@ -65,9 +67,8 @@ -- |Wrap another widget to center it vertically. vCentered :: (Show a) => Widget a -> IO (Widget (VCentered a)) vCentered ch = do-  wRef <- newWidget $ \w ->-      w { state = VCentered ch-        , growVertical_ = const $ return True+  wRef <- newWidget (VCentered ch) $ \w ->+      w { growVertical_ = const $ return True         , growHorizontal_ = const $ growHorizontal ch          , render_ = \this s ctx -> do@@ -75,12 +76,12 @@                    img <- render child s ctx                     let attr' = getNormalAttr ctx-                       (half, half') = centered_halves region_height s (image_height img)+                       (half, half') = centered_halves regionHeight s (imageHeight img)                     return $ if half > 0-                            then vert_cat [ char_fill attr' ' ' (image_width img) half+                            then vertCat [ charFill attr' ' ' (imageWidth img) half                                           , img-                                          , char_fill attr' ' ' (image_width img) half'+                                          , charFill attr' ' ' (imageWidth img) half'                                           ]                             else img @@ -89,9 +90,13 @@               VCentered child <- getState this               s <- getCurrentSize this               chSz <- getCurrentSize child-              let (half, _) = centered_halves region_height s (region_height chSz)+              let (half, _) = centered_halves regionHeight s (regionHeight chSz)                   chPos = pos `plusHeight` half               setCurrentPosition child chPos++        , getCursorPosition_ = \this -> do+              VCentered child <- getState this+              getCursorPosition child         }   wRef `relayKeyEvents` ch   wRef `relayFocusEvents` ch@@ -101,7 +106,7 @@ centered :: (Show a) => Widget a -> IO (Widget (VCentered (HCentered a))) centered wRef = vCentered =<< hCentered wRef -centered_halves :: (DisplayRegion -> Word) -> DisplayRegion -> Word -> (Word, Word)+centered_halves :: (DisplayRegion -> Int) -> DisplayRegion -> Int -> (Int, Int) centered_halves region_size s obj_sz =     let remaining = region_size s - obj_sz         half = remaining `div` 2
src/Graphics/Vty/Widgets/CheckBox.hs view
@@ -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,42 +159,48 @@ newMultiStateCheckbox _ [] = throw EmptyCheckboxStates newMultiStateCheckbox label states = do   cchs <- newHandlers-  wRef <- newWidget $ \w ->-      w { state = CheckBox { checkboxLabel = label-                           , checkboxChangeHandlers = cchs-                           , leftBracketChar = '['-                           , rightBracketChar = ']'-                           , checkboxStates = states-                           , currentState = fst $ states !! 0-                           , checkboxFrozen = False-                           }-        , getCursorPosition_ =+  t <- plainText ""+  let initSt = CheckBox { checkboxLabel = label+                        , checkboxChangeHandlers = cchs+                        , leftBracketChar = '['+                        , rightBracketChar = ']'+                        , 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]@@ -222,11 +232,11 @@                                      }  -- |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-radioKeyEvent this (KASCII ' ') [] = cycleCheckbox this >> return True+radioKeyEvent this (KChar ' ') [] = cycleCheckbox this >> return True radioKeyEvent this KEnter [] = cycleCheckbox this >> return True radioKeyEvent _ _ _ = return False
src/Graphics/Vty/Widgets/Core.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances, BangPatterns #-} -- |This module is the core of this library; it provides -- infrastructure for creating new types of widgets and extending -- their functionality.  This module provides various bits of@@ -31,6 +31,8 @@     , growHorizontal     , getCursorPosition     , showWidget+    , getVisible+    , setVisible     , (<~)     , (<~~) @@ -51,6 +53,7 @@     , onKeyPressed     , onGainFocus     , onLoseFocus+    , onResize     , relayKeyEvents     , relayFocusEvents @@ -81,11 +84,12 @@ import Graphics.Vty.Widgets.Skins import Graphics.Vty.Widgets.Events --- |The class of types with a "normal" attribute.+-- |The class of types with a ''normal'' attribute. class HasNormalAttr w where     setNormalAttribute :: w -> Attr -> IO () --- |The class of types with a "focus" attribute.+-- |The class of types with a ''focus'' attribute, i.e., a way of+-- visually indicating that the object has input focus. class HasFocusAttr w where     setFocusAttribute :: w -> Attr -> IO () @@ -133,7 +137,7 @@                   , overrideAttr :: Attr                   -- ^An override attribute to be used to override                   -- both the normal and focus attributes in effect-                  -- during rendering.  Usually def_attr, this+                  -- during rendering.  Usually defAttr, this                   -- attribute is used when child widgets need to have                   -- their attributes overridden by a parent widget.                   , skin :: Skin@@ -148,52 +152,60 @@  -- |Default context settings. defaultContext :: RenderContext-defaultContext = RenderContext def_attr (white `on` blue) def_attr unicodeSkin+defaultContext = RenderContext defAttr (white `on` blue) defAttr unicodeSkin  -- |The type of widget implementations, parameterized on the type of -- the widget's state. data WidgetImpl a = WidgetImpl {-      state :: a+      state :: !a     -- ^The state of the widget.-    , render_ :: Widget a -> DisplayRegion -> RenderContext -> IO Image+    , 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     -- work with, and a rendering context to be used to determine     -- attribute and skin settings.  This MUST return an image which     -- is no larger than the specified rendering region.-    , growHorizontal_ :: a -> IO Bool+    , growHorizontal_ :: !(a -> IO Bool)     -- ^Returns whether the widget will automatically grow to fill     -- available horizontal space.-    , growVertical_ :: a -> IO Bool+    , growVertical_ :: !(a -> IO Bool)     -- ^Returns whether the widget will automatically grow to fill     -- available vertical space.-    , currentSize :: DisplayRegion+    , currentSize :: !DisplayRegion     -- ^The size of the widget after its most recent rendering pass.-    , currentPosition :: DisplayRegion++    -- NOTE: DisplayRegion is a lazy tuple.+    , currentPosition :: !DisplayRegion     -- ^The position of the widget after its most recent rendering     -- pass.-    , normalAttribute :: Attr++    -- NOTE: DisplayRegion is a lazy tuple.+    , normalAttribute :: !Attr     -- ^The normal (unfocused) attribute of the wiget.-    , focusAttribute :: Attr+    , focusAttribute :: !Attr     -- ^The focused attribute of the widget.-    , setCurrentPosition_ :: Widget a -> DisplayRegion -> IO ()+    , setCurrentPosition_ :: !(Widget a -> DisplayRegion -> IO ())     -- ^Sets the current position of the widget.  Takes a widget     -- reference and a display region indicating the coordinates of     -- the widget's upper left corner.-    , keyEventHandler :: Widget a -> Key -> [Modifier] -> IO Bool+    , keyEventHandler :: !(Widget a -> Key -> [Modifier] -> IO Bool)     -- ^The widget's key event handler.  Takes a widget reference, a     -- key event, and a list of keyboard modifiers.  Returns whether     -- the keyboard event was handled.  True indicates that the event     -- was handled and that event processing should halt; False     -- indicates that other event handlers, if present, may handle the     -- event.-    , gainFocusHandlers :: Handlers (Widget a)+    , gainFocusHandlers :: !(Handlers (Widget a))     -- ^List of handlers to be invoked when the widget gains focus.-    , loseFocusHandlers :: Handlers (Widget a)+    , resizeHandlers :: !(Handlers (DisplayRegion, DisplayRegion))+    -- ^List of handlers to be invoked when the widget's size changes.+    , loseFocusHandlers :: !(Handlers (Widget a))     -- ^List of handlers to be invoked when the widget loses focus.-    , focused :: Bool+    , focused :: !Bool     -- ^Whether the widget is focused.-    , getCursorPosition_ :: Widget a -> IO (Maybe DisplayRegion)+    , getCursorPosition_ :: !(Widget a -> IO (Maybe DisplayRegion))     -- ^Returns the current terminal cursor position.  Should return     -- Nothing if the widget does not need to show a cursor, or Just     -- if it does.  (For example, widgets receiving keyboard input for@@ -220,19 +232,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@@ -248,23 +278,28 @@ 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 emptyImage+    True -> do+           -- Merge the override attributes with the context.  If the+           -- overrides haven't been set (still defAttr), 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 = (imageWidth img, imageHeight img) -  when (image_width img > region_width sz ||-        image_height img > region_height sz) $ throw $ ImageTooBig (show impl) sz imgsz+           when ((imageWidth img > 0 && imageHeight img > 0) &&+                 (imageWidth img > regionWidth sz || imageHeight img > regionHeight sz)) $+                 throw $ ImageTooBig (show impl) sz imgsz -  setCurrentSize wRef $ DisplayRegion (image_width img) (image_height img)-  return img+           setCurrentSize wRef (imageWidth img, imageHeight img)+           return img  -- |Render a widget and set its position after rendering is complete. -- This is exported for internal use; widget implementations should@@ -283,10 +318,14 @@   setCurrentPosition wRef pos   return img --- |Set the current size of a widget.  Exported for internal use.+-- |Set the current size of a widget.  Exported for internal use.  When the+-- size changes from its previous value, resize event handlers will be invoked. setCurrentSize :: Widget a -> DisplayRegion -> IO ()-setCurrentSize wRef newSize =-    modifyIORef wRef $ \w -> w { currentSize = newSize }+setCurrentSize wRef newSize = do+    oldSize <- getCurrentSize wRef+    when (oldSize /= newSize) $ do+      atomicModifyIORef' wRef $ \w -> (w { currentSize = newSize }, ())+      handleResizeEvent wRef (oldSize, newSize)  -- |Get the current size of the widget (its size after its most recent -- rendering).@@ -304,29 +343,34 @@   w <- readIORef wRef   (setCurrentPosition_ w) wRef pos --- |Create a new widget.  Takes a widget implementation function and--- passes it an implementation with default values.  The caller MUST--- set the 'state' and 'render_' functions of the implementation!-newWidget :: (WidgetImpl a -> WidgetImpl a) -> IO (Widget a)-newWidget f = do+-- |Create a new widget.  Takes an initial state value and a widget+-- implementation transformation and passes it an implementation with+-- default values.+newWidget :: a+          -> (WidgetImpl a -> WidgetImpl a)+          -> IO (Widget a)+newWidget initState f = do   gfhs <- newHandlers   lfhs <- newHandlers+  rhs <- newHandlers    wRef <- newIORef $-          WidgetImpl { state = undefined-                     , render_ = undefined+          WidgetImpl { state = initState+                     , render_ = \_ _ _ -> return emptyImage                      , growVertical_ = const $ return False                      , growHorizontal_ = const $ return False                      , setCurrentPosition_ = \_ _ -> return ()-                     , currentSize = DisplayRegion 0 0-                     , currentPosition = DisplayRegion 0 0+                     , currentSize = (0, 0)+                     , currentPosition = (0, 0)                      , focused = False+                     , visible = True                      , gainFocusHandlers = gfhs+                     , resizeHandlers = rhs                      , loseFocusHandlers = lfhs                      , keyEventHandler = \_ _ _ -> return False                      , getCursorPosition_ = defaultCursorInfo-                     , normalAttribute = def_attr-                     , focusAttribute = def_attr+                     , normalAttribute = defAttr+                     , focusAttribute = defAttr                      }    updateWidget wRef f@@ -335,10 +379,10 @@ -- |Default cursor positioning implementation used by 'newWidget'. defaultCursorInfo :: Widget a -> IO (Maybe DisplayRegion) defaultCursorInfo w = do-  sz <- getCurrentSize w+  (rW, _) <- getCurrentSize w   pos <- getCurrentPosition w-  if region_width sz > 0 then-      return $ Just $ pos `plusWidth` (region_width sz - 1) else+  if rW > 0 then+      return $ Just $ pos `plusWidth` (rW - 1) else       return Nothing  -- |Given a widget and key event information, invoke the widget's key@@ -349,6 +393,11 @@   act <- keyEventHandler <~ wRef   act wRef keyEvent mods +-- |Given a widget, invoke its resize event handlers with the old and new+-- sizes.+handleResizeEvent :: Widget a -> (DisplayRegion, DisplayRegion) -> IO ()+handleResizeEvent wRef szs = fireEvent wRef (resizeHandlers <~) szs+ -- |Given widgets A and B, causes any key events on widget A to be -- relayed to widget B.  Note that this does behavior constitutes an -- ordinary key event handler from A's perspective, so if B does not@@ -385,7 +434,10 @@    updateWidget wRef $ \w -> w { keyEventHandler = combinedHandler } --- |Focus a widget.  Causes its focus gain event handlers to run.+-- |Focus a widget.  Causes its focus gain event handlers to run.  If+-- the widget is in a 'FocusGroup' and if that group's+-- currently-focused widget is some other widget, that widget will+-- lose the focus and its focus loss event handlers will be called. focus :: Widget a -> IO () focus wRef = do   updateWidget wRef $ \w -> w { focused = True }@@ -403,6 +455,17 @@ onGainFocus :: Widget a -> (Widget a -> IO ()) -> IO () onGainFocus = addHandler (gainFocusHandlers <~) +-- |Given a widget and a resize event handler, add the handler to the widget.+-- The handler will be invoked when the widget's size changes.  This includes+-- the first rendering, at which point its size changes from (0, 0).  Note that+-- if the resize handler needs to change the visual appearance of the widget+-- when its size changes, be sure to use 'schedule' to ensure that visual+-- changes are reflected immediately, and be absolutely sure that those changes+-- will not cause further size changes; that will cause a resize event handler+-- loop that will consume your CPU!+onResize :: Widget a -> ((DisplayRegion, DisplayRegion) -> IO ()) -> IO ()+onResize = addHandler (resizeHandlers <~)+ -- |Given a widget and a focus loss event handler, add the handler to -- the widget.  The handler will be invoked when the widget loses -- focus.@@ -420,7 +483,7 @@ -- |Given a widget and an implementation transformer, apply the -- transformer to the widget's implementation. updateWidget :: Widget a -> (WidgetImpl a -> WidgetImpl a) -> IO ()-updateWidget wRef f = modifyIORef wRef f+updateWidget wRef f = atomicModifyIORef' wRef (\w -> (f w, ()))  -- |Get the state value of a widget. getState :: Widget a -> IO a@@ -428,9 +491,8 @@  -- |Apply a state transformation function to a widget's state. updateWidgetState :: Widget a -> (a -> a) -> IO ()-updateWidgetState wRef f = do-  w <- readIORef wRef-  writeIORef wRef $ w { state = f (state w) }+updateWidgetState wRef f =+  updateWidget wRef (\w -> w { state = f (state w) })  -- |Focus group handling errors. data FocusGroupError = FocusGroupEmpty@@ -456,14 +518,14 @@  newFocusEntry :: (Show a) => Widget a -> IO (Widget FocusEntry) newFocusEntry chRef = do-  wRef <- newWidget $ \w ->-      w { state = FocusEntry chRef -        , growHorizontal_ = const $ growHorizontal chRef+  let st = FocusEntry chRef++  wRef <- newWidget st $ \w ->+      w { growHorizontal_ = const $ growHorizontal chRef         , growVertical_ = const $ growVertical chRef -        , render_ =-            \_ sz ctx -> render chRef sz ctx+        , render_ = \_ sz ctx -> render chRef sz ctx          , setCurrentPosition_ =             \this pos -> do@@ -481,14 +543,15 @@ -- before input events are handled by the currently-focused widget. newFocusGroup :: IO (Widget FocusGroup) newFocusGroup = do-  wRef <- newWidget $ \w ->-      w { state = FocusGroup { entries = []-                             , currentEntryNum = -1-                             , nextKey = (KASCII '\t', [])-                             , prevKey = (KASCII '\t', [MShift])-                             } -        , getCursorPosition_ =+  let initSt = FocusGroup { entries = []+                          , currentEntryNum = -1+                          , nextKey = (KChar '\t', [])+                          , prevKey = (KBackTab, [])+                          }++  wRef <- newWidget initSt $ \w ->+      w { getCursorPosition_ =             \this -> do               cur <- currentEntryNum <~~ this               case cur of@@ -511,9 +574,6 @@                           do                             let e = entries st !! i                             handleKeyEvent e key mods--        -- Should never be rendered.-        , render_ = \_ _ _ -> return empty_image         }   return wRef @@ -530,9 +590,9 @@     updateWidgetState fg $ \s -> s { prevKey = (k, mods) }  -- |Merge two focus groups.  Given two focus groups A and B, this--- returns a new focus group with all of the entries from A and B--- added to it, in that order.  Both A and B must be non-empty or--- 'FocusGroupEmpty' will be thrown.+-- returns a new focus group with all of the entries from A and B added to it,+-- in that order.  At least one A and B must be non-empty or 'FocusGroupEmpty'+-- will be thrown. mergeFocusGroups :: Widget FocusGroup -> Widget FocusGroup -> IO (Widget FocusGroup) mergeFocusGroups a b = do   c <- newFocusGroup@@ -540,7 +600,7 @@   aEntries <- entries <~~ a   bEntries <- entries <~~ b -  when (null aEntries || null bEntries) $+  when (null aEntries && null bEntries) $        throw FocusGroupEmpty    updateWidgetState c $ \s -> s { entries = aEntries ++ bEntries@@ -606,8 +666,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)
src/Graphics/Vty/Widgets/Dialog.hs view
@@ -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
src/Graphics/Vty/Widgets/DirBrowser.hs view
@@ -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,16 +126,20 @@ 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)+  l <- newList 1+  setSelectedUnfocusedAttr l $ Just (browserUnfocusedSelAttr bSkin)+   ui <- vBox header =<< vBox l footer    r <- newIORef ""@@ -145,10 +164,13 @@    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 l+  _ <- addToFocusGroup fg ui    setDirBrowserPath b path   return (b, fg)@@ -156,11 +178,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,23 +214,26 @@ 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)+      , defAttr)     , (\_ s -> isSymbolicLink s,        (\p stat -> do           linkDest <- if not $ isSymbolicLink stat@@ -213,7 +241,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 +250,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' _ _ [] = (defAttr, return T.empty)       getAnnotation' pth stat ((f,mkAnn,a):rest) =           if f pth stat           then (a, mkAnn pth stat)@@ -242,8 +270,8 @@ handleBrowserKey b _ KRight [] = descend b False >> return True handleBrowserKey b _ KLeft [] = ascend b >> return True handleBrowserKey b _ KEsc [] = cancelBrowse b >> return True-handleBrowserKey b _ (KASCII 'q') [] = cancelBrowse b >> return True-handleBrowserKey b _ (KASCII 'r') [] = refreshBrowser b >> return True+handleBrowserKey b _ (KChar 'q') [] = cancelBrowse b >> return True+handleBrowserKey b _ (KChar 'r') [] = refreshBrowser b >> return True handleBrowserKey _ _ _ _ = return False  -- |Refresh the browser by reloading and displaying the contents of@@ -262,7 +290,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 +332,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
src/Graphics/Vty/Widgets/Edit.hs view
@@ -1,114 +1,279 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}--- |This module provides a one-line editing interface.+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-}+-- |This module provides a text-editing widget.  Edit widgets can+-- operate in single- and multi-line modes.+--+-- Edit widgets support the following special keystrokes:+--+-- * Arrow keys to navigate the text+--+-- * @Enter@ - Activate single-line edit widgets or insert new lines+--   into multi-line widgets+--+-- * @Home@ / @Control-a@ - Go to beginning of the current line+--+-- * @End@ / @Control-e@ - Go to end of the current line+--+-- * @Control-k@ - Remove text from the cursor to the end of the line,+--   or remove the line if it is empty+--+-- * @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+    , multiLineEditWidget     , getEditText+    , getEditCurrentLine     , setEditText-    , setEditCursorPosition+    , setEditRewriter+    , setCharFilter     , getEditCursorPosition+    , setEditCursorPosition+    , setEditLineLimit+    , getEditLineLimit     , setEditMaxLength+    , getEditMaxLength+    , applyEdit     , onActivate     , onChange     , onCursorMove+#ifdef TESTING+    , doClipping+    , indicatorChar+#endif     ) where +import Control.Applicative ((<$>)) import Control.Monad+import Data.Maybe (isJust)+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-                 , cursorPosition :: Int-                 , displayStart :: Int-                 , displayWidth :: Int+data Edit = Edit { contents :: Z.TextZipper T.Text+                 , clipRect :: ClipRect                  , activateHandlers :: Handlers (Widget Edit)-                 , changeHandlers :: Handlers String-                 , cursorMoveHandlers :: Handlers Int-                 , maxTextLength :: Maybe Int+                 , changeHandlers :: Handlers T.Text+                 , cursorMoveHandlers :: Handlers (Int, Int)+                 , lineLimit :: Maybe Int+                 , maxLength :: Maybe Int+                 , rewriter :: Char -> Char+                 , charFilter :: Char -> Bool                  }  instance Show Edit where     show e = concat [ "Edit { "-                    , "currentText = ", show $ currentText e-                    , ", cursorPosition = ", show $ cursorPosition e-                    , ", displayStart = ", show $ displayStart e-                    , ", displayWidth = ", show $ displayWidth e+                    , "contents = ", show $ contents e+                    , ", lineLimit = ", show $ lineLimit e+                    , ", clipRect = ", show $ clipRect e                     , " }"                     ] --- |Create a new editing widget.-editWidget :: IO (Widget Edit)-editWidget = do+editWidget' :: IO (Widget Edit)+editWidget' = do   ahs <- newHandlers   chs <- newHandlers   cmhs <- newHandlers -  wRef <- newWidget $ \w ->-      w { state = Edit { currentText = ""-                       , cursorPosition = 0-                       , displayStart = 0-                       , displayWidth = 0-                       , activateHandlers = ahs-                       , changeHandlers = chs-                       , cursorMoveHandlers = cmhs-                       , maxTextLength = Nothing-                       }+  let initSt = Edit { contents = Z.textZipper []+                    , clipRect = ClipRect { clipLeft = 0+                                          , clipWidth = 0+                                          , clipTop = 0+                                          , clipHeight = 1+                                          }+                    , activateHandlers = ahs+                    , changeHandlers = chs+                    , cursorMoveHandlers = cmhs+                    , lineLimit = Nothing+                    , maxLength = Nothing+                    , rewriter = id+                    , charFilter = const True+                    } -        , growHorizontal_ = const $ return True-        , getCursorPosition_ =+  wRef <- newWidget initSt $ \w ->+      w { growHorizontal_ = const $ return True+        , growVertical_ =             \this -> do-              f <- focused <~ this-              pos <- getCurrentPosition this-              curPos <- cursorPosition <~~ this-              start <- displayStart <~~ this+              case lineLimit this of+                Just v | v == 1 -> return False+                _ -> return True -              if f then-                  return (Just $ pos `plusWidth` (toEnum (curPos - start))) else-                  return Nothing+        , getCursorPosition_ = internalGetCursorPosition+        , render_ = renderEditWidget+        , keyEventHandler = editKeyEvent+        }+  return wRef -        , render_ =-            \this size ctx -> do-              setDisplayWidth this (fromEnum $ region_width size)-              st <- getState this+internalGetCursorPosition :: Widget Edit -> IO (Maybe DisplayRegion)+internalGetCursorPosition this = do+  st <- getState this+  f <- focused <~ this+  pos <- getCurrentPosition this -              let truncated = take (displayWidth st)-                              (drop (displayStart st) (currentText st))+  let (cursorRow, _) = Z.cursorPosition (contents st)+      Phys offset = physCursorCol st - clipLeft (clipRect st)+      newPos = pos+               `withWidth` (toEnum ((fromEnum $ regionWidth pos) + offset))+               `plusHeight` (toEnum (cursorRow - (fromEnum $ clipTop $ clipRect st))) -                  nAttr = mergeAttrs [ overrideAttr ctx-                                     , normalAttr ctx-                                     ]+  return $ if f then Just newPos else Nothing -              isFocused <- focused <~ this-              let attr = if isFocused then focusAttr ctx else nAttr+-- |Set the function which rewrites all characters at rendering time.  Defaults+-- to 'id'.  Does not affect text stored in the editor.+setEditRewriter :: Widget Edit -> (Char -> Char) -> IO ()+setEditRewriter w f =+    updateWidgetState w $ \st -> st { rewriter = f } -              return $ string attr truncated-                         <|> char_fill attr ' ' (region_width size - (toEnum $ length truncated)) 1+-- |Set the function which allows typed characters in the edit widget.+-- Defaults to 'const' 'True', allowing all characters.  For example, setting the+-- filter to ('elem' \"0123456789\") will only allow numbers in the edit widget.+setCharFilter :: Widget Edit -> (Char -> Bool) -> IO ()+setCharFilter w f =+    updateWidgetState w $ \st -> st { charFilter = f } -        , keyEventHandler = editKeyEvent-        }+renderEditWidget :: Widget Edit -> DisplayRegion -> RenderContext -> IO Image+renderEditWidget this size ctx = do+  resizeEdit this ( Phys $ fromEnum $ regionHeight size+                  , Phys $ fromEnum $ regionWidth size )++  st <- getState this+  isFocused <- focused <~ this++  let nAttr = mergeAttrs [ overrideAttr ctx+                         , normalAttr ctx+                         ]+      attr = if isFocused then focusAttr ctx else nAttr++      clipped = doClipping (Z.getText $ contents st) (clipRect st)+      rewritten = ((rewriter st) <$>) <$> clipped++      totalAllowedLines = fromEnum $ regionHeight size+      numEmptyLines = lim - length rewritten+          where+            lim = case lineLimit st of+                    Just v -> min v totalAllowedLines+                    Nothing -> totalAllowedLines++      emptyLines = replicate numEmptyLines ""+      lineWidget s = let Phys physLineLength = sum $ chWidth <$> s+                     in string attr s <|>+                        charFill attr ' ' (regionWidth size - toEnum physLineLength) 1++  return $ vertCat $ lineWidget <$> (rewritten ++ emptyLines)++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').+editWidget :: IO (Widget Edit)+editWidget = do+  wRef <- editWidget'   setNormalAttribute wRef $ style underline   setFocusAttribute wRef $ style underline+  setEditLineLimit wRef $ Just 1   return wRef --- |Set the maximum length of the edit widget's content.-setEditMaxLength :: Widget Edit -> Int -> IO ()-setEditMaxLength wRef v = do-  cur <- maxTextLength <~~ wRef-  case cur of-    Nothing -> return ()-    Just oldMax ->-        when (v < oldMax) $-             do-               s <- currentText <~~ wRef-               setEditText wRef $ take v s-  updateWidgetState wRef $ \s -> s { maxTextLength = Just v }+-- |Construct a text widget for editing multi-line documents.+-- Multi-line edit widgets never send activation events, since the+-- @Enter@ key inserts a new line at the cursor position.+multiLineEditWidget :: IO (Widget Edit)+multiLineEditWidget = do+  wRef <- editWidget'+  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.+setEditLineLimit :: Widget Edit -> Maybe Int -> IO ()+setEditLineLimit _ (Just v) | v <= 0 = return ()+setEditLineLimit w v = updateWidgetState w $ \st -> st { lineLimit = v }++-- |Get the current line limit, if any, for the edit widget.+getEditLineLimit :: Widget Edit -> IO (Maybe Int)+getEditLineLimit = (lineLimit <~~)++-- |Set the maximum length of the contents of an edit widget.  Applies to every+-- line of text in the editor.  'Nothing' indicates no limit, while 'Just'+-- indicates a limit of the specified number of characters.+setEditMaxLength :: Widget Edit -> Maybe Int -> IO ()+setEditMaxLength _ (Just v) | v <= 0 = return ()+setEditMaxLength w v = updateWidgetState w $ \st -> st { maxLength = v }++-- |Get the current maximum length, if any, for the edit widget.+getEditMaxLength :: Widget Edit -> IO (Maybe Int)+getEditMaxLength = (maxLength <~~)++resizeEdit :: Widget Edit -> (Phys, Phys) -> IO ()+resizeEdit e (newHeight, newWidth) = do+  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).+-- focused).  These handlers will only be invoked when a single-line+-- edit widget is activated; multi-line widgets never generate these+-- events. onActivate :: Widget Edit -> (Widget Edit -> IO ()) -> IO () onActivate = addHandler (activateHandlers <~~) @@ -127,179 +292,133 @@  -- |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).-onCursorMove :: Widget Edit -> (Int -> IO ()) -> IO ()+-- 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.-getEditText :: Widget Edit -> IO String-getEditText = (currentText <~~)+-- |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 T.Text+getEditText = (((T.intercalate (T.pack "\n")) . Z.getText . contents) <~~) --- |Set the contents of the edit widget.-setEditText :: Widget Edit -> String -> IO ()+-- |Get the contents of the current line of the edit widget (the line+-- on which the cursor is positioned).+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.  If the edit+-- widget has a line length limit, lines will be truncated.+setEditText :: Widget Edit -> T.Text -> IO () setEditText wRef str = do-  oldS <- currentText <~~ wRef-  maxLen <- maxTextLength <~~ wRef-  s <- case maxLen of-    Nothing -> return str-    Just l -> return $ take l str-  updateWidgetState wRef $ \st -> st { currentText = s }-  when (oldS /= s) $ do-    gotoBeginning wRef-    notifyChangeHandlers wRef+  lim <- lineLimit <~~ wRef+  maxL <- maxLength <~~ wRef+  let ls1 = case lim of+             Nothing -> T.lines str+             Just l -> take l $ T.lines str+      ls2 = case maxL of+             Nothing -> ls1+             Just l -> ((T.take l) <$>) $ T.lines str+  updateWidgetState wRef $ \st -> st { contents = Z.textZipper ls2+                                     }+  notifyChangeHandlers wRef --- |Set the current edit widget cursor position.  Invalid cursor--- positions will be ignored.-setEditCursorPosition :: Widget Edit -> Int -> IO ()-setEditCursorPosition wRef pos = do-  oldPos <- getEditCursorPosition wRef-  str <- getEditText wRef+-- |Get the edit widget's current cursor position (row, column).+getEditCursorPosition :: Widget Edit -> IO (Int, Int)+getEditCursorPosition = ((Z.cursorPosition . contents) <~~) -  let newPos = if pos > (length str)-               then length str-               else if pos < 0-                    then 0-                    else pos+-- |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) -  when (newPos /= oldPos) $-       do-         updateWidgetState wRef $ \s ->-             s { cursorPosition = newPos-               }-         notifyCursorMoveHandlers wRef+-- |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 --- |Get the edit widget's current cursor position.-getEditCursorPosition :: Widget Edit -> IO Int-getEditCursorPosition = (cursorPosition <~~)+-- |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+  old <- contents <~~ this+  llim <- lineLimit <~~ this+  maxL <- maxLength <~~ this -setDisplayWidth :: Widget Edit -> Int -> IO ()-setDisplayWidth this width =-    updateWidgetState this $ \s ->-        let newDispStart = if cursorPosition s - displayStart s >= width-                           then cursorPosition s - width + 1-                           else displayStart s-        in s { displayWidth = width-             , displayStart = newDispStart-             }+  let checkLines tz = case llim of+                        Nothing -> Just tz+                        Just l -> if length (Z.getText tz) > l+                                  then Nothing+                                  else Just tz+      checkLength tz = case maxL of+                         Nothing -> Just tz+                         Just l -> if or ((> l) <$> (Z.lineLengths tz))+                                   then Nothing+                                   else Just tz+      newContents = checkLength =<< checkLines (f old) +  when (isJust newContents) $ do+    let Just new = newContents+    updateWidgetState this $ \s -> s { contents = new }++    when (Z.getText old /= Z.getText new) $+         notifyChangeHandlers this++    when (Z.cursorPosition old /= Z.cursorPosition new) $+         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-    (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-    (KEnter, []) -> notifyActivateHandlers this >> return True+    (KChar 'a', [MCtrl]) -> run Z.gotoBOL+    (KChar 'k', [MCtrl]) -> run Z.killToEOL+    (KChar 'e', [MCtrl]) -> run Z.gotoEOL+    (KChar 'd', [MCtrl]) -> run Z.deleteChar+    (KLeft, []) -> run Z.moveLeft+    (KRight, []) -> run Z.moveRight+    (KUp, []) -> run Z.moveUp+    (KDown, []) -> run Z.moveDown+    (KBS, []) -> do+        v <- run Z.deletePrevChar+        when (v) $ do+            -- We want deletions to cause content earlier on the line(s) to+            -- slide in from the left rather than letting the cursor reach the+            -- beginning of the edit widget, preventing the user from seeing+            -- characters being deleted.  To do this, after deletion (if we+            -- can) we slide the clipping window one column to the left.+            updateWidgetState this $ \st ->+                let r = clipRect st+                in if clipLeft r > 0+                   then st { clipRect = r { clipLeft = clipLeft r - Phys 1 } }+                   else st+        return v+    (KDel, []) -> run Z.deleteChar+    (KChar ch, []) -> do+        st <- getState this+        if charFilter st ch+            then run (Z.insertChar ch)+            else return True -- True even if the filter rejected the character.+    (KHome, []) -> run Z.gotoBOL+    (KEnd, []) -> run Z.gotoEOL+    (KEnter, []) -> do+                   lim <- lineLimit <~~ this+                   case lim of+                     Just 1 -> notifyActivateHandlers this >> return True+                     _ -> run Z.breakLine     _ -> return False--killToEOL :: Widget Edit -> IO ()-killToEOL this = do-  -- Preserve some state since setEditText changes it.-  pos <- cursorPosition <~~ this-  st <- displayStart <~~ this-  str <- getEditText this--  setEditText this $ take pos str-  updateWidgetState this $ \s ->-      s { displayStart = st-        }--  notifyChangeHandlers this--deletePreviousChar :: Widget Edit -> IO ()-deletePreviousChar this = do-  pos <- cursorPosition <~~ this-  when (pos /= 0) $ do-    moveCursorLeft this-    delCurrentChar this--gotoBeginning :: Widget Edit -> IO ()-gotoBeginning wRef = do-  updateWidgetState wRef $ \s -> s { displayStart = 0-                                   }-  setEditCursorPosition wRef 0--gotoEnd :: Widget Edit -> IO ()-gotoEnd wRef = do-  updateWidgetState wRef $ \s ->-      s { displayStart = if (length $ currentText s) > displayWidth s-                         then (length $ currentText s) - displayWidth s-                         else 0-        }-  s <- getEditText wRef-  setEditCursorPosition wRef $ length s--moveCursorLeft :: Widget Edit -> IO ()-moveCursorLeft wRef = do-  st <- getState wRef--  case cursorPosition st of-    0 -> return ()-    p -> do-      let newDispStart = if p == displayStart st-                         then displayStart st - 1-                         else displayStart st-      updateWidgetState wRef $ \s ->-          s { cursorPosition = p - 1-            , displayStart = newDispStart-            }-      notifyCursorMoveHandlers wRef--moveCursorRight :: Widget Edit -> IO ()-moveCursorRight wRef = do-  st <- getState wRef--  when (cursorPosition st < (length $ currentText st)) $-       do-         let newDispStart = if cursorPosition st == displayStart st + displayWidth st - 1-                            then displayStart st + 1-                            else displayStart st-         updateWidgetState wRef $ \s ->-             s { cursorPosition = cursorPosition st + 1-               , displayStart = newDispStart-               }-         notifyCursorMoveHandlers wRef--insertChar :: Widget Edit -> Char -> IO ()-insertChar wRef ch = do-  maxLen <- maxTextLength <~~ wRef-  curLen <- (length . currentText) <~~ wRef-  let proceed = case maxLen of-                  Nothing -> True-                  Just v -> if curLen + 1 > v-                            then False-                            else True--  when proceed $ do-    updateWidgetState wRef $ \st ->-        let newContent = inject (cursorPosition st) ch (currentText st)-            newViewStart =-                if cursorPosition st == displayStart st + displayWidth st - 1-                then displayStart st + 1-                else displayStart st-        in st { currentText = newContent-              , displayStart = newViewStart-              }-    moveCursorRight wRef-    notifyChangeHandlers wRef--delCurrentChar :: Widget Edit -> IO ()-delCurrentChar wRef = do-  st <- getState wRef-  when (cursorPosition st < (length $ currentText st)) $-       do-         let newContent = remove (cursorPosition st) (currentText st)-         updateWidgetState wRef $ \s -> s { currentText = newContent }-         notifyChangeHandlers wRef
src/Graphics/Vty/Widgets/EventLoop.hs view
@@ -10,12 +10,16 @@     , shutdownUi     , newCollection     , addToCollection+    , addToCollectionWithCallbacks     , setCurrentEntry+    , EntryHide+    , EntryShow     ) where  import Data.IORef import Data.Typeable+import Data.Default (def) import Control.Concurrent ( forkIO ) import Control.Concurrent.STM ( atomically ) import Control.Concurrent.STM.TChan@@ -42,19 +46,18 @@ -- 'Collection' is empty. runUi :: Collection -> RenderContext -> IO () runUi collection ctx = do-  vty <- mkVty+  vty <- mkVty def    -- Create VTY event listener thread   _ <- forkIO $ vtyEventListener vty eventChan -  runUi' vty eventChan collection ctx `finally` do-                         reserve_display $ terminal vty-                         shutdown vty+  setCurrentEntry collection 0+  runUi' vty eventChan collection ctx `finally` shutdown vty  vtyEventListener :: Vty -> TChan CombinedEvent -> IO () vtyEventListener vty chan =     forever $ do-      e <- next_event vty+      e <- nextEvent vty       atomically $ writeTChan chan $ VTYEvent e  -- |Schedule a widget-mutating 'IO' action to be run by the main event@@ -70,29 +73,45 @@  runUi' :: Vty -> TChan CombinedEvent -> Collection -> RenderContext -> IO () runUi' vty chan collection ctx = do-  sz <- display_bounds $ terminal vty+  sz <- displayBounds $ outputIface vty    e <- getCurrentEntry collection   let fg = entryFocusGroup e -  img <- entryRenderAndPosition e (DisplayRegion 0 0) sz ctx-  update vty $ pic_for_image img+  img <- entryRenderAndPosition e (0, 0) sz ctx+  update vty $ picForLayers [img]    mPos <- getCursorPosition fg   case mPos of-    Just (DisplayRegion w h) -> do-                        show_cursor $ terminal vty-                        set_cursor_pos (terminal vty) w h-    Nothing -> hide_cursor $ terminal vty+    Just (w, h) -> do+                        showCursor $ outputIface vty+                        setCursorPos (outputIface vty) w h+    Nothing -> hideCursor $ outputIface vty -  evt <- atomically $ readTChan chan+  -- Get the next event(s) in the queue.  Returns all available events;+  -- blocks until at least one event is available.+  let getNextEvents = do+      evt <- readTChan chan+      em <- isEmptyTChan chan+      case em of+          True -> return [evt]+          False -> do+              rest <- getNextEvents+              return $ evt : rest -  cont <- case evt of-            VTYEvent (EvKey k mods) -> handleKeyEvent fg k mods >> return True-            VTYEvent _ -> return True-            UserEvent (ScheduledAction act) -> act >> return True-            ShutdownUi -> return False+  evts <- atomically getNextEvents +  let processEvent lastCont evt = do+          if not lastCont then+              return False else+              case evt of+                  VTYEvent (EvKey k mods) -> handleKeyEvent fg k mods >> return True+                  VTYEvent _ -> return True+                  UserEvent (ScheduledAction act) -> act >> return True+                  ShutdownUi -> return False++  cont <- foldM processEvent True evts+   when cont $ runUi' vty chan collection ctx  data CollectionError = BadCollectionIndex Int@@ -100,8 +119,16 @@  instance Exception CollectionError -data Entry = forall a. (Show a) => Entry (Widget a) (Widget FocusGroup)+type EntryShow = IO ()+type EntryHide = IO () +data Entry = forall a. (Show a) => Entry+    { entryWidget :: Widget a+    , entryFocusGroup :: Widget FocusGroup+    , entryShowCallback :: EntryShow+    , entryHideCallback :: EntryHide+    }+ data CollectionData =     CollectionData { entries :: [Entry]                    , currentEntryNum :: Int@@ -118,10 +145,7 @@                                           ]  entryRenderAndPosition :: Entry -> DisplayRegion -> DisplayRegion -> RenderContext -> IO Image-entryRenderAndPosition (Entry w _) = renderAndPosition w--entryFocusGroup :: Entry -> Widget FocusGroup-entryFocusGroup (Entry _ fg) = fg+entryRenderAndPosition (Entry { entryWidget = w }) = renderAndPosition w  -- |Create a new collection. newCollection :: IO Collection@@ -130,24 +154,41 @@                               , currentEntryNum = -1                               } +getMaybeCurrentEntry :: Collection -> IO (Maybe Entry)+getMaybeCurrentEntry cRef = do+  cur <- currentEntryNum <~ cRef+  es <- entries <~ cRef+  if cur == -1+    then return Nothing+    else if cur >= 0 && cur < length es+      then return . Just $ es !! cur+      else return Nothing+ getCurrentEntry :: Collection -> IO Entry getCurrentEntry cRef = do+  maybeEntry <- getMaybeCurrentEntry cRef   cur <- currentEntryNum <~ cRef-  es <- entries <~ cRef-  if cur == -1 then-      throw $ BadCollectionIndex cur else-      if cur >= 0 && cur < length es then-          return $ es !! cur else-          throw $ BadCollectionIndex cur+  case maybeEntry of+    Nothing -> throw $ BadCollectionIndex cur+    Just entry -> return entry  -- |Add a widget and its focus group to a collection.  Returns an -- action which, when invoked, will switch to the interface specified -- in the call. addToCollection :: (Show a) => Collection -> Widget a -> Widget FocusGroup -> IO (IO ())-addToCollection cRef wRef fg = do+addToCollection cRef wRef fg = addToCollectionWithCallbacks cRef wRef fg (return ()) (return ())++-- |Add a widget and its focus group to a collection.  In addition, two+-- callbacks -- one to call when showing the widget and one to call when hiding+-- it (i.e. showing some other widget) -- must be provided.  Returns an action+-- which, when invoked, will switch to the interface specified.+addToCollectionWithCallbacks :: (Show a) => Collection -> Widget a+                             -> Widget FocusGroup -> EntryShow+                             -> EntryHide -> IO (IO ())+addToCollectionWithCallbacks cRef wRef fg onShowCb onHideCb = do   i <- (length . entries) <~ cRef   modifyIORef cRef $ \st ->-      st { entries = (entries st) ++ [Entry wRef fg]+      st { entries = (entries st) ++ [Entry wRef fg onShowCb onHideCb]          , currentEntryNum = if currentEntryNum st == -1                              then 0                              else currentEntryNum st@@ -158,9 +199,18 @@ setCurrentEntry :: Collection -> Int -> IO () setCurrentEntry cRef i = do   st <- readIORef cRef-  if i < length (entries st) && i >= 0 then-      (modifyIORef cRef $ \s -> s { currentEntryNum = i }) else-      throw $ BadCollectionIndex i +  if i < length (entries st) && i >= 0+    then do+      -- Let the old entry know it's no longer current.+      maybeOldEntry <- getMaybeCurrentEntry cRef+      case maybeOldEntry of+        Nothing -> return ()+        Just oldEntry -> entryHideCallback oldEntry+      -- Set the current entry index.+      (modifyIORef cRef $ \s -> s { currentEntryNum = i })+    else throw $ BadCollectionIndex i+   e <- getCurrentEntry cRef+  entryShowCallback e   resetFocusGroup $ entryFocusGroup e
src/Graphics/Vty/Widgets/Fills.hs view
@@ -20,35 +20,38 @@ -- specified character and attribute. vFill :: Char -> IO (Widget VFill) vFill c = do-  wRef <- newWidget $ \w ->-      w { state = VFill c-        , growVertical_ = const $ return True+  wRef <- newWidget (VFill c) $ \w ->+      w { growVertical_ = const $ return True         , render_ = \this s ctx -> do                    foc <- focused <~ this                    VFill ch <- getState this                    let attr' = mergeAttrs [ if foc then focusAttr ctx else overrideAttr ctx                                           , normalAttr ctx                                           ]-                   return $ char_fill attr' ch (region_width s) (region_height s)+                   return $ charFill attr' ch (regionWidth s) (regionHeight s)++        , getCursorPosition_ = const $ return Nothing         }   return wRef  data HFill = HFill Char Int              deriving (Show) --- |A horizontal fill widget.  Fills the available horizontal space,--- one row high, using the specified character and attribute.+-- |A horizontal fill widget.  Fills the available horizontal space using the+-- specified character. The integer parameter specifies the height, in rows, of+-- the fill. hFill :: Char -> Int -> IO (Widget HFill) hFill c h = do-  wRef <- newWidget $ \w ->-      w { state = HFill c h-        , growHorizontal_ = const $ return True+  wRef <- newWidget (HFill c h) $ \w ->+      w { growHorizontal_ = const $ return True         , render_ = \this s ctx -> do                    foc <- focused <~ this                    HFill ch height <- getState this                    let attr' = mergeAttrs [ if foc then focusAttr ctx else overrideAttr ctx                                           , normalAttr ctx                                           ]-                   return $ char_fill attr' ch (region_width s) (toEnum height)+                   return $ charFill attr' ch (regionWidth s) (toEnum height)++        , getCursorPosition_ = const $ return Nothing         }   return wRef
src/Graphics/Vty/Widgets/Fixed.hs view
@@ -31,17 +31,17 @@ -- |Impose a fixed horizontal size, in columns, on a 'Widget'. hFixed :: (Show a) => Int -> Widget a -> IO (Widget (HFixed a)) hFixed fixedWidth child = do-  wRef <- newWidget $ \w ->-      w { state = HFixed fixedWidth child-        , render_ = \this s ctx -> do+  let initSt = HFixed fixedWidth child+  wRef <- newWidget initSt $ \w ->+      w { render_ = \this s ctx -> do                    HFixed width ch <- getState this-                   let region = s `withWidth` fromIntegral (min (toEnum width) (region_width s))+                   let region = s `withWidth` fromIntegral (min (toEnum width) (regionWidth s))                    img <- render ch region ctx                    -- Pad the image if it's smaller than the region.-                   let img' = if image_width img < region_width region-                              then img <|> (char_fill (getNormalAttr ctx) ' '-                                            (region_width region - image_width img)-                                            (region_height region))+                   let img' = if imageWidth img < regionWidth region+                              then img <|> (charFill (getNormalAttr ctx) ' '+                                            (toEnum width - imageWidth img)+                                            1)                               else img                    return img' @@ -49,6 +49,10 @@             \this pos -> do               HFixed _ ch <- getState this               setCurrentPosition ch pos++        , getCursorPosition_ = \this -> do+              HFixed _ ch <- getState this+              getCursorPosition ch         }   wRef `relayKeyEvents` child   wRef `relayFocusEvents` child@@ -62,19 +66,19 @@ -- |Impose a fixed vertical size, in columns, on a 'Widget'. vFixed :: (Show a) => Int -> Widget a -> IO (Widget (VFixed a)) vFixed maxHeight child = do-  wRef <- newWidget $ \w ->-      w { state = VFixed maxHeight child-        , growHorizontal_ = const $ growHorizontal child+  let initSt = VFixed maxHeight child+  wRef <- newWidget initSt $ \w ->+      w { growHorizontal_ = const $ growHorizontal child          , render_ = \this s ctx -> do                    VFixed height ch <- getState this-                   let region = s `withHeight` fromIntegral (min (toEnum height) (region_height s))+                   let region = s `withHeight` fromIntegral (min (toEnum height) (regionHeight s))                    img <- render ch region ctx                    -- Pad the image if it's smaller than the region.-                   let img' = if image_height img < region_height region-                              then img <-> (char_fill (getNormalAttr ctx) ' '-                                            (region_width region)-                                            (region_height region - image_height img))+                   let img' = if imageHeight img < regionHeight region+                              then img <-> (charFill (getNormalAttr ctx) ' '+                                            1+                                            (toEnum height - imageHeight img))                               else img                    return img' @@ -82,6 +86,10 @@             \this pos -> do               VFixed _ ch <- getState this               setCurrentPosition ch pos++        , getCursorPosition_ = \this -> do+              VFixed _ ch <- getState this+              getCursorPosition ch         }   wRef `relayKeyEvents` child   wRef `relayFocusEvents` child@@ -123,10 +131,10 @@   (HFixed lim _) <- state <~ wRef   return lim --- |Impose a maximum horizontal and vertical size on a widget.+-- |Impose a fixed horizontal and vertical size on a widget. boxFixed :: (Show a) =>-            Int -- ^Maximum width in columns-         -> Int -- ^Maximum height in rows+            Int -- ^Width in columns+         -> Int -- ^Height in rows          -> Widget a          -> IO (Widget (VFixed (HFixed a))) boxFixed maxWidth maxHeight w = do
src/Graphics/Vty/Widgets/Group.hs view
@@ -13,7 +13,7 @@ where  import Control.Monad ( when )-import Graphics.Vty ( empty_image )+import Graphics.Vty ( emptyImage ) import Graphics.Vty.Widgets.Core  -- |A group of widgets of a specified type.@@ -31,15 +31,19 @@ -- |Create a new empty widget group. newGroup :: (Show a) => IO (Widget (Group a)) newGroup = do-  wRef <- newWidget $ \w ->-      w { state = Group { entries = []-                        , currentEntryNum = -1-                        }--        , getCursorPosition_ =+  let initSt = Group { entries = []+                     , currentEntryNum = -1+                     }+  wRef <- newWidget initSt $ \w ->+      w { getCursorPosition_ =             \this ->                 getCursorPosition =<< currentEntry this +        , setCurrentPosition_ =+            \this pos -> do+                e <- currentEntry this+                setCurrentPosition e pos+         , growHorizontal_ =             \this ->                 growHorizontal $ currentEntry' this@@ -61,7 +65,7 @@         , render_ = \this sz ctx -> do                       cur <- currentEntryNum <~~ this                       case cur of-                        (-1) -> return empty_image+                        (-1) -> return emptyImage                         _ -> do                           e <- currentEntry this                           render e sz ctx
src/Graphics/Vty/Widgets/Limits.hs view
@@ -21,7 +21,6 @@ where  import Control.Monad-import Graphics.Vty import Graphics.Vty.Widgets.Core import Graphics.Vty.Widgets.Util @@ -33,19 +32,23 @@ -- |Impose a maximum horizontal size, in columns, on a 'Widget'. hLimit :: (Show a) => Int -> Widget a -> IO (Widget (HLimit a)) hLimit maxWidth child = do-  wRef <- newWidget $ \w ->-      w { state = HLimit maxWidth child-        , growHorizontal_ = const $ return False+  let initSt = HLimit maxWidth child+  wRef <- newWidget initSt $ \w ->+      w { growHorizontal_ = const $ return False         , growVertical_ = const $ growVertical child         , render_ = \this s ctx -> do                    HLimit width ch <- getState this-                   let region = s `withWidth` fromIntegral (min (toEnum width) (region_width s))+                   let region = s `withWidth` fromIntegral (min (toEnum width) (regionWidth s))                    render ch region ctx          , setCurrentPosition_ =             \this pos -> do               HLimit _ ch <- getState this               setCurrentPosition ch pos++        , getCursorPosition_ = \this -> do+              HLimit _ ch <- getState this+              getCursorPosition ch         }   wRef `relayKeyEvents` child   wRef `relayFocusEvents` child@@ -59,20 +62,24 @@ -- |Impose a maximum vertical size, in columns, on a 'Widget'. vLimit :: (Show a) => Int -> Widget a -> IO (Widget (VLimit a)) vLimit maxHeight child = do-  wRef <- newWidget $ \w ->-      w { state = VLimit maxHeight child-        , growHorizontal_ = const $ growHorizontal child+  let initSt = VLimit maxHeight child+  wRef <- newWidget initSt $ \w ->+      w { growHorizontal_ = const $ growHorizontal child         , growVertical_ = const $ return False          , render_ = \this s ctx -> do                    VLimit height ch <- getState this-                   let region = s `withHeight` fromIntegral (min (toEnum height) (region_height s))+                   let region = s `withHeight` fromIntegral (min (toEnum height) (regionHeight s))                    render ch region ctx          , setCurrentPosition_ =             \this pos -> do               VLimit _ ch <- getState this               setCurrentPosition ch pos++        , getCursorPosition_ = \this -> do+              VLimit _ ch <- getState this+              getCursorPosition ch         }   wRef `relayKeyEvents` child   wRef `relayFocusEvents` child
src/Graphics/Vty/Widgets/List.hs view
@@ -14,15 +14,19 @@     , SelectionEvent(..)     , ActivateItemEvent(..)     -- ** List creation-    , newStringList+    , newTextList     , newList     , addToList     , insertIntoList     , removeFromList+    , setSelectedFocusedAttr+    , setSelectedUnfocusedAttr     -- ** List manipulation     , scrollBy     , scrollUp     , scrollDown+    , scrollToEnd+    , scrollToBeginning     , pageUp     , pageDown     , onSelectionChange@@ -33,6 +37,10 @@     , clearList     , setSelected     -- ** List inspection+    , listFindFirst+    , listFindFirstBy+    , listFindAll+    , listFindAllBy     , getListSize     , getSelected     , getListItem@@ -42,9 +50,13 @@ 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 import Graphics.Vty.Widgets.Text+import Graphics.Vty.Widgets.Fixed+import Graphics.Vty.Widgets.Limits import Graphics.Vty.Widgets.Events import Graphics.Vty.Widgets.Util @@ -52,9 +64,6 @@                -- ^The specified position could not be used to remove                -- an item from the list.                | ResizeError-               | BadListWidgetSizePolicy-               -- ^The type of widgets added to the list grow-               -- vertically, which is not permitted.                  deriving (Show, Typeable)  instance Exception ListError@@ -87,57 +96,60 @@ -- /value type/ @a@, the type of internal values used to refer to the -- visible representations of the list contents, and the /widget type/ -- @b@, the type of widgets used to represent the list visually.-data List a b = List { selectedUnfocusedAttr :: Attr-                     , selectedIndex :: Int+data List a b = List { selectedUnfocusedAttr :: Maybe Attr+                     , selectedFocusedAttr :: Maybe Attr+                     , selectedIndex :: !Int                      -- ^The currently selected list index.-                     , scrollTopIndex :: Int+                     , scrollTopIndex :: !Int                      -- ^The start index of the window of visible list                      -- items.-                     , scrollWindowSize :: Int+                     , scrollWindowSize :: !Int                      -- ^The size of the window of visible list items.-                     , listItems :: [ListItem a b]+                     , listItems :: V.Vector (ListItem a b)                      -- ^The items in the list.                      , selectionChangeHandlers :: Handlers (SelectionEvent a b)                      , itemAddHandlers :: Handlers (NewItemEvent a b)                      , itemRemoveHandlers :: Handlers (RemoveItemEvent a b)                      , itemActivateHandlers :: Handlers (ActivateItemEvent a b)-                     , itemHeight :: Int+                     , itemHeight :: !Int                      }  instance Show (List a b) where     show lst = concat [ "List { "                       , "selectedUnfocusedAttr = ", show $ selectedUnfocusedAttr lst+                      , ", selectedFocusedAttr = ", show $ selectedFocusedAttr lst                       , ", selectedIndex = ", show $ selectedIndex lst                       , ", scrollTopIndex = ", show $ scrollTopIndex lst                       , ", scrollWindowSize = ", show $ scrollWindowSize lst-                      , ", listItems = <", show $ length $ listItems lst, " items>"+                      , ", listItems = <", show $ V.length $ listItems lst, " items>"                       , ", itemHeight = ", show $ itemHeight lst                       , " }"                       ] -newListData :: Attr -- ^The attribute of the selected item+newListData :: Int -- ^Item widget height in rows             -> IO (List a b)-newListData selAttr = do+newListData h = do   schs <- newHandlers   iahs <- newHandlers   irhs <- newHandlers   iacths <- newHandlers -  return $ List { selectedUnfocusedAttr = selAttr+  return $ List { selectedUnfocusedAttr = Nothing+                , selectedFocusedAttr = Nothing                 , selectedIndex = -1                 , scrollTopIndex = 0                 , scrollWindowSize = 0-                , listItems = []+                , listItems = V.empty                 , selectionChangeHandlers = schs                 , itemAddHandlers = iahs                 , itemRemoveHandlers = irhs                 , itemActivateHandlers = iacths-                , itemHeight = 0+                , itemHeight = h                 }  -- |Get the length of the list in elements. getListSize :: Widget (List a b) -> IO Int-getListSize = ((length . listItems) <~~)+getListSize = ((V.length . listItems) <~~)  -- |Remove an element from the list at the specified position.  May -- throw 'BadItemIndex'.@@ -146,14 +158,14 @@   st <- getState list   foc <- focused <~ list -  let numItems = length $ listItems st+  let numItems = V.length $ listItems st       oldScr = scrollTopIndex st    when (pos < 0 || pos >= numItems) $        throw $ BadItemIndex pos    -- Get the item from the list.-  let (label, w) = listItems st !! pos+  let (label, w) = (listItems st) V.! pos       sel = selectedIndex st        newScrollTop = if pos <= oldScr@@ -178,8 +190,8 @@                                         else sel    updateWidgetState list $ \s -> s { selectedIndex = newSelectedIndex-                                   , listItems = take pos (listItems st) ++-                                                 drop (pos + 1) (listItems st)+                                   , listItems = V.take pos (listItems st) V.+++                                                 V.drop (pos + 1) (listItems st)                                    , scrollTopIndex = newScrollTop                                    } @@ -207,35 +219,31 @@   -- Return the removed item.   return (label, w) +-- |Sets the attributes to be merged on the selected list item when the list+-- widget has the focus.+setSelectedFocusedAttr :: Widget (List a b) -> Maybe Attr -> IO ()+setSelectedFocusedAttr w attr = do+  updateWidgetState w $ \l -> l { selectedFocusedAttr = attr }++-- |Sets the attributes to be merged on the selected list item when the list+-- widget does not have the focus.+setSelectedUnfocusedAttr :: Widget (List a b) -> Maybe Attr -> IO ()+setSelectedUnfocusedAttr w attr = do+  updateWidgetState w $ \l -> l { selectedUnfocusedAttr = attr }+ -- |Add an item to the list.  Its widget will be constructed from the -- specified internal value using the widget constructor passed to -- 'newList'. addToList :: (Show b) => Widget (List a b) -> a -> Widget b -> IO () addToList list key w = do-  numItems <- (length . listItems) <~~ list+  numItems <- (V.length . listItems) <~~ list   insertIntoList list key w numItems  -- |Insert an element into the list at the specified position.  If the -- position exceeds the length of the list, it is inserted at the end. insertIntoList :: (Show b) => Widget (List a b) -> a -> Widget b -> Int -> IO () insertIntoList list key w pos = do-  numItems <- (length . listItems) <~~ list--  v <- growVertical w-  when (v) $ throw BadListWidgetSizePolicy--  h <- case numItems of-         0 -> do-           -- We're adding the first element to the list, so we need-           -- to compute the item height based on this widget.  We-           -- just render it in an unreasonably large space (since,-           -- really, list items should never be THAT big) and measure-           -- the result, assuming that all list widgets will have the-           -- same size.  If you violate this, you'll have interesting-           -- results!-           img <- render w (DisplayRegion 100 100) defaultContext-           return $ max 1 $ fromEnum $ image_height img-         _ -> itemHeight <~~ list+  numItems <- (V.length . listItems) <~~ list    -- Calculate the new selected index.   oldSel <- selectedIndex <~~ list@@ -253,13 +261,20 @@                           else oldScr                      else oldScr -  updateWidgetState list $ \s -> s { itemHeight = h-                                   , listItems = inject pos (key, w) (listItems s)+  let vInject atPos a as = let (hd, t) = (V.take atPos as, V.drop atPos as)+                           in hd V.++ (V.cons a t)++  -- Optimize the append case.+  let newItems s = if pos >= numItems+                   then V.snoc (listItems s) (key, w)+                   else vInject pos (key, w) (listItems s)++  updateWidgetState list $ \s -> s { listItems = V.force $ newItems s                                    , selectedIndex = newSelIndex                                    , scrollTopIndex = newScrollTop                                    } -  notifyItemAddHandler list (numItems + 1) key w+  notifyItemAddHandler list (min numItems pos) key w    when (numItems == 0) $        do@@ -291,7 +306,7 @@ -- which happens when the user presses Enter on a selected element -- while the list has the focus. onItemActivated :: Widget (List a b)-            -> (ActivateItemEvent a b -> IO ()) -> IO ()+                -> (ActivateItemEvent a b -> IO ()) -> IO () onItemActivated = addHandler (itemActivateHandlers <~~)  -- |Clear the list, removing all elements.  Does not invoke any@@ -301,19 +316,18 @@   updateWidgetState w $ \l ->       l { selectedIndex = (-1)         , scrollTopIndex = 0-        , listItems = []+        , listItems = V.empty         } --- |Create a new list using the specified attribute for the--- currently-selected element when the list does NOT have focus.+-- |Create a new list.  The list's item widgets will be rendered using the+-- specified height in rows. newList :: (Show b) =>-           Attr -- ^The attribute of the selected item+           Int -- ^Height of list item widgets in rows         -> IO (Widget (List a b))-newList selAttr = do-  list <- newListData selAttr-  wRef <- newWidget $ \w ->-      w { state = list-        , keyEventHandler = listKeyEvent+newList ht = do+  list <- newListData ht+  wRef <- newWidget list $ \w ->+      w { keyEventHandler = listKeyEvent          , growVertical_ = const $ return True         , growHorizontal_ = const $ return True@@ -334,12 +348,9 @@               -- Resize the list based on the available space and the               -- height of each item.               when (h > 0) $-                   resize this (max 1 ((fromEnum $ region_height sz) `div` h))--              listData <- getState this-              foc <- focused <~ this+                   resizeList this (max 1 ((fromEnum $ regionHeight sz) `div` h)) -              renderListWidget foc listData sz ctx+              renderListWidget this sz ctx          , setCurrentPosition_ =             \this pos -> do@@ -377,9 +388,14 @@     Nothing -> return False     Just (_, (_, e)) -> handleKeyEvent e k mods -renderListWidget :: (Show b) => Bool -> List a b -> DisplayRegion -> RenderContext -> IO Image-renderListWidget foc list s ctx = do+renderListWidget :: (Show b) => Widget (List a b) -> DisplayRegion -> RenderContext -> IO Image+renderListWidget this s ctx = do+  list <- getState this+  foc <- focused <~ this+   let items = map (\((_, w), sel) -> (w, sel)) $ getVisibleItems_ list+      childSelFocAttr   = (maybe (focusAttr ctx) id) $ selectedFocusedAttr list+      childSelUnfocAttr = (maybe (focusAttr ctx) id) $ selectedUnfocusedAttr list       defaultAttr = mergeAttrs [ overrideAttr ctx                                , normalAttr ctx                                ]@@ -388,37 +404,39 @@       renderVisible ((w, sel):ws) = do         let att = if sel                   then if foc-                       then focusAttr ctx-                       else mergeAttrs [ selectedUnfocusedAttr list-                                       , defaultAttr-                                       ]+                       then mergeAttrs [ childSelFocAttr, defaultAttr ]+                       else mergeAttrs [ childSelUnfocAttr, defaultAttr ]                   else defaultAttr-        img <- render w s $ ctx { overrideAttr = att } -        let actualHeight = min (region_height s) (toEnum $ itemHeight list)-            img' = img <|> char_fill att ' '-                   (region_width s - image_width img)+        -- Height-limit the widget by wrapping it with a VFixed/VLimit+        limited <- vLimit (itemHeight list) =<< vFixed (itemHeight list) w++        img <- render limited s $ ctx { overrideAttr = att }++        let actualHeight = min (regionHeight s) (toEnum $ itemHeight list)+            img' = img <|> charFill att ' '+                   (regionWidth s - imageWidth img)                    actualHeight         imgs <- renderVisible ws         return (img':imgs) -  let filler = char_fill defaultAttr ' ' (region_width s) fill_height+  let filler = charFill defaultAttr ' ' (regionWidth s) fill_height       fill_height = if scrollWindowSize list == 0-                    then region_height s+                    then regionHeight s                     else toEnum $ ((scrollWindowSize list - length items) * itemHeight list)    visible_imgs <- renderVisible items -  return $ vert_cat (visible_imgs ++ [filler])+  return $ vertCat (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-  list <- newList selAttr+newTextList :: [T.Text] -- ^The list items+            -> Int -- ^Maximum number of rows of text to show per list item+            -> IO (Widget (List T.Text FormattedText))+newTextList labels h = do+  list <- newList h   forM_ labels $ \l ->       (addToList list l =<< plainText l)   return list@@ -441,15 +459,15 @@   list <- state <~ wRef   case selectedIndex list of     (-1) -> return Nothing-    i -> return $ Just (i, (listItems list) !! i)+    i -> return $ Just (i, (listItems list) V.! i)  -- |Get the list item at the specified position. getListItem :: Widget (List a b) -> Int -> IO (Maybe (ListItem a b)) getListItem wRef pos = do   list <- state <~ wRef-  case pos >= 0 && pos < (length $ listItems list) of+  case pos >= 0 && pos < (V.length $ listItems list) of     False ->  return Nothing-    True -> return $ Just ((listItems list) !! pos)+    True -> return $ Just ((listItems list) V.! pos)  -- |Set the currently-selected list index. setSelected :: Widget (List a b) -> Int -> IO ()@@ -459,8 +477,34 @@     (-1) -> return ()     curPos -> scrollBy wRef (newPos - curPos) -resize :: Widget (List a b) -> Int -> IO ()-resize wRef newSize = do+-- |Find the first index of the specified key in the list.  If the key does not+-- exist, return Nothing.+listFindFirst :: (Eq a) => Widget (List a b) -> a -> IO (Maybe Int)+listFindFirst wRef item = listFindFirstBy (== item) wRef++-- |Find the first index in the list for which the predicate is true.+-- If no item in the list matches the given predicate, return Nothing.+listFindFirstBy :: (a -> Bool) -> Widget (List a b) -> IO (Maybe Int)+listFindFirstBy p wRef = do+  list <- state <~ wRef+  return $ V.findIndex matcher (listItems list)+  where+    matcher = \(match, _) -> p match++-- |Find all indicies of the specified key in the list.+listFindAll :: (Eq a) => Widget (List a b) -> a -> IO [Int]+listFindAll wRef item = listFindAllBy (== item) wRef++-- |Find all indices in the list matching the given predicate.+listFindAllBy :: (a -> Bool) -> Widget (List a b) -> IO [Int]+listFindAllBy p wRef = do+  list <- state <~ wRef+  return $ V.toList $ V.findIndices matcher (listItems list)+  where+    matcher = \(match, _) -> p match++resizeList :: Widget (List a b) -> Int -> IO ()+resizeList wRef newSize = do   when (newSize == 0) $ throw ResizeError    size <- (scrollWindowSize . state) <~ wRef@@ -514,20 +558,22 @@   notifySelectionHandler wRef  scrollBy' :: Int -> List a b -> List a b-scrollBy' amount list =-  let sel = selectedIndex list-      lastPos = (length $ listItems list) - 1-      validPositions = [0..lastPos]-      newPosition = sel + amount--      newSelected = if newPosition `elem` validPositions-                    then newPosition-                    else if newPosition > lastPos-                         then lastPos-                         else 0+scrollBy' amt list =+    case selectedIndex list of+        (-1) -> list+        i -> let dest = i + amt+                 sz = V.length $ listItems list+                 newDest = if dest < 0+                           then 0+                           else if dest >= sz+                                then sz - 1+                                else dest+             in scrollTo newDest list -      bottomPosition = min (scrollTopIndex list + scrollWindowSize list - 1)-                       ((length $ listItems list) - 1)+scrollTo :: Int -> List a b -> List a b+scrollTo newSelected list =+  let bottomPosition = min (scrollTopIndex list + scrollWindowSize list - 1)+                       ((V.length $ listItems list) - 1)       topPosition = scrollTopIndex list       windowPositions = [topPosition..bottomPosition] @@ -537,11 +583,12 @@                          then newSelected - scrollWindowSize list + 1                          else newSelected -  in if scrollWindowSize list == 0-     then list-     else list { scrollTopIndex = adjustedTop-               , selectedIndex = newSelected }+  in list { scrollTopIndex = adjustedTop+          , selectedIndex = newSelected+          } ++ notifySelectionHandler :: Widget (List a b) -> IO () notifySelectionHandler wRef = do   sel <- getSelected wRef@@ -559,6 +606,23 @@ notifyItemAddHandler wRef pos k w =     fireEvent wRef (itemAddHandlers <~~) $ NewItemEvent pos k w +-- |Scroll to the last list position.+scrollToEnd :: Widget (List a b) -> IO ()+scrollToEnd wRef = do+    cur <- getSelected wRef+    sz <- getListSize wRef+    case cur of+        Nothing -> return ()+        Just (pos, _) -> scrollBy wRef (sz - pos)++-- |Scroll to the first list position.+scrollToBeginning :: Widget (List a b) -> IO ()+scrollToBeginning wRef = do+    cur <- getSelected wRef+    case cur of+        Nothing -> return ()+        Just (pos, _) -> scrollBy wRef (-1 * pos)+ -- |Scroll a list down by one position. scrollDown :: Widget (List a b) -> IO () scrollDown wRef = scrollBy wRef 1@@ -588,6 +652,6 @@ getVisibleItems_ list =     let start = scrollTopIndex list         stop = scrollTopIndex list + scrollWindowSize list-        adjustedStop = (min stop $ length $ listItems list) - 1-    in [ (listItems list !! i, i == selectedIndex list)+        adjustedStop = (min stop $ V.length $ listItems list) - 1+    in [ (listItems list V.! i, i == selectedIndex list)              | i <- [start..adjustedStop] ]
src/Graphics/Vty/Widgets/Padding.hs view
@@ -19,7 +19,6 @@     ) where -import Data.Word import Data.Monoid import Graphics.Vty import Graphics.Vty.Widgets.Core@@ -53,16 +52,16 @@ instance Paddable Padding where     pad p1 p2 = p1 +++ p2 -leftPadding :: Padding -> Word+leftPadding :: Padding -> Int leftPadding (Padding _ _ _ l) = toEnum l -rightPadding :: Padding -> Word+rightPadding :: Padding -> Int rightPadding (Padding _ r _ _) = toEnum r -bottomPadding :: Padding -> Word+bottomPadding :: Padding -> Int bottomPadding (Padding _ _ b _) = toEnum b -topPadding :: Padding -> Word+topPadding :: Padding -> Int topPadding (Padding t _ _ _) = toEnum t  -- |Padding constructor with no padding.@@ -105,26 +104,27 @@ -- |Create a 'Padded' wrapper to add padding. padded :: (Show a) => Widget a -> Padding -> IO (Widget Padded) padded ch padding = do-  wRef <- newWidget $ \w ->-      w { state = Padded ch padding--        , growVertical_ = const $ growVertical ch+  let initSt = Padded ch padding+  wRef <- newWidget initSt $ \w ->+      w { growVertical_ = const $ growVertical ch         , growHorizontal_ = const $ growHorizontal ch          , render_ =-            \this sz ctx ->-                if (region_width sz < 2) || (region_height sz < 2)-                then return empty_image-                else do-                  Padded child p <- getState this+            \this sz ctx -> do+                Padded child p <- getState this++                if (regionWidth sz < leftPadding p + rightPadding p) ||+                   (regionHeight sz < bottomPadding p + topPadding p) then+                  return emptyImage else+                 do                   f <- focused <~ this                    -- Compute constrained space based on padding                   -- settings.                   let constrained = sz `withWidth` (toEnum $ max 0 newWidth)                                     `withHeight` (toEnum $ max 0 newHeight)-                      newWidth = (fromEnum $ region_width sz) - fromEnum (leftPadding p + rightPadding p)-                      newHeight = (fromEnum $ region_height sz) - fromEnum (topPadding p + bottomPadding p)+                      newWidth = (fromEnum $ regionWidth sz) - fromEnum (leftPadding p + rightPadding p)+                      newHeight = (fromEnum $ regionHeight sz) - fromEnum (topPadding p + bottomPadding p)                       attr = mergeAttrs [ if f then focusAttr ctx else overrideAttr ctx                                         , normalAttr ctx                                         ]@@ -133,11 +133,11 @@                   img <- render child constrained ctx                    -- Create padding images.-                  let leftImg = char_fill attr ' ' (leftPadding p) (image_height img)-                      rightImg = char_fill attr ' ' (rightPadding p) (image_height img)-                      topImg = char_fill attr ' ' (image_width img + leftPadding p + rightPadding p)+                  let leftImg = charFill attr ' ' (leftPadding p) (imageHeight img)+                      rightImg = charFill attr ' ' (rightPadding p) (imageHeight img)+                      topImg = charFill attr ' ' (imageWidth img + leftPadding p + rightPadding p)                                (topPadding p)-                      bottomImg = char_fill attr ' ' (image_width img + leftPadding p + rightPadding p)+                      bottomImg = charFill attr ' ' (imageWidth img + leftPadding p + rightPadding p)                                   (bottomPadding p)                    return $ topImg <-> (leftImg <|> img <|> rightImg) <-> bottomImg@@ -154,6 +154,9 @@                setCurrentPosition child newPos +        , getCursorPosition_ = \this -> do+              Padded child _ <- getState this+              getCursorPosition child         }    wRef `relayKeyEvents` ch
src/Graphics/Vty/Widgets/ProgressBar.hs view
@@ -1,68 +1,147 @@ -- |This module provides a ''progress bar'' widget which stores a--- progress value between 0 and 100 inclusive.  Use the 'schedule'--- function to modify the progress bar's state from a thread.+-- progress value between 0 and 100 inclusive and supports a text+-- label.  Use the 'schedule' function to modify the progress bar's+-- state from a thread. module Graphics.Vty.Widgets.ProgressBar     ( ProgressBar     , newProgressBar-    , progressBarWidget     , setProgress+    , setProgressTextAlignment+    , setProgressText     , addProgress     , getProgress     , onProgressChange     ) where -import Data.IORef import Control.Monad-import Control.Monad.Trans+import qualified Data.Text as T import Graphics.Vty import Graphics.Vty.Widgets.Core-import Graphics.Vty.Widgets.Fills-import Graphics.Vty.Widgets.Box 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 { progressBarWidget :: Widget (Box HFill HFill)-                               -- ^Get the widget of a progress bar.-                               , progressBarAmount :: IORef Int+data ProgressBar = ProgressBar { progressBarAmount :: Int                                , onChangeHandlers :: Handlers Int+                               , progressBarText :: T.Text+                               , progressBarTextAlignment :: Alignment+                               , progCompleteAttr :: Attr+                               , progIncompleteAttr :: Attr+                               , progTextWidget :: Widget FormattedText                                } +instance Show ProgressBar where+    show p = concat [ "ProgressBar { "+                    , ", " ++ (show $ progressBarAmount p)+                    , ", ... }"+                    ]+ -- |Create a new progress bar with the specified completed and--- uncompleted colors, respectively.-newProgressBar :: Color -> Color -> IO ProgressBar-newProgressBar completeColor incompleteColor = do-  let completeAttr = completeColor `on` completeColor-      incompleteAttr = incompleteColor `on` incompleteColor+-- uncompleted attributes, respectively.  The foreground of the+-- attributes will be used to show the progress bar's label, if any.+newProgressBar :: Attr -> Attr -> IO (Widget ProgressBar)+newProgressBar completeAttr incompleteAttr = do+  chs <- newHandlers+  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 -> renderProgressBar size ctx =<< getState this+            , getCursorPosition_ = const $ return Nothing+            } -  w <- (hFill ' ' 1 >>= withNormalAttribute completeAttr) <++>-       (hFill ' ' 1 >>= withNormalAttribute incompleteAttr)-  r <- liftIO $ newIORef 0-  hs <- newHandlers-  let p = ProgressBar w r hs-  setProgress p 0-  return p+  setProgress wRef 0+  return wRef +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++      complete_width =+          Phys $ fromEnum $ (toRational prog / toRational (100.0 :: Double)) *+                   (toRational $ fromEnum $ regionWidth size)++      full_width = Phys $ fromEnum $ regionWidth size+      full_str = truncateText full_width $ mkStr txt al++      mkStr s AlignLeft =+          let diff = fromEnum $ full_width - textWidth txt+          in T.concat [ s+                      , T.pack $ replicate diff ' '+                      ]++      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 :: ProgressBar -> (Int -> IO ()) -> IO ()-onProgressChange = addHandler (return . onChangeHandlers)+onProgressChange :: Widget ProgressBar -> (Int -> IO ()) -> IO ()+onProgressChange = addHandler (onChangeHandlers <~~)  -- |Set the progress bar's progress value.  Values outside the allowed -- range will be ignored.-setProgress :: ProgressBar -> Int -> IO ()+setProgress :: Widget ProgressBar -> Int -> IO () setProgress p amt =     when (amt >= 0 && amt <= 100) $ do-      liftIO $ writeIORef (progressBarAmount p) amt-      setBoxChildSizePolicy (progressBarWidget p) $ Percentage amt-      fireEvent p (return . onChangeHandlers) amt+      updateWidgetState p $ \st -> st { progressBarAmount = amt }+      fireEvent p (onChangeHandlers <~~) amt +-- |Set the progress bar's text label alignment.+setProgressTextAlignment :: Widget ProgressBar -> Alignment -> IO ()+setProgressTextAlignment p al =+    updateWidgetState p $ \st -> st { progressBarTextAlignment = al }++-- |Set the progress bar's text label.+setProgressText :: Widget ProgressBar -> T.Text -> IO ()+setProgressText p s =+    updateWidgetState p $ \st -> st { progressBarText = s }+ -- |Get the progress bar's current progress value.-getProgress :: ProgressBar -> IO Int-getProgress = liftIO . readIORef . progressBarAmount+getProgress :: Widget ProgressBar -> IO Int+getProgress = (progressBarAmount <~~)  -- |Add a delta value to the progress bar's current value.-addProgress :: ProgressBar -> Int -> IO ()+addProgress :: Widget ProgressBar -> Int -> IO () addProgress p amt = do   cur <- getProgress p   let newAmt = cur + amt
src/Graphics/Vty/Widgets/Table.hs view
@@ -12,8 +12,6 @@     , RowLike(..)     , TableError(..)     , ColumnSpec(..)-    , Alignment(..)-    , Alignable(..)     , (.|.)     , newTable     , setDefaultCellAlignment@@ -28,8 +26,8 @@ where  import Data.Monoid+import qualified Data.Text as T import Data.Typeable-import Data.Word import Data.List import Control.Applicative hiding ((<|>)) import Control.Exception@@ -44,6 +42,7 @@ import Graphics.Vty.Widgets.Util import Graphics.Vty.Widgets.Fills import Graphics.Vty.Widgets.Box+import Graphics.Vty.Widgets.Alignment  data TableError = ColumnCountMismatch                 -- ^A row added to the table did not have the same@@ -58,14 +57,6 @@  instance Exception TableError --- |Column alignment values.-data Alignment = AlignCenter | AlignLeft | AlignRight-                 deriving (Show)---- |The class of types whose values can be aligned.-class Alignable a where-    align :: a -> Alignment -> a- -- |The wrapper type for all table cells; stores the widgets -- themselves in addition to alignment and padding settings. -- Alignment and padding settings on a cell override the column- and@@ -216,22 +207,21 @@  -- |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-  t <- newWidget $ \w ->-      w { state = Table { rows = []-                        , columnSpecs = specs-                        , borderStyle = borderSty-                        , numColumns = length specs-                        , borderAttr = def_attr-                        , defaultCellAlignment = AlignLeft-                        , defaultCellPadding = padNone-                        }+  let initSt = Table { rows = []+                     , columnSpecs = specs+                     , borderStyle = borderSty+                     , numColumns = length specs+                     , borderAttr = defAttr+                     , defaultCellAlignment = AlignLeft+                     , defaultCellPadding = padNone+                     } -        , growHorizontal_ = \st -> do+  t <- newWidget initSt $ \w ->+      w { growHorizontal_ = \st -> do             return $ any (== ColAuto) (map columnSize $ columnSpecs st)          , render_ =@@ -247,21 +237,21 @@               sideBorderL <- mkSideBorder this ctx True               sideBorderR <- mkSideBorder this ctx False -              let body = vert_cat $ intersperse rowBorder rowImgs-                  withTBBorders = vert_cat [topBorder, body, bottomBorder]-                  withSideBorders = horiz_cat [sideBorderL, withTBBorders, sideBorderR]+              let body = vertCat $ intersperse rowBorder rowImgs+                  withTBBorders = vertCat [topBorder, body, bottomBorder]+                  withSideBorders = horizCat [sideBorderL, withTBBorders, sideBorderR]                -- Ideally, we would only display rows that we have room               -- to render, but this is a much easier cop-out. :)-              if ((region_width sz < image_width withSideBorders) ||-                  (region_height sz < image_height withSideBorders)) then-                  return empty_image else+              if ((regionWidth sz < imageWidth withSideBorders) ||+                  (regionHeight sz < imageHeight withSideBorders)) then+                  return emptyImage else                   return withSideBorders          , setCurrentPosition_ =             \this pos -> do               sz <- getCurrentSize this-              if region_width sz == 0 || region_height sz == 0 then+              if regionWidth sz == 0 || regionHeight sz == 0 then                   return () else                   do                     bs <- borderStyle <~~ this@@ -281,7 +271,7 @@                             cellPhysSizes <- forM row $ \cell ->                                              case cell of                                                TableCell cw _ _ -> getCurrentSize cw-                                               EmptyCell -> return $ DisplayRegion 0 1+                                               EmptyCell -> return (0, 1)                              -- Include 1 as a possible height to                             -- prevent zero-height images from@@ -289,7 +279,7 @@                             -- won't hurt in the case where other                             -- cells are bigger, since their heights                             -- will be chosen instead.-                            let maxSize = maximum $ 1 : map region_height cellPhysSizes+                            let maxSize = maximum $ 1 : map regionHeight cellPhysSizes                                 borderOffset = if rowBorders bs                                                then 1 else 0 @@ -298,7 +288,7 @@                             positionRow this bs rowPos row                             positionRows (height + maxSize + borderOffset) rest -                    positionRows (region_height pos + edgeOffset) rs+                    positionRows (regionHeight pos + edgeOffset) rs         }   return t @@ -331,7 +321,7 @@   bs <- borderStyle <~~ t    if not $ rowBorders bs then-      return empty_image else+      return emptyImage else       mkRowBorder_ t sz ctx intChar  -- Make a row border that matches the width of each row but does not@@ -352,13 +342,13 @@       intersection = string bAttr' [intChar]       imgs = (flip map) szs $ \s ->              case s of-               ColFixed n -> char_fill bAttr' (skinHorizontal sk) n 1-               ColAuto -> char_fill bAttr' (skinHorizontal sk) aw 1+               ColFixed n -> charFill bAttr' (skinHorizontal sk) n 1+               ColAuto -> charFill bAttr' (skinHorizontal sk) aw 1       imgs' = if colBorders bs               then intersperse intersection imgs               else imgs -  return $ horiz_cat imgs'+  return $ horizCat imgs'  mkTopBottomBorder :: Widget Table -> DisplayRegion -> RenderContext -> Char -> IO Image mkTopBottomBorder t sz ctx intChar = do@@ -366,7 +356,7 @@    if edgeBorders bs then       mkRowBorder_ t sz ctx intChar else-      return empty_image+      return emptyImage  -- Make vertical side borders for the table, including row border -- intersections if necessary.@@ -376,7 +366,7 @@    if edgeBorders bs then       mkSideBorder_ t ctx isLeft else-      return empty_image+      return emptyImage  mkSideBorder_ :: Widget Table -> RenderContext -> Bool -> IO Image mkSideBorder_ t ctx isLeft = do@@ -405,16 +395,16 @@   rowHeights <- forM rs $ \(TableRow row) -> do                     hs <- forM row $ \cell ->                           case cell of-                            TableCell cw _ _ -> region_height <$> getCurrentSize cw+                            TableCell cw _ _ -> regionHeight <$> getCurrentSize cw                             EmptyCell -> return 1                     return $ maximum hs -  let borderImgs = (flip map) rowHeights $ \h -> char_fill bAttr' (skinVertical sk) 1 h+  let borderImgs = (flip map) rowHeights $ \h -> charFill bAttr' (skinVertical sk) 1 h       withIntersections = if rowBorders bs                           then intersperse intersection borderImgs                           else borderImgs -  return $ vert_cat $ topCorner : withIntersections ++ [bottomCorner]+  return $ vertCat $ topCorner : withIntersections ++ [bottomCorner]  positionRow :: Widget Table -> BorderStyle -> DisplayRegion -> [TableCell] -> IO () positionRow t bs pos cells = do@@ -443,7 +433,7 @@    doPositioning 0 $ zip szs cells -autoWidth :: Widget Table -> DisplayRegion -> IO Word+autoWidth :: Widget Table -> DisplayRegion -> IO Int autoWidth t sz = do   specs <- columnSpecs <~~ t   bs <- borderStyle <~~ t@@ -457,13 +447,13 @@       edgeWidth = if edgeBorders bs then 2 else 0       colWidth = if colBorders bs then (toEnum $ length sizes - 1) else 0 -  return $ toEnum ((max 0 ((fromEnum $ region_width sz) - totalFixed - edgeWidth - colWidth))+  return $ toEnum ((max 0 ((fromEnum $ regionWidth sz) - totalFixed - edgeWidth - colWidth))                    `div` numAuto)  -- |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@@ -471,7 +461,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@@ -532,7 +522,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@@ -552,8 +542,8 @@ rowBorders BorderFull = True rowBorders _ = False -rowHeight :: [Image] -> Word-rowHeight = maximum . map image_height+rowHeight :: [Image] -> Int+rowHeight = maximum . map imageHeight  renderRow :: Widget Table -> DisplayRegion -> [TableCell] -> RenderContext -> IO Image renderRow tbl sz cells ctx = do@@ -572,7 +562,7 @@   cellImgs <-       forM (zip cells sizes) $ \(cellW, sizeSpec) ->           do-            let cellSz = DisplayRegion cellWidth (region_height sz)+            let cellSz = (cellWidth, regionHeight sz)                 cellWidth = case sizeSpec of                               ColFixed n -> toEnum n                               ColAuto -> aw@@ -580,16 +570,16 @@             img <- renderCell cellSz cellW $ ctx { normalAttr = newDefault }             -- Right-pad the image if it isn't big enough to fill the             -- cell.-            case compare (image_width img) (region_width cellSz) of+            case compare (imageWidth img) (regionWidth cellSz) of               EQ -> return img-              LT -> return $ img <|> char_fill att ' '-                       (max 0 (region_width cellSz - image_width img))-                       (max (image_height img) 1)+              LT -> return $ img <|> charFill att ' '+                       (max 0 (regionWidth cellSz - imageWidth img))+                       (max (imageHeight img) 1)               GT -> throw CellImageTooBig    let maxHeight = rowHeight cellImgs       cellImgsBottomPadded = (flip map) cellImgs $ \img ->-                             img <-> char_fill att ' ' (image_width img) (maxHeight - image_height img)+                             img <-> charFill att ' ' (imageWidth img) (maxHeight - imageHeight img)    -- If we need to draw borders in between columns, do that.   let bAttr' = mergeAttrs [ overrideAttr ctx@@ -598,6 +588,6 @@                           ]       withBorders = case colBorders borderSty of                       False -> cellImgsBottomPadded-                      True -> intersperse (char_fill bAttr' (skinVertical sk) 1 maxHeight) cellImgsBottomPadded+                      True -> intersperse (charFill bAttr' (skinVertical sk) 1 maxHeight) cellImgsBottomPadded -  return $ horiz_cat withBorders+  return $ horizCat withBorders
src/Graphics/Vty/Widgets/Text.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}--- |This module provides functionality for rendering 'String's as+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns #-}+-- |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@@ -12,7 +11,11 @@     , textWidget     -- *Setting Widget Contents     , setText+    , appendText+    , prependText     , setTextWithAttrs+    , appendTextWithAttrs+    , prependTextWithAttrs     , setTextFormatter     , setTextAppearFocused     -- *Formatting@@ -24,8 +27,9 @@     ) where +import Control.Applicative import Data.Monoid-import Data.Word+import qualified Data.Text as T import Graphics.Vty import Graphics.Vty.Widgets.Core import Text.Trans.Tokenize@@ -53,9 +57,9 @@ -- |The type of formatted text widget state.  Stores the text itself -- and the formatter used to apply attributes to the text. data FormattedText =-    FormattedText { text :: TextStream Attr-                  , formatter :: Formatter-                  , useFocusAttribute :: Bool+    FormattedText { textContent :: TextStream Attr+                  , formatter :: !Formatter+                  , useFocusAttribute :: !Bool                   }  instance Show FormattedText where@@ -66,16 +70,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,26 +90,27 @@ wrap :: Formatter wrap =     Formatter $ \sz ts -> do-      let width = fromEnum $ region_width sz+      let width = Phys $ fromEnum $ fst 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-  wRef <- newWidget $ \w ->-      w { state = FormattedText { text = TS []-                                , formatter = format-                                , useFocusAttribute = False-                                }-        , getCursorPosition_ = const $ return Nothing+  let initSt = FormattedText { textContent = TS []+                             , formatter = format+                             , useFocusAttribute = False+                             }++  wRef <- newWidget initSt $ \w ->+      w { getCursorPosition_ = const $ return Nothing         , render_ =             \this size ctx -> do               ft <- getState this               f <- focused <~ this               appearFocused <- useFocusAttribute <~~ this-              renderText (text ft) (f && appearFocused) (formatter ft) size ctx+              renderText (textContent ft) (f && appearFocused) (formatter ft) size ctx         }   setText wRef s   return wRef@@ -129,21 +134,59 @@  -- |Set the text value of a 'FormattedText' widget.  The specified -- string will be 'tokenize'd.-setText :: Widget FormattedText -> String -> IO ()-setText wRef s = setTextWithAttrs wRef [(s, def_attr)]+setText :: Widget FormattedText -> T.Text -> IO ()+setText wRef s = setTextWithAttrs wRef [(s, defAttr)] +-- |Append the text value to the text contained in a 'FormattedText' widget.+-- The specified string will be 'tokenize'd.+appendText :: Widget FormattedText -> T.Text -> IO ()+appendText wRef s = appendTextWithAttrs wRef [(s, defAttr)]++-- |Prepend the text value to the text contained in a 'FormattedText' widget.+-- The specified string will be 'tokenize'd.+prependText :: Widget FormattedText -> T.Text -> IO ()+prependText wRef s = prependTextWithAttrs wRef [(s, defAttr)]++-- |Prepend text to the text value of a 'FormattedText' widget directly, in+-- case you have done formatting elsewhere and already have text with+-- 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.+prependTextWithAttrs :: Widget FormattedText -> [(T.Text, Attr)] -> IO ()+prependTextWithAttrs wRef pairs = _setTextWithAttrs wRef pairs f+    where+      f st new = let TS old = textContent st+                 in new ++ old++-- |Append text to the text value of a 'FormattedText' widget directly, in case+-- you have done formatting elsewhere and already have text with 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.+appendTextWithAttrs :: Widget FormattedText -> [(T.Text, Attr)] -> IO ()+appendTextWithAttrs wRef pairs = _setTextWithAttrs wRef pairs f+    where+      f st new = let TS old = textContent st+                 in old ++ new+ -- |Set the text value of a 'FormattedText' widget directly, in case -- you have done formatting elsewhere and already have text with -- 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 wRef pairs = do+setTextWithAttrs :: Widget FormattedText -> [(T.Text, Attr)] -> IO ()+setTextWithAttrs wRef pairs = _setTextWithAttrs wRef pairs (\_ new -> new)++_setTextWithAttrs :: Widget FormattedText+                  -> [(T.Text, Attr)]+                  -> (FormattedText -> [TextStreamEntity Attr] -> [TextStreamEntity Attr])+                  -> IO ()+_setTextWithAttrs wRef pairs f = do   let streams = map (\(s, a) -> tokenize s a) pairs       ts = concat $ map streamEntities streams    updateWidgetState wRef $ \st ->-      st { text = TS ts }+      st { textContent = TS $ f st ts }  -- |Low-level text-rendering routine. renderText :: TextStream Attr@@ -166,18 +209,31 @@                                  ]        lineImgs = map mkLineImg ls+      lineLength l = length $ tokenStr <$> l+      maxLineLength = maximum $ lineLength <$> ls+      emptyLineLength = min (fromEnum $ fst sz) maxLineLength+       ls = map truncLine $ map (map entityToken) $ findLines newText-      truncLine = truncateLine (fromEnum $ region_width sz)+      truncLine = truncateLine (Phys $ fromEnum $ fst sz)++      -- When building images for empty lines, it's critical that we+      -- *don't* use the emptyImage, because that will cause empty+      -- lines to collapse vertically.  Instead, we create line images+      -- using spaces.  When doing this it's important to make them as+      -- wide as the rest of the text because otherwise we could have+      -- weird-looking results with background attributes not+      -- affecting the whole empty line.  We compute the length of the+      -- longest line above and use that to build the 'empty' lines.       mkLineImg line = if null line-                       then char_fill attr' ' ' (region_width sz) (1::Word)-                       else horiz_cat $ map mkTokenImg line-      nullImg = string def_attr ""+                       then charFill attr' ' ' emptyLineLength 1+                       else horizCat $ map mkTokenImg line+      nullImg = string defAttr ""        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+  return $ if snd sz == 0            then nullImg            else if null ls || all null ls                 then nullImg-                else vert_cat $ take (fromEnum $ region_height sz) lineImgs+                else vertCat $ take (fromEnum $ snd sz) lineImgs
+ src/Graphics/Vty/Widgets/TextClip.hs view
@@ -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
+ src/Graphics/Vty/Widgets/TextZipper.hs view
@@ -0,0 +1,306 @@+-- |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+    , lineLengths++    -- *Navigation functions+    , moveCursor+    , insertChar+    , breakLine+    , killToEOL+    , gotoEOL+    , gotoBOL+    , deletePrevChar+    , deleteChar+    , moveRight+    , moveLeft+    , moveUp+    , moveDown+    )+where++import Control.Applicative ((<$>))+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+                    ]++-- |Return the lengths of the lines in the zipper.+lineLengths :: (Monoid a) => TextZipper a -> [Int]+lineLengths tz = (length_ 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
src/Graphics/Vty/Widgets/Util.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-} module Graphics.Vty.Widgets.Util     ( on     , fgColor@@ -12,30 +13,67 @@     , remove     , inject     , repl+    , takeMaxText+    , takeMaxChars+    , chWidth+    , strWidth+    , textWidth+    , regionWidth+    , regionHeight+    , Phys(..)     ) where -import Data.Word+import Control.Applicative+import qualified Data.Text as T import Graphics.Vty +-- 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 . safeWcwidth++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. on :: Color -> Color -> Attr-on a b = def_attr `with_back_color` b `with_fore_color` a+on a b = defAttr `withBackColor` b `withForeColor` a  -- |Foreground-only attribute constructor.  Background color and style -- are defaulted. fgColor :: Color -> Attr-fgColor = (def_attr `with_fore_color`)+fgColor = (defAttr `withForeColor`)  -- |Background-only attribute constructor.  Foreground color and style -- are defaulted. bgColor :: Color -> Attr-bgColor = (def_attr `with_back_color`)+bgColor = (defAttr `withBackColor`)  -- |Style-only attribute constructor.  Colors are defaulted. style :: Style -> Attr-style = (def_attr `with_style`)+style = (defAttr `withStyle`)  -- Left-most attribute's fields take precedence. -- |Merge two attributes.  Leftmost attribute takes precedence where@@ -44,49 +82,55 @@ -- style mask will take precedence if any are set. mergeAttr :: Attr -> Attr -> Attr mergeAttr a b =-    let b1 = case attr_style a of-               SetTo v -> b { attr_style = SetTo v }+    let b1 = case attrStyle a of+               SetTo v -> b { attrStyle = SetTo v }                _ -> b-        b2 = case attr_fore_color a of-               SetTo v -> b1 `with_fore_color` v+        b2 = case attrForeColor a of+               SetTo v -> b1 `withForeColor` v                _ -> b1-        b3 = case attr_back_color a of-               SetTo v -> b2 `with_back_color` v+        b3 = case attrBackColor a of+               SetTo v -> b2 `withBackColor` v                _ -> b2     in b3  -- |List fold version of 'mergeAttr'. mergeAttrs :: [Attr] -> Attr-mergeAttrs attrs = foldr mergeAttr def_attr attrs+mergeAttrs attrs = foldr mergeAttr defAttr attrs  -- |Modify the width component of a 'DisplayRegion'.-withWidth :: DisplayRegion -> Word -> DisplayRegion-withWidth (DisplayRegion _ h) w = DisplayRegion w h+withWidth :: DisplayRegion -> Int -> DisplayRegion+withWidth (_, h) w = (w, h)  -- |Modify the height component of a 'DisplayRegion'.-withHeight :: DisplayRegion -> Word -> DisplayRegion-withHeight (DisplayRegion w _) h = DisplayRegion w h+withHeight :: DisplayRegion -> Int -> DisplayRegion+withHeight (w, _) h = (w, h)  -- |Modify the width component of a 'DisplayRegion'.-plusWidth :: DisplayRegion -> Word -> DisplayRegion-plusWidth (DisplayRegion w' h) w =-    if (fromEnum w' + fromEnum w < 0)+plusWidth :: DisplayRegion -> Int -> DisplayRegion+plusWidth (w', h) w =+    if (w' + w < 0)     then error $ "plusWidth: would overflow on " ++ (show w') ++ " + " ++ (show w)-    else DisplayRegion (w + w') h+    else ((w + w'), h)  -- |Modify the height component of a 'DisplayRegion'.-plusHeight :: DisplayRegion -> Word -> DisplayRegion-plusHeight (DisplayRegion w h') h =-    if (fromEnum h' + fromEnum h < 0)+plusHeight :: DisplayRegion -> Int -> DisplayRegion+plusHeight (w, h') h =+    if (h' + h < 0)     then error $ "plusHeight: would overflow on " ++ (show h') ++ " + " ++ (show h)-    else DisplayRegion w (h + h')+    else (w, (h + h'))  remove :: Int -> [a] -> [a] remove pos as = (take pos as) ++ (drop (pos + 1) as)  inject :: Int -> a -> [a] -> [a]-inject pos a as = let (h, t) = splitAt pos as-                  in h ++ (a:t)+inject !pos !a !as = let (h, t) = (take pos as, drop pos as)+                     in h ++ (a:t)  repl :: Int -> a -> [a] -> [a]-repl pos a as = inject pos a (remove pos as)+repl !pos !a !as = inject pos a (remove pos as)++regionWidth :: DisplayRegion -> Int+regionWidth = fst++regionHeight :: DisplayRegion -> Int+regionHeight = snd
− src/ListDemo.hs 
@@ -1,170 +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-                , theFooter1 :: Widget FormattedText-                , theFooter2 :: Widget FormattedText-                , theEdit :: Widget Edit-                , theListLimit :: Widget (VLimit (List String FormattedText))-                , uis :: Collection-                }---- Visual attributes.-titleAttr = bright_white `on` blue-editAttr = white `on` black-focAttr = black `on` green-boxAttr = bright_yellow `on` black-bodyAttr = bright_green `on` black-selAttr = black `on` yellow-hlAttr1 = red `on` black-hlAttr2 = yellow `on` black--uiCore appst w = do-  (hBorder >>= withBorderAttribute titleAttr)-      <--> w-      <--> (hBorder >>= withBorderAttribute titleAttr)-      <--> (return $ theEdit appst)-      <--> ((return $ theFooter1 appst)-            <++> (return $ theFooter2 appst)-            <++> (hBorder >>= withBorderAttribute titleAttr))--buildUi1 appst = do-  uiCore appst (return $ theList appst)--buildUi2 appst =-    uiCore appst ((return $ theListLimit appst)-                  <--> (hBorder >>= withBorderAttribute titleAttr)-                  <--> (return $ theBody appst)-                  <--> (vFill ' '))---- Construct the application state using the message map.-mkAppElements :: IO AppElements-mkAppElements = do-  lw <- newStringList selAttr []-  b <- textWidget wrap ""-  f1 <- plainText "" >>= withNormalAttribute titleAttr-  f2 <- plainText "[]" >>= withNormalAttribute titleAttr-  e <- editWidget-  ll <- vLimit 5 lw--  c <- newCollection--  return $ AppElements { theList = lw-                       , theBody = b-                       , theFooter1 = f1-                       , theFooter2 = f2-                       , theEdit = e-                       , 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 -> "--/--"-              Just (i, _) ->-                  "-" ++ (show $ i + 1) ++ "/" ++-                          (show sz) ++ "-"-  setText (theFooter1 st) msg--updateFooterText :: AppElements -> Widget Edit -> String -> IO ()-updateFooterText st _ t = setText (theFooter2 st) ("[" ++ t ++ "]")--main :: IO ()-main = do-  st <- mkAppElements--  ui1 <- buildUi1 st-  ui2 <- buildUi2 st--  fg1 <- newFocusGroup-  fg2 <- newFocusGroup--  showMainUI <- addToCollection (uis st) ui1 fg1-  showMessageUI <- addToCollection (uis st) ui2 fg2--  listCtx1 <- addToFocusGroup fg1 (theList st)-  addToFocusGroup fg1 (theEdit st)--  listCtx2 <- addToFocusGroup fg2 (theList st)-  addToFocusGroup fg2 (theEdit st)--  -- These event handlers will fire regardless of the input event-  -- context.-  (theEdit st) `onChange` (updateFooterText st (theEdit st))-  (theEdit st) `onActivate` \e -> do-         s <- getEditText e-         addToList (theList st) s =<< plainText s-         setEditText e ""--  let doBodyUpdate (SelectionOn i _ _) = updateBody st i-      doBodyUpdate SelectionOff = return ()--  (theList st) `onSelectionChange` doBodyUpdate-  (theList st) `onSelectionChange` \_ -> updateFooterNums st $ theList st-  (theList st) `onItemAdded` \_ -> updateFooterNums st $ theList st-  (theList st) `onItemRemoved` \_ -> updateFooterNums st $ theList st--  (theList st) `onKeyPressed` \_ k _ -> do-         case k of-           (KASCII 'q') -> exitSuccess-           KDel -> do-                  result <- getSelected (theList st)-                  case result of-                    Nothing -> return ()-                    Just (i, _) -> removeFromList (theList st) i >> return ()-                  return True-           _ -> return False--  -- These event handlers will only fire when the UI is in the-  -- appropriate mode, depending on the state of the Widget-  -- Collection.-  listCtx1 `onKeyPressed` \_ k _ -> do-            case k of-              KEnter -> do-                     r <- getSelected (theList st)-                     case r of-                       Nothing -> return True-                       Just _ -> showMessageUI >> return True-              _ -> return False--  listCtx2 `onKeyPressed` \_ k _ -> do-         case k of-           KASCII 'c' -> showMainUI >> return True-           KASCII '+' -> do-                  addToVLimit (theListLimit st) 1-                  return True-           KASCII '-' -> do-                  addToVLimit (theListLimit st) (-1)-                  return True-           _ -> return False--  setEditText (theEdit st) "edit me"-  focus (theEdit st)--  -- 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-                                  }
− src/PhoneInputDemo.hs 
@@ -1,82 +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)--   setEditMaxLength e1 3-   setEditMaxLength e2 3-   setEditMaxLength e3 4--   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-                           }
src/Text/Trans/Tokenize.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, BangPatterns #-} -- |This module provides functionality for tokenizing text streams to -- differentiate between printed characters and structural elements -- such as newlines.  Once tokenized, such text streams can be@@ -19,6 +19,7 @@      -- * Manipulation     , truncateLine+    , truncateText     , wrapStream     , findLines #ifdef TESTING@@ -28,30 +29,33 @@     ) 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+                 , tokenAttr :: !a                  -- ^The token's attribute.                  }              -- ^Non-whitespace tokens.-             | WS { tokenStr :: String+             | WS { tokenStr :: !T.Text                   -- ^The token's string.-                  , tokenAttr :: a+                  , tokenAttr :: !a                   -- ^The token's attribute.                   }                -- ^Whitespace tokens.  -- |A text stream entity is either a token or a structural element.-data TextStreamEntity a = T (Token a)+data TextStreamEntity a = T !(Token a)                         -- ^Constructor for ordinary tokens.                         | NL                           -- ^Newline.@@ -59,7 +63,7 @@ -- |A text stream is a list of text stream entities.  A text stream -- |combines structural elements of the text (e.g., newlines) with the -- |text itself (words, whitespace, etc.).-data TextStream a = TS [TextStreamEntity a]+data TextStream a = TS ![TextStreamEntity a]  instance (Show a) => Show (TextStream a) where     show (TS ts) = "TS " ++ show ts@@ -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 _ [] = []
test/TestDriver.hs view
@@ -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 ()
+ test/src/Tests/Edit.hs view
@@ -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+        ]
test/src/Tests/FormattedText.hs view
@@ -4,26 +4,28 @@ import Test.QuickCheck.Monadic  import Control.Applicative+import qualified Data.Text as T  import Graphics.Vty import Graphics.Vty.Widgets.Text import Graphics.Vty.Widgets.Core+import Graphics.Vty.Widgets.Util  import Tests.Util  import Tests.Instances ()  sz :: DisplayRegion-sz = DisplayRegion 100 100+sz = (100, 100)  textHeight :: Property textHeight =     monadicIO $ forAllM textString $ \str -> do       w <- run $ plainText str       img <- run $ render w sz defaultContext-      if region_height sz == 0 then-          return $ image_height img == 0 else-          return $ image_height img == (toEnum $ numNewlines str + 1)+      if regionHeight sz == 0 then+          return $ imageHeight img == 0 else+          return $ imageHeight img == (toEnum $ numNewlines str + 1)  textImageSize :: Property textImageSize =@@ -42,11 +44,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
test/src/Tests/Instances.hs view
@@ -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@@ -20,7 +22,14 @@ instance Arbitrary Attr where     arbitrary = Attr <$> arbitrary <*> arbitrary <*> arbitrary -instance Arbitrary DisplayRegion where-    arbitrary = DisplayRegion <$> coord <*> coord-        where-          coord = sized $ \n -> fromIntegral <$> choose (0, n)+instance 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
+ test/src/Tests/TextClip.hs view
@@ -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+        ]
+ test/src/Tests/TextZipper.hs view
@@ -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+        ]
test/src/Tests/Tokenize.hs view
@@ -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         ]
test/src/Tests/Util.hs view
@@ -1,28 +1,40 @@ 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 ()  imageSize :: Image -> DisplayRegion -> Bool imageSize img sz =-    image_width img <= region_width sz && image_height img <= region_height sz+    imageWidth img <= regionWidth sz && imageHeight img <= regionHeight sz  count :: (a -> Bool) -> [a] -> Int count _ [] = 0 count f (a:as) = count f as + if f a then 1 else 0 -numNewlines :: String -> Int-numNewlines = count (== '\n')+numNewlines :: T.Text -> Int+numNewlines = count (== '\n') . T.unpack +sizeGen :: Gen DisplayRegion+sizeGen = (,)+          <$> (arbitrary `suchThat` (>= 0))+          <*> (arbitrary `suchThat` (>= 0))+ sizeTest :: (Show a) => IO (Widget a) -> PropertyM IO Bool sizeTest mkWidget =-    forAllM arbitrary $ \sz -> do+    forAllM sizeGen $ \sz -> do       w <- run mkWidget       img <- run $ render w sz defaultContext-      if region_height sz == 0 || region_width sz == 0 then-          return $ image_height img == 0 && image_width img == 0 else-          return $ image_width img <= region_width sz &&-                 image_height img <= region_height sz+      if regionHeight sz == 0 || regionWidth sz == 0 then+          return $ imageHeight img == 0 && imageWidth img == 0 else+          return $ imageWidth img <= regionWidth sz &&+                 imageHeight img <= regionHeight sz++lineLength :: [Token a] -> Phys+lineLength = sum . (textWidth <$>) . (tokenStr <$>)
vty-ui.cabal view
@@ -1,30 +1,30 @@ Name:                vty-ui-Version:             1.4+Version:             1.9 Synopsis:   An interactive terminal user interface library for Vty  Description:   An extensible library of user interface widgets for composing and   laying out Vty user interfaces.  This library provides a collection-  of widgets for building and composing interactive interactive,+  of widgets for building and composing interactive,   event-driven terminal interfaces.  This library is intended to make   non-trivial user interfaces easy to express and modify without   having to worry about terminal size.   .   Be sure to check out the user manual for the version you're using-  at: <http://codevine.org/vty-ui/>+  at: <http://jtdaugherty.github.com/vty-ui/>   .   Build with the 'demos' flag to get a set of demonstration programs   to see some of the things the library can do!  Category:            User Interfaces-Author:              Jonathan Daugherty <jtd@galois.com>-Maintainer:          Jonathan Daugherty <jtd@galois.com>+Author:              Jonathan Daugherty <cygnus@foobox.com>+Maintainer:          Jonathan Daugherty <cygnus@foobox.com> Build-Type:          Simple License:             BSD3 License-File:        LICENSE-Cabal-Version:       >= 1.6-Homepage:            http://codevine.org/vty-ui/+Cabal-Version:       >= 1.8+Homepage:            http://jtdaugherty.github.com/vty-ui/  Data-Files:     doc/ch1/api_notes.tex@@ -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,22 +89,28 @@ Library   Build-Depends:     base >= 4 && < 5,-    vty >= 4.6 && < 4.8,-    containers >= 0.2 && < 0.5,+    vty >= 5.1.0,+    containers >= 0.2 && < 0.6,     regex-base >= 0.93 && < 0.94,-    directory >= 1.0 && < 1.2,-    filepath >= 1.1 && < 1.3,-    unix >= 2.4 && < 2.6,-    mtl >= 2.0 && < 2.1,-    stm >= 2.1 && < 2.3,-    array >= 0.3 && < 0.4+    directory >= 1.0 && < 1.3,+    filepath >= 1.1 && < 1.5,+    unix >= 2.4 && < 2.8,+    mtl >= 2.0 && < 2.3,+    stm >= 2.1 && < 2.5,+    array >= 0.3.0.0 && < 0.6.0.0,+    text >= 0.11,+    vector >= 0.9,+    data-default >= 0.5.3    GHC-Options:       -Wall    Hs-Source-Dirs:    src   Exposed-Modules:           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@@ -127,89 +136,131 @@  Executable vty-ui-tests   Build-Depends:-    QuickCheck >= 2.4 && < 2.5+    base >= 4 && < 5,+    QuickCheck >= 2.4 && < 2.8,+    random >= 1.0,+    text,+    vty >= 5.1.0,+    vty-ui    CPP-Options: -DTESTING-  GHC-Options: -Wall+  GHC-Options: -Wall -threaded -  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-collection-demo+  Hs-Source-Dirs:  demos+  GHC-Options:     -Wall -threaded+  Main-is:         CollectionDemo.hs+  Build-Depends:+    base >= 4 && < 5,+    mtl >= 2.0 && < 2.3,+    vty >= 5.1.0,+    text,+    vty-ui+  if !flag(demos)+    Buildable: False+ Executable vty-ui-list-demo-  Hs-Source-Dirs:  src-  GHC-Options:     -Wall+  Hs-Source-Dirs:  demos+  GHC-Options:     -Wall -threaded   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.3,+    vty >= 5.1.0,+    text,+    vty-ui   if !flag(demos)     Buildable: False +Executable vty-ui-progressbar-demo+  Hs-Source-Dirs:  demos+  GHC-Options:     -Wall -threaded+  Main-is:         ProgressBarDemo.hs+  Build-Depends:+    base >= 4 && < 5,+    mtl >= 2.0 && < 2.3,+    vty >= 5.1.0,+    text,+    vty-ui+  if !flag(demos)+    Buildable: False+ Executable vty-ui-complex-demo-  Hs-Source-Dirs:  src-  GHC-Options:     -Wall+  Hs-Source-Dirs:  demos+  GHC-Options:     -Wall -threaded   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.3,     bytestring >= 0.9 && < 1.0,-    time >= 1.1 && < 1.3,-    old-locale >= 1.0 && < 1.1,-    vty >= 4.6 && < 4.8+    time >= 1.5,+    vty >= 5.1.0,+    text,+    vty-ui   if !flag(demos)     Buildable: False  Executable vty-ui-dirbrowser-demo-  Hs-Source-Dirs:  src-  GHC-Options:     -Wall+  Hs-Source-Dirs:  demos+  GHC-Options:     -Wall -threaded   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.3,+    vty >= 5.1.0,+    vty-ui   if !flag(demos)     Buildable: False  Executable vty-ui-phoneinput-demo-  Hs-Source-Dirs:  src-  GHC-Options:     -Wall+  Hs-Source-Dirs:  demos+  GHC-Options:     -Wall -threaded   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.3,+    vty >= 5.1.0,+    text,+    vty-ui   if !flag(demos)     Buildable: False  Executable vty-ui-dialog-demo-  Hs-Source-Dirs:  src-  GHC-Options:     -Wall+  Hs-Source-Dirs:  demos+  GHC-Options:     -Wall -threaded   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.3,+    vty >= 5.1.0,+    text,+    vty-ui+  if !flag(demos)+    Buildable: False++Executable vty-ui-edit-demo+  Hs-Source-Dirs:  demos+  GHC-Options:     -Wall -threaded+  Main-is:         EditDemo.hs+  Build-Depends:+    base >= 4 && < 5,+    mtl >= 2.0 && < 2.3,+    vty >= 5.1.0,+    vty-ui   if !flag(demos)     Buildable: False