itemfield (empty) → 1.1.0.1
raw patch · 14 files changed
+1976/−0 lines, 14 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, brick, data-default, itemfield, microlens, microlens-th, random, test-framework, test-framework-hunit, test-framework-quickcheck2, text, vty
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- brickcompat/015plus/TextUI/ItemField/BrickHelper.hs +53/−0
- brickcompat/pre015/TextUI/ItemField/BrickHelper.hs +53/−0
- examples/bookcase.hs +133/−0
- examples/workreport.hs +181/−0
- itemfield.cabal +143/−0
- src/TextUI/ItemField.hs +378/−0
- src/TextUI/ItemField/Attrs.hs +100/−0
- src/TextUI/ItemField/Layout.hs +292/−0
- src/TextUI/ItemField/Operations.hs +38/−0
- src/TextUI/ItemField/Types.hs +59/−0
- test/test_itemfield.hs +109/−0
- test/test_layout.hs +405/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Kevin Quick <quick@sparq.org>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Kevin Quick <quick@sparq.org> nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ brickcompat/015plus/TextUI/ItemField/BrickHelper.hs view
@@ -0,0 +1,53 @@+module TextUI.ItemField.BrickHelper+ (getEventWidgetLocation)+ where++import Brick.Main (lookupViewport, lookupExtent, clickedExtent)+import Brick.Types (EventM, Location(..), locationRowL, locationColumnL,+ Extent(..), Viewport(..))+import Brick.Widgets.Core (Named(..))+import Data.Monoid ((<>))+import Lens.Micro ((^.))+++-- | When processing a global EvMouseDown VtyEvent, the coordinates of+-- the mouse event on the screen must be mapped to a specific location+-- in a Widget. The `lookupExtent` function will return the "extent"+-- of the Widget (i.e. where it was drawn and how big it is) but this+-- only indicates that the widget was clocked and does not identify+-- the actual location within the widget where the click occurred.+--+-- The `getEventWidgetLocation` function translates the mouse event+-- coordinates to a specific location within the widget in the+-- widget's local reference frame, taking into account any scrolling+-- that has occurred within a viewport that wraps that widget.+--+-- drawUI st = reportExtent (getName st) $+-- viewport (getName st) Vertical $+-- Widget Fixed Fixed $ ...+--+-- handleEvent event st =+-- case event of+-- EvMouseDown col row button _mods ->+-- do wcoords <- getEventWidgetLocation fieldw col row+-- case wcoords of+-- Nothing -> return fieldw+-- Just l -> ...+--+getEventWidgetLocation :: (Named a n, Ord n)+ => a -> Int -> Int -> EventM n (Maybe Location)+getEventWidgetLocation widget screenCol screenRow =+ do mExtent <- Brick.Main.lookupExtent (getName widget)+ case mExtent of+ Nothing -> return Nothing+ Just e@(Extent _ upperLeft _) ->+ if Brick.Main.clickedExtent (screenCol, screenRow) e+ then let widgetRow = screenRow - upperLeft^.locationRowL+ widgetCol = screenCol - upperLeft^.locationColumnL+ widgetLoc = Location (widgetCol, widgetRow)+ in do mView <- Brick.Main.lookupViewport (getName widget)+ case mView of+ Nothing -> return $ Just widgetLoc+ Just (VP left top _) ->+ return $ Just $ widgetLoc <> Location (left, top)+ else return Nothing
+ brickcompat/pre015/TextUI/ItemField/BrickHelper.hs view
@@ -0,0 +1,53 @@+module TextUI.ItemField.BrickHelper+ (getEventWidgetLocation)+ where++import Brick.Main (lookupViewport, lookupExtent, clickedExtent)+import Brick.Types (EventM, Location(..), rowL, columnL,+ Extent(..), Viewport(..))+import Brick.Widgets.Core (Named(..))+import Data.Monoid ((<>))+import Lens.Micro ((^.))+++-- | When processing a global EvMouseDown VtyEvent, the coordinates of+-- the mouse event on the screen must be mapped to a specific location+-- in a Widget. The `lookupExtent` function will return the "extent"+-- of the Widget (i.e. where it was drawn and how big it is) but this+-- only indicates that the widget was clocked and does not identify+-- the actual location within the widget where the click occurred.+--+-- The `getEventWidgetLocation` function translates the mouse event+-- coordinates to a specific location within the widget in the+-- widget's local reference frame, taking into account any scrolling+-- that has occurred within a viewport that wraps that widget.+--+-- drawUI st = reportExtent (getName st) $+-- viewport (getName st) Vertical $+-- Widget Fixed Fixed $ ...+--+-- handleEvent event st =+-- case event of+-- EvMouseDown col row button _mods ->+-- do wcoords <- getEventWidgetLocation fieldw col row+-- case wcoords of+-- Nothing -> return fieldw+-- Just l -> ...+--+getEventWidgetLocation :: (Named a n, Ord n)+ => a -> Int -> Int -> EventM n (Maybe Location)+getEventWidgetLocation widget screenCol screenRow =+ do mExtent <- Brick.Main.lookupExtent (getName widget)+ case mExtent of+ Nothing -> return Nothing+ Just e@(Extent _ upperLeft _) ->+ if Brick.Main.clickedExtent (screenCol, screenRow) e+ then let widgetRow = screenRow - upperLeft^.rowL+ widgetCol = screenCol - upperLeft^.columnL+ widgetLoc = Location (widgetCol, widgetRow)+ in do mView <- Brick.Main.lookupViewport (getName widget)+ case mView of+ Nothing -> return $ Just widgetLoc+ Just (VP left top _) ->+ return $ Just $ widgetLoc <> Location (left, top)+ else return Nothing
+ examples/bookcase.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++{- This is an example of a bookcase with a number of shelves, each+containing a number of books. The books can be "checked out" and the+itemfield will change to indicate the missing status for that book.+-}++module Main where++import Data.List (intercalate)+import Data.Monoid+import Data.Default+import Data.String (IsString)+import qualified Data.Text as T+import Brick+import Brick.Widgets.Border+import Graphics.Vty (Event(..), Key(..))+import TextUI.ItemField+import Lens.Micro ((^.))+import Lens.Micro.TH (makeLenses)+++data BookCaseState n = BookCaseState { _shelves :: ItemFieldWidget n+ , _books :: [T.Text]+ }++makeLenses ''BookCaseState+++sampleBookCase :: ItemIdent -> ItemField+sampleBookCase =+ newItemField [ ItemGroup "Top Shelf" (Items 5)+ , ItemGroup "Fiction" (Items 320)+ , ItemGroup "Fiction" (ItemGroup "SciFi" (Items 12))+ , ItemGroup "Fiction" (ItemGroup "Romance" (Items 121))+ , ItemGroup "Reference" (Items 113)+ , ItemGroup "Shelf 5" (Items 86)+ , ItemGroup "Childrens" (ItemGroup "Dr. Seuss" (Items 3))+ , ItemGroup "Childrens" (ItemGroup "Primers" (Items 8))+ , ItemGroup "Childrens" (ItemGroup "Pictures" (ItemGroup "Animals" (Items 5)))+ , ItemGroup "Childrens" (ItemGroup "Pictures" (ItemGroup "Thomas the Tank Engine" (Items 12)))+ , ItemGroup "Bottom Shelf" (Items 0)+ ]+++initialState :: n -> BookCaseState n+initialState n =+ let blank = T.pack ""+ scifi = 5 + 320+ scifi_books = ["Fahrenheit 451", "Snow Crash", "Idoru", "Starburst", "Cryptonomicon"] <>+ replicate (12 - 5) blank+ scifi_to_seuss = 121 + 113 + 86+ seuss_books = ["One Fish, Two Fish", "Cat In The Hat", "The Lorax"]+ all_books = replicate scifi blank <> scifi_books+ <> replicate (scifi_to_seuss) blank <> seuss_books+ in BookCaseState+ (ItemFieldWidget n $ sampleBookCase $ Just $ showBookCaseItem all_books)+ all_books+++bookstate :: IsString s => ItemState -> s+bookstate s = case s of+ Good -> "read by you"+ Bad -> "missing or damaged"+ CaVa -> "on loan"+ _ -> ""+++showBookCaseItem :: [T.Text] -> Int -> ItemState -> T.Text+showBookCaseItem booklist idx st8 =+ let book = booklist !! idx+ bookid = if idx >= length booklist+ then T.pack $ "Book #" <> show idx+ else if T.null book+ then T.pack $ "Untitled Book #" <> show idx+ else book+ bookinfo = case bookstate st8 of+ "" -> ""+ a -> " (" <> a <> ")"+ in bookid <> bookinfo+++data MainIFName = MainItemFieldName deriving (Eq, Ord, Show)+++showBookcase :: (Show n, Ord n) => BookCaseState n -> [Widget n]+showBookcase bc =+ [ vBox [ borderWithLabel (str "BookCase Contents") $ itemFieldWidget $ bc^.shelves+ , str " Movement: arrows, or '<' and '>' to jump."+ , str "Toggle item selection: space = single item, L = line, G = group, A = all"+ , str " right or left arrow with shift extends selection"+ , str " !, ~, or + selects all corresponding items"+ , str " Misc: Q/q = quit, r = read book, l = loan book, m = missing book"+ ]+ ]+++bookEvent :: Ord n => BookCaseState n -> BrickEvent n e -> EventM n (Next (BookCaseState n))+bookEvent s (VtyEvent e) = bkVtyEvent e+ where+ bkVtyEvent (EvResize _ _) = continue s+ bkVtyEvent (EvKey (KChar 'r') []) = continue =<< handleEventLensed s shelves (setBooks Good) e+ bkVtyEvent (EvKey (KChar 'l') []) = continue =<< handleEventLensed s shelves (setBooks CaVa) e+ bkVtyEvent (EvKey (KChar 'm') []) = continue =<< handleEventLensed s shelves (setBooks Bad) e+ bkVtyEvent (EvKey (KChar 'Q') []) = halt s+ bkVtyEvent (EvKey (KChar 'q') []) = halt s+ bkVtyEvent o = continue =<< handleEventLensed s shelves handleItemFieldEvent o+bookEvent s _ = continue s -- =<< handleEventLensed s shelves handleItemFieldEvent o+++setBooks :: ItemState -> e -> ItemFieldWidget n -> EventM n (ItemFieldWidget n)+setBooks toState _ fieldw = return $ setMarkedItemsState toState fieldw+++main :: IO ()+main =+ do result <- defaultMain app (initialState MainItemFieldName)+ let finalBookcase = itemField $ result^.shelves+ st8s = itemst8 finalBookcase+ numSt8 st8 = length . filter ((==) st8)+ showNum = show . flip numSt8 st8s+ summary s = showNum s <> " " <> bookstate s+ putStrLn $ "Final bookcase state: " <>+ intercalate ", " [ (show $ length st8s) <> " books"+ , summary Good, summary CaVa, summary Bad+ ]+ where app = App { appDraw = showBookcase+ , appHandleEvent = bookEvent+ , appStartEvent = return+ , appAttrMap = const $ applyAttrMappings itemDefaultAttrs def+ , appChooseCursor = showFirstCursor+ }
+ examples/workreport.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}++{- This example application uses the ItemField widget to show the status+of a number of asynchronously executing workers as they complete their+work.+-}++module Main where++import Data.List (intercalate)+import Data.Monoid+import Data.Default+import Data.String (IsString)+import Brick+import Brick.Widgets.Center (hCenter)+import Graphics.Vty (Event(..), Key(..), mkVty, outputIface, supportsMode, Mode(..), setMode, Vty)+import Graphics.Vty.Attributes+import TextUI.ItemField+import Brick.Widgets.Border+import Lens.Micro ((^.), Lens', (.~), (&))+import Lens.Micro.TH (makeLenses)+import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import System.Random+++data WorkEvent = WorkerFinished Int ItemState+++data WorkerTeams n = WorkerTeams { _workers :: ItemFieldWidget n+ , _reqChannel :: Chan WorkEvent+ }++makeLenses ''WorkerTeams+++setupFactory :: n -> Chan WorkEvent -> WorkerTeams n+setupFactory n =+ let teams = [ ItemGroup "Team 1" (Items 28)+ , ItemGroup "Team 2" (Items 238)+ , ItemGroup "Team 3" $ ItemGroup "Group 1" $ Items 93+ , ItemGroup "Team 3" $ ItemGroup "Group 2" $ Items 127+ , ItemGroup "Team 3" $ ItemGroup "Group 3" $ Items 56+ , ItemGroup "Team 3" $ Items 596+ , ItemGroup "Team 4" $ Items 77+ , ItemGroup "Team 5" $ Items 0+ , ItemGroup "Team 6" $ Items 3+ ]+ -- teams = [] -- alternative: no workers, not very interesting+ in WorkerTeams (ItemFieldWidget n $ newItemField teams Nothing)+++workerstate :: IsString s => ItemState -> s+workerstate s = case s of+ Good -> "done"+ Bad -> "error"+ CaVa -> "delayed"+ _ -> ""++-- KWQ: add a mapper that will map through and provide index, state, and [groups]+-- KWQ: add a mapper that will map through groups, with sub-mapping for index, state+showWorkers :: WorkerTeams n -> String+showWorkers teams =+ let ws = itemField $ teams^.workers+ st8s = itemst8 ws+ numSt8 st8 = length . filter (st8 ==)+ showNum = show . flip numSt8 st8s+ summary s = showNum s <> " " <> workerstate s+ in intercalate ", " [ show (length st8s) <> " workers"+ , summary Good, summary CaVa, summary Bad+ ]+++data WorkerTeamsName = WorkerTeamsName deriving (Eq, Ord, Show)+++drawWorkers :: (Show n, Ord n) => WorkerTeams n -> [Widget n]+drawWorkers teams =+ [ vBox [ hCenter $ str "Workers"+ , itemFieldWidget $ teams^.workers+ , hBorder+ , str " Movement: arrows, or '<' and '>' to jump."+ , str "Toggle item selection: space = single item, L = line, G = group, A = all"+ , str " right or left arrow with shift extends selection"+ , str " !, ~, or + selects all corresponding items"+ , str " s, f select only successes or failures"+ , str " Misc: Q/q = quit, r = run workers"+ , str ""+ , str "When run, workers will asynchronously \"do some work\" and then"+ , str "set their state to good or bad."+ ]+ ]++++workEvent :: Ord n => WorkerTeams n -> BrickEvent n WorkEvent -> EventM n (Next (WorkerTeams n))+workEvent s (VtyEvent ve) = workVtyEvt ve+ where+ workVtyEvt (EvResize _ _) = continue s+ workVtyEvt (EvKey (KChar 'r') []) = runWork s+ -- workVtyEvt e@(EvKey (KChar 'r') []) = continue =<< handleEventLensed s workers (runWork (s^. e+ -- workVtyEvt e@(EvKey (KChar 'l') []) = continue =<< handleEventLensed s shelves (setBooks CaVa) e+ -- workVtyEvt e@(EvKey (KChar 'm') []) = continue =<< handleEventLensed s shelves (setBooks Bad) e+ workVtyEvt (EvKey (KChar 'Q') []) = halt s+ workVtyEvt (EvKey (KChar 'q') []) = halt s+ workVtyEvt _ = continue =<< handleEventLensed s workers handleItemFieldEvent ve+workEvent s (AppEvent e@(WorkerFinished wnum result)) =+ continue =<< handleEventL s workers (workDone wnum result) e+workEvent s _ = continue s++handleEventL :: a+ -- ^ The state value.+ -> Lens' a b+ -- ^ The lens to use to extract and store the target+ -- of the event.+ -> (e -> b -> EventM n b)+ -- ^ The event handler.+ -> e+ -- ^ The event to handle.+ -> EventM n a+handleEventL v target handleEvent ev = do+ newB <- handleEvent ev (v^.target)+ return $ v & target .~ newB++runWork :: WorkerTeams n -> EventM n (Next (WorkerTeams n))+runWork wt =+ let chan = wt^.reqChannel+ marked = getMarkedItems $ wt^.workers+ startwork c i = forkIO $ doWork c i+ in liftIO (mapM_ (startwork chan) marked) >> continue wt+++doWork :: Chan WorkEvent -> Int -> IO ()+doWork reportChan myId =+ do r <- randomRIO (100000,3000000)+ threadDelay r+ s <- ([Good, Bad, CaVa] !!) <$> randomRIO (0,2)+ writeChan reportChan $ WorkerFinished myId s+ when (s == CaVa) $ doWork reportChan myId++-- KWQ: workers can report their total time taken and result, which can be displayed in a separate widget+-- KWQ: with brick viewport scrolling, is itemMoreMessageAttr and associated even used?+-- KWQ: vi/emacs style movement? means top level entrypoints for those event processors (and move their utilities into hidding internal operations?)+workDone :: Int -> ItemState -> t -> ItemFieldWidget n -> EventM n (ItemFieldWidget n)+workDone workerNum toState _ fieldw =+ return $ setItemState toState fieldw workerNum+++workAttrs :: AttrMap+workAttrs =+ applyAttrMappings [ (itemFieldAttr, bg brightBlack)+ , (itemFreeAttr, defAttr `withStyle` dim)+ , (itemBadAttr, brightYellow `on` red `withStyle` bold)+ , (itemHeaderAttr, bg blue `withStyle` underline)+ ] $+ applyAttrMappings itemDefaultAttrs $+ setDefault (white `on` black) def+++enableMouse :: Graphics.Vty.Vty -> IO ()+enableMouse v = let output = outputIface v+ in when (supportsMode output Mouse) $ setMode output Mouse True++main :: IO ()+main = do+ chan <- newChan+ let allworkers = setupFactory WorkerTeamsName chan+ app = App { appDraw = drawWorkers+ , appHandleEvent = workEvent+ , appStartEvent = return+ , appAttrMap = const workAttrs+ , appChooseCursor = showFirstCursor+ }+ vty = do v <- mkVty def+ enableMouse v+ return v+ mapM_ (forkIO . doWork chan) [8 .. 12] -- initial sample work+ putStrLn . ("Final results: " <>) . showWorkers =<< customMain vty (Just chan) app allworkers
+ itemfield.cabal view
@@ -0,0 +1,143 @@+name: itemfield+version: 1.1.0.1++synopsis: A brick Widget for selectable summary of many elements on a terminal+description: ++ This module provides a brick Widget that can be used with the+ brick package to handle situations where there are lots of items+ to represent to the user along with a corresponding state for each+ item. In addition, the user should be able to use the cursor+ keys and space bar to mark one or more items (presumably so other+ code can get the list of marked elements and perform a+ state-changing operation).+ .+ . * 0.1.0.0 -- initial version+ .+ . * 0.2.0.0 -- more key events: Shift+Arrow to mark/unmark with move+ .+ . * 0.2.0.1 -- more key events: G=mrk/unm group, A=mrk/unm all, !=mrk bad; add helpMsg+ .+ . * 0.3.0.0 -- rename from StateFieldSelector to ItemField+ .+ . * 0.3.1.0 -- add + key selector to select all successful targets+ .+ . * 1.0.0.0 -- update from vty-ui to brick+ .+ . * 1.1.0.0 -- add support for 's' and 'f' keys and mouse events+ +license: BSD3+license-file: LICENSE+author: Kevin Quick <quick@sparq.org>+maintainer: quick@sparq.org+copyright: Kevin Quick, 2013-2016+category: Graphics, Console+build-type: Simple+cabal-version: >=1.8++extra-source-files: brickcompat/015plus/TextUI/ItemField/BrickHelper.hs+ brickcompat/pre015/TextUI/ItemField/BrickHelper.hs++library+ hs-source-dirs: src+ exposed-modules: TextUI.ItemField+ other-modules: TextUI.ItemField.Types+ , TextUI.ItemField.Attrs+ , TextUI.ItemField.Operations+ , TextUI.ItemField.Layout+ , TextUI.ItemField.BrickHelper+ build-depends: base ==4.* , vty, text, microlens+ if flag(brick015plus)+ build-depends: brick >= 0.15+ hs-source-dirs: brickcompat/015plus+ else+ build-depends: brick >= 0.13 && < 0.15+ hs-source-dirs: brickcompat/pre015+ ghc-options: -Wall -fno-warn-unused-do-bind -O3+++Flag examples+ Description: Build example programs+ Default: False++Flag brick015plus+ Description: true for Brick version 0.15 or later+ Default: True++executable bookcase+ if !flag(examples)+ Buildable: False+ hs-source-dirs: src, examples+ if flag(brick015plus)+ build-depends: brick >= 0.15+ hs-source-dirs: brickcompat/015plus+ else+ build-depends: brick >= 0.13 && < 0.15+ hs-source-dirs: brickcompat/pre015+ ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3+ -- default-language: Haskell2010+ main-is: bookcase.hs+ build-depends: base==4.*+ , brick >= 0.13 && < 1.0+ , vty, text, microlens, microlens-th+ , itemfield, data-default+++executable workreport+ if !flag(examples)+ Buildable: False+ hs-source-dirs: src, examples+ if flag(brick015plus)+ build-depends: brick >= 0.15+ hs-source-dirs: brickcompat/015plus+ else+ build-depends: brick >= 0.13 && < 0.15+ hs-source-dirs: brickcompat/pre015+ ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3+ -- default-language: Haskell2010+ main-is: workreport.hs+ build-depends: base==4.*+ , brick >= 0.13 && < 1.0+ , vty, text, microlens, microlens-th+ , itemfield, data-default, random+++test-suite test_itemfield+ type: exitcode-stdio-1.0+ main-is: test_itemfield.hs+ hs-source-dirs: test, src+ if flag(brick015plus)+ build-depends: brick >= 0.15+ hs-source-dirs: brickcompat/015plus+ else+ build-depends: brick >= 0.13 && < 0.15+ hs-source-dirs: brickcompat/pre015+ ghc-options: -threaded -O0+ build-depends: base, HUnit, QuickCheck+ , test-framework, test-framework-hunit+ , test-framework-quickcheck2+ , brick >= 0.13 && < 1.0+ , vty, text, microlens, microlens-th++test-suite test_layout+ type: exitcode-stdio-1.0+ main-is: test_layout.hs+ hs-source-dirs: test, src+ if flag(brick015plus)+ build-depends: brick >= 0.15+ hs-source-dirs: brickcompat/015plus+ else+ build-depends: brick >= 0.13 && < 0.15+ hs-source-dirs: brickcompat/pre015+ ghc-options: -threaded -O0+ cpp-options: -DTEST+ build-depends: base, HUnit, QuickCheck+ , test-framework, test-framework-hunit+ , test-framework-quickcheck2+ , brick >= 0.13 && < 1.0+ , vty, text, microlens, microlens-th+ , data-default++source-repository head+ type: darcs+ location: http://hub.darcs.net/kquick/itemfield
+ src/TextUI/ItemField.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}++{-|+Module : ItemField+Description : Selectable field of items and their current state+Copyright : (c) Kevin Quick, 2016+License : BSD-3+Maintainer : quick@sparq.org+Stability : stable+Portability : POSIX++The ItemField is used to keep track of the current status of a+potentially large number of items and visually indicate that status.+Further, it provides the ability to move the cursor around in the+field of items to "select" a particular item, as well as marking one+or more items for performing an operation on.++This widget is useful for handling data sets that are too large to+readily display with a List widget or similar functionality. Each+item is represented by a single character on the screen, and these+characters are displayed in the specified groups. Each item can have+an associated state, which is reflected in both the character used for+that item and the associated attributes:++ State Character Attribute+ Free (unmarked) . itemFreeAttr+ Marked * itemMarkedAttr+ Good + itemGoodAttr+ Bad ! itemBadAttr+ Pending ~ itemCaVaAttr++(The TextUI.ItemField.Attrs module defines additional attributes.)++The widget provides a default event handler that handles the following:++ Arrow keys: move in the specified direction+ Mouse-click: move cursor to clicked item+ Space: select/deselect the item under the cursor (state->Marked or Free)+ Shift-RightArrow or Shift-LeftArrow: extend selection+ < or >: move 15 items backward or forward+ L: toggle Marked/Free for the current line+ G: toggle Marked/Free for the current group+ Mouse-click on a group: toggle Marked/Free for the current group+ A: toggle Marked/Free for all items+ +: change all Good items to Marked+ !: change all Bad items to Marked+ ~: change all Pending items to Marked+ s: change all Good items to Marked, everything else to Free+ f: change all Bad items to Marked, everything else to Free++Use "cabal configure -fexamples" to build a couple of example programs+that use the ItemField and demonstrate its capabilities.++This module provides the top-level imports and the interaction with+the brick UI framework.++-}++module TextUI.ItemField+ ( module TextUI.ItemField.Types+ -- * Types+ , ItemFieldWidget(..), itemFieldWidget+#ifdef TEST+ , itemFieldRender -- export for testing only+#endif+ -- * Event handling+ , handleItemFieldEvent+ , withItemFieldWidth+ -- * Current item retrieval and manipulation+ , setItemState+ , getSelectedItem+ -- * Retrieving and updating marked items+ , getMarkedItems+ , setMarkedItemsState+ , module TextUI.ItemField.Attrs+ )+where++ -- KWQ: user provides marks? that would imply state as well? no for simplicity+ -- KWQ: finish top level documentation. Then ItemField is in good position refactoring lens, and then publishing.++++import Brick.AttrMap+import Brick.Main (lookupViewport)+import Brick.Types+import Brick.Widgets.Core+import Data.List+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import Graphics.Vty+import Lens.Micro ((^.), _1)+import TextUI.ItemField.Attrs+import TextUI.ItemField.BrickHelper (getEventWidgetLocation)+import TextUI.ItemField.Layout+import TextUI.ItemField.Operations+import TextUI.ItemField.Types+++-- | This is the main widget for managing an ItemFieldWidget in a brick UI.+data ItemFieldWidget n =+ ItemFieldWidget { itemFieldName :: n+ , itemField :: ItemField+ }++instance Show (ItemFieldWidget n) where+ show = show . itemField++instance Named (ItemFieldWidget n) n where+ getName = itemFieldName+++-- | This is the primary drawing description for the ItemField. This+-- draws the widget in a viewport with the same name as the widget,+-- using the Fixed horizontal and vertical growth policies.+itemFieldWidget :: (Show n, Ord n) => ItemFieldWidget n -> Widget n+itemFieldWidget field =+ -- n.b. Use "Vertical" and not "Both" and accept "invisible" items if output screen is too narrow. This is better than enabling horizontal scrolling, at which point the group names are never scrolled back into view. could change this by making each group/line scrollable independently...+ let i = reportExtent (getName field) $+ viewport (getName field) Vertical $+ Widget Fixed Fixed $ fieldImageW field -- KWQ: cached?+ s = Widget Fixed Fixed . summaryW field+ in case elemIdent $ itemField field of+ Nothing -> i+ Just sf -> i <=> s sf++fieldImageW :: ItemFieldWidget n -> RenderM n (Result n)+fieldImageW field =+ do ctx <- getContext+ let width = ctx^.availWidthL+ height = ctx^.availHeightL+ attrmap = ctx^.ctxAttrMapL+ (rdata, newImage) = itemFieldRender field attrmap width height+ cursor = CursorLocation cursorloc (Just $ getName field)+ cursorloc = itemFieldGetPos rdata field+ return $ Result newImage [cursor] [VR cursorloc (1,1)] [] -- KWQ: VR is internal.. can update with recent brick changes??++summaryW :: ItemFieldWidget n -> (Int -> ItemState -> T.Text)+ -> RenderM n (Result n)+summaryW field fn =+ do let s' = itemField field+ cs = curSel s'+ cs8 = itemst8 s' !! cs+ render $ identSel cs cs8 fn++itemFieldRender :: ItemFieldWidget n -> AttrMap -> Int -> Int+ -> (RenderData, Graphics.Vty.Image)+itemFieldRender field attrs width height =+ let s' = itemField field+ rdata = computeLinePosRanges width s'+ ls = redrawSt8Lines height (items s') (itemst8 s') rdata+ mkLineImg = horizCat . map mkColImg+ mkColImg (t,a) = string (attrMapLookup a attrs) $ T.unpack t+ in (rdata, vertCat $ map mkLineImg ls)++identSel :: Int -> ItemState -> (Int -> ItemState -> T.Text) -> Widget n+identSel cs cs8 sf =+ let msg = "#" ++ show cs ++ " " ++ T.unpack (sf cs cs8)+ in withDefAttr itemSelectedDetailsAttr $ str msg++itemFieldGetPos :: RenderData -> ItemFieldWidget n -> Location+itemFieldGetPos rdata field =+ let mbl = pos_coordinates (itemField field) rdata+ in Location $ fromMaybe (5,0) mbl+++-- | This is a handler that can be called from a higher level brick+-- Event handler to allow the item field to handle any keys or other+-- events that have not been handled by that higher level handler. This handler provides handling for:+--+-- * movement via arrow keys and the '<' and '>' keys+-- * toggling marking items:+-- space = current item+-- L = current line+-- G = current group+-- A = all items+-- * extending marking by holding shift while using left or right arrow keys+-- * marking all items with a particular status by using the corrsponding key: +, !, or ~+--+handleItemFieldEvent :: (Ord n) =>+ Event -> ItemFieldWidget n -> EventM n (ItemFieldWidget n)+handleItemFieldEvent event fieldw =+ let marking mods = MShift `elem` mods+ allWithState s = elemIndices s $ itemst8 $ itemField fieldw+ oldItm = itemField fieldw+ clrItm = setAllFree oldItm+ onFldWidget fld fun itmLst = let newItm = foldl fun fld itmLst+ in fieldw { itemField = newItm }+ markItem = changeItemState Marked+ handleKey key mods = case key of+ KRight -> selectNextItem (marking mods) fieldw+ KLeft -> selectPrevItem (marking mods) fieldw+ KChar '>' -> selectForwardBy 15 False fieldw+ KChar '<' -> selectBackwardBy 15 False fieldw+ -- -- shift + KUp or KDown is not supported, so just do regular movement+ KDown -> withItemFieldWidth fieldw $ \w -> selectNextLineItem w False fieldw+ KUp -> withItemFieldWidth fieldw $ \w -> selectPrevLineItem w False fieldw+ -- marked item toggling: space = single item, L = line, G = current group, A = all items+ KChar ' ' -> toggleMark fieldw [curSel $ itemField fieldw]+ KChar 'L' -> toggleLineMarks fieldw+ KChar 'G' -> toggleGroupMarks fieldw+ KChar 'A' -> toggleAllMarks fieldw+ -- set marks based on existing state+ KChar '+' -> setMark Marked fieldw $ allWithState Good+ KChar '!' -> setMark Marked fieldw $ allWithState Bad+ KChar '~' -> setMark Marked fieldw $ allWithState CaVa+ KChar 's' -> return $ onFldWidget clrItm markItem $ allWithState Good+ KChar 'f' -> return $ onFldWidget clrItm markItem $ allWithState Bad+ _ -> return fieldw+ in case event of+ EvKey key mods -> handleKey key mods+ EvMouseDown mcol mrow _button _mods ->+ do wcoords <- getEventWidgetLocation fieldw mcol mrow+ case wcoords of+ Nothing -> return fieldw+ Just l -> withItemFieldWidth fieldw $ \w ->+ let rdata = computeLinePosRanges w $ itemField fieldw+ selly = coordinatesSel oldItm rdata $ loc l+ in case selly of+ Nothing -> return fieldw+ Just (ItemLocNum n) -> selectItemNum n fieldw+ Just (ItemLocGroup n s) -> selectItemNum n fieldw >>= toggleNamedGroupMarks s+ -- EvMouseUp col row button -> error $ "MouseUp at " <> show col <> " / " <> show row <> " with " <> show button+ _ -> return fieldw+++-- | Useful function for writing custom event handlers for the+-- ItemFieldWidget. This wrapper can provide the width of the+-- rendered ItemFieldWidget to the custom event handler.+withItemFieldWidth :: Ord n+ => ItemFieldWidget n+ -> (Int -> EventM n (ItemFieldWidget n))+ -> EventM n (ItemFieldWidget n)+withItemFieldWidth fieldw op =+ do v <- lookupViewport $ itemFieldName fieldw+ case v of+ Nothing -> return fieldw+ Just vp -> op $ vp^.vpSize._1+++-- ----------------------------------------------------------------------+-- Movement Functions++type ItemFieldEventHandler n = ItemFieldWidget n -> EventM n (ItemFieldWidget n)++-- | Select specific item by Id+selectItemNum :: Int -> ItemFieldEventHandler n+selectItemNum n = selectUpdate (update_position $ const . const n) False++-- | Select the next or previous item in the item field, moving the+-- cursor accordingly. The first argument should be true if the+-- state of the newly selected item should be the same as the state of+-- the current item.+selectNextItem, selectPrevItem :: Bool -> ItemFieldEventHandler n+selectNextItem = selectUpdate select_next+selectPrevItem = selectUpdate select_prev++-- | Move the selection forward or backward by the specified number of+-- items in the first argument. Movement will be stopped at the first+-- or last item, so specifying a move beyond those boundaries is safe.+-- The second argument is a boolean that specifies the extension of+-- the current items state across the selection movement (similar to+-- the use of the boolean argument for the 'selectNextItem' and+-- 'selectPrevItem' functions).+selectForwardBy, selectBackwardBy :: Int -> Bool -> ItemFieldEventHandler n+selectForwardBy n = selectUpdate (select_forward_n n)+selectBackwardBy n = selectUpdate (select_backward_n n)++-- | Move the selection to the next line or previous line. The first+-- argument specifies the rendering width of the region (viewport)+-- that contains the ItemFieldWidget, which allows it to compute the+-- line lengths to determine what the target item is for a forward or+-- backward line motion. The boolean argument specifies whether the+-- intervening and target selection item's states are to be set to the+-- current item's state, just as with the 'selectForwardBy' and+-- 'selectBackwardBy' functions.+selectNextLineItem, selectPrevLineItem+ :: Int -- ^ the rendering width of the region that contains the ItemFieldWidget+ -> Bool -- ^ should items between source and destination be set to the source's state?+ -> ItemFieldEventHandler n -- ^ ItemFieldWidget to operate on and output EventM+selectNextLineItem width marking fieldw =+ let renderData = computeLinePosRanges width $ itemField fieldw+ in selectUpdate (select_next_line renderData) marking fieldw+selectPrevLineItem width marking fieldw =+ let renderData = computeLinePosRanges width $ itemField fieldw+ in selectUpdate (select_prev_line renderData) marking fieldw+++selectUpdate :: FieldUpdateFunc -> Bool -> ItemFieldEventHandler n+selectUpdate updfun marking fld =+ let field = itemField fld+ (selrange, field') = updfun field+ firstMarked = head selrange `elem` getMarked field'+ markState = if firstMarked then Marked else Free+ field'' = if marking+ then foldl (changeItemState markState) field' selrange+ else field'+ fld' = fld { itemField = field'' }+ in return fld'+++-- ----------------------------------------------------------------------+-- Marking Functions++toggleMark :: ItemFieldWidget n -> [Int] -> EventM n (ItemFieldWidget n)+toggleMark fieldw =+ let newSt8 = if selected `elem` marked then Free else Marked+ selected = curSel $ itemField fieldw+ marked = getMarked $ itemField fieldw+ in setMark newSt8 fieldw++setMark :: ItemState -> ItemFieldWidget n -> [Int] -> EventM n (ItemFieldWidget n)+setMark newSt8 fieldw = return . foldl (setItemState newSt8) fieldw++toggleAllMarks :: ItemFieldWidget n -> EventM n (ItemFieldWidget n)+toggleAllMarks fieldw = toggleMark fieldw allItems+ where allItems = [0 .. length (itemst8 $ itemField fieldw) - 1]++toggleGroupMarks :: ItemFieldWidget n -> EventM n (ItemFieldWidget n)+toggleGroupMarks fieldw = toggleMark fieldw groupItems+ where groupItems = [fst grng .. snd grng]+ grng = groupRange selected $ items $ itemField fieldw+ selected = curSel $ itemField fieldw++toggleNamedGroupMarks :: T.Text -> ItemFieldWidget n -> EventM n (ItemFieldWidget n)+toggleNamedGroupMarks grpspec fieldw = toggleMark fieldw groupItems+ where groupNames = T.splitOn (T.singleton '.') grpspec+ itms = items $ itemField fieldw+ itemStarts = snd $ mapAccumL (\a i -> let n = numItems i in (a+n, a)) 0 itms+ itemMatchSpans = map (matchGroupItem groupNames) itms+ groupRanges = map (\(s,m) -> if m == 0 then [] else [s .. s + m - 1]) $+ zip itemStarts itemMatchSpans+ groupItems = concat groupRanges++ matchGroupItem :: [T.Text] -> Items -> Int+ matchGroupItem [] i = numItems i+ matchGroupItem (g:gs) (ItemGroup n i) = if n == g then matchGroupItem gs i else 0+ matchGroupItem _ _ = 0++toggleLineMarks :: Ord n => ItemFieldWidget n -> EventM n (ItemFieldWidget n)+toggleLineMarks fieldw =+ withItemFieldWidth fieldw $ \width ->+ let renderData = computeLinePosRanges width $ itemField fieldw+ lens = lineIndices $ renderedLines renderData+ lnum = fst $ curLine (itemField fieldw) renderData+ lrange = if lnum >= length lens+ then error "handleItemFieldEvent index error"+ else lens !! lnum+ Just lbeg = lineFirstIndex lrange+ Just lend = lineLastIndex lrange+ in if lrange == EmptyLine then return fieldw else toggleMark fieldw [lbeg .. lend]+++-- ----------------------------------------------------------------------+-- Item retrieval and manipulation++-- | Returns the index of the currently selected item in the Widget's field+getSelectedItem :: ItemFieldWidget n -> Int+getSelectedItem = curSel . itemField+++-- | Returns the list of the currently marked items in the Widget's field+getMarkedItems :: ItemFieldWidget n -> [Int]+getMarkedItems = getMarked . itemField+++-- | Modifies the state of the specified item in the widget to the new value+setItemState :: ItemState -> ItemFieldWidget n -> Int -> ItemFieldWidget n+setItemState newState widget itemIdx =+ widget { itemField = changeItemState newState (itemField widget) itemIdx }+++-- | Modifies the state of all currently marked items in the widget.+setMarkedItemsState :: ItemState -> ItemFieldWidget n -> ItemFieldWidget n+setMarkedItemsState newState widget =+ foldl (setItemState newState) widget $ getMarkedItems widget
+ src/TextUI/ItemField/Attrs.hs view
@@ -0,0 +1,100 @@+-- | This module defines the various attributes that can be used with+-- an 'ItemFieldWidget'.+module TextUI.ItemField.Attrs where+++import Data.Monoid+import Brick.AttrMap (AttrName, attrName)+import Brick.Util (on)+import Graphics.Vty+++-- | The 'itemAttr' is the base attribute for the entire Widget+itemAttr :: AttrName+itemAttr = attrName "item"+++-- | The 'itemFieldAttr' is the attribute for the items portion of the+-- Widget. It does not apply to the headers or the current selection+-- status.+itemFieldAttr :: AttrName+itemFieldAttr = itemAttr <> attrName "itemField"+++-- | The 'itemFreeAttr' applies to showing an item state that is Free,+-- which is usually the default state for an unselected, un-evaluated+-- item.+itemFreeAttr :: AttrName+itemFreeAttr = itemFieldAttr <> attrName "itemFree"++-- | The 'itemMarkedAttr' applies to showing an item that is Marked+-- for future action.+itemMarkedAttr :: AttrName+itemMarkedAttr = itemFieldAttr <> attrName "itemMarked"++-- | The 'itemGoodAttr' indicates an item that is in the Good state.+itemGoodAttr :: AttrName+itemGoodAttr = itemFieldAttr <> attrName "itemGood"++-- | The 'itemBadAttr' indicates an item that is in the Bad state.+itemBadAttr :: AttrName+itemBadAttr = itemFieldAttr <> attrName "itemBad"++-- | The 'itemCaVaAttr' indicates an item that is in the CaVa state+-- ("ca va" is French for "OK" or "so-so").+itemCaVaAttr :: AttrName+itemCaVaAttr = itemFieldAttr <> attrName "itemModerate"++-- | The 'itemBlankAttr' is an interstitial attribute marker for+-- portions of the ItemField that are to be left blank+itemBlankAttr :: AttrName+itemBlankAttr = itemAttr <> attrName "itemBlank"++-- | The 'itemMoreMessageAttr' is used when the 'ItemField' rendering+-- would overflow the available space, so the bottom of the rendering+-- includes a message indicating there is more to display.+itemMoreMessageAttr :: AttrName+itemMoreMessageAttr = itemFieldAttr <> attrName "itemsMoreMessage"++-- | The 'itemNoneMessageAttr' is used for the message displayed when+-- the 'ItemField' contains no actual items.+itemNoneMessageAttr :: AttrName+itemNoneMessageAttr = itemFieldAttr <> attrName "itemsNoneMessage"++-- | The 'itemSelectedDetailsAttr' is used for the details info for+-- the currently selected item that is displayed at the bottom of the+-- itemfield.+itemSelectedDetailsAttr :: AttrName+itemSelectedDetailsAttr = itemAttr <> attrName "itemSelectedDetails"++-- | The 'itemHeaderAttr' is used for group headers in the ItemField.+itemHeaderAttr :: AttrName+itemHeaderAttr = itemAttr <> attrName "itemHeader"+++-- | This defines the list of default attribute values for this+-- itemfield. To apply these to the default attrbute specifications:+--+-- @+-- App { ...+-- , appAttrMap = const $ applyAttrMappings itemDefaultAttrs def+-- ... }+-- @+--+-- and to override these defaults:+--+-- @+-- App { ...+-- , appAttrMap = const+-- $ applyAttrMappings+-- [ (itemHeaderAddr, fg cyan), ... ]+-- $ applyAttrMappings itemDefaultAttrs def+-- ... }+-- @+itemDefaultAttrs :: [ (AttrName, Attr) ]+itemDefaultAttrs = [ (itemGoodAttr, black `on` green `withStyle` bold)+ , (itemBadAttr, black `on` red)+ , (itemCaVaAttr, black `on` yellow)+ , (itemMoreMessageAttr, currentAttr `withStyle` reverseVideo)+ , (itemHeaderAttr, currentAttr `withStyle` underline)+ ]
+ src/TextUI/ItemField/Layout.hs view
@@ -0,0 +1,292 @@+module TextUI.ItemField.Layout where+++import Data.Monoid ( (<>) )+import Data.Either+import Data.Maybe+import Data.List (mapAccumL)+import qualified Data.Text as T+import Brick.AttrMap+import TextUI.ItemField.Types+import TextUI.ItemField.Attrs+++-- | Pre-compute the rendering information such as the number of items+-- per line and their offset. This information is computed once and+-- used for various calculations. This could have been implemented as+-- a MonadReader context, but the uses are all internal and fairly+-- simple, so direct argument passing is used for now.+data RenderData = RenderData Int [LinePosRange] -- ^ width and line positions+ deriving (Eq, Show)+++renderedLines :: RenderData -> [LinePosRange]+renderedLines (RenderData _ l) = l++renderWidth :: RenderData -> Int+renderWidth (RenderData w _) = w+++-- | LinePosRange is the layout range of the items plotted on a line,+-- indicating the start column and length for that line.+data LinePosRange = LinePosRange Int Int -- start, length+ deriving (Show, Eq)++lineStart, lineWidth, lineEnd :: LinePosRange -> Int+lineStart (LinePosRange s _) = s+lineWidth (LinePosRange _ w) = w+lineEnd (LinePosRange s w) = s + w+++-- | LineIndexRange is the Item indices for each line. This is+-- similar to the LinePosRange, except that the latter has character+-- positions on screen.+data LineIndexRange = LineIndexRange Int Int | EmptyLine deriving (Show, Eq)++lineFirstIndex, lineLastIndex :: LineIndexRange -> Maybe Int+lineFirstIndex (LineIndexRange f _) = Just f+lineFirstIndex EmptyLine = Nothing++lineLastIndex (LineIndexRange _ l) = Just l+lineLastIndex EmptyLine = Nothing+++lineIndices :: [LinePosRange] -> [LineIndexRange]+lineIndices =+ let cvtFun prevEnd (LinePosRange _ w) = (prevEnd + w, nlr prevEnd w)+ nlr p l = if l == 0+ then EmptyLine+ else LineIndexRange p $ p + max 0 (l - 1)+ in snd . mapAccumL cvtFun 0+++ssRep :: ItemState -> (T.Text, Brick.AttrMap.AttrName)+ssRep Free = (T.singleton '.', itemFreeAttr)+ssRep Marked = (T.singleton '*', itemMarkedAttr)+ssRep Good = (T.singleton '+', itemGoodAttr)+ssRep Bad = (T.singleton '!', itemBadAttr)+ssRep CaVa = (T.singleton '~', itemCaVaAttr)++groupSepText :: T.Text+groupSepText = T.singleton ' '+groupSepImg :: (T.Text, AttrName)+groupSepImg = (groupSepText, itemBlankAttr)++aSpace :: (T.Text, AttrName)+aSpace = (T.singleton ' ', itemBlankAttr)++aSpaces :: Int -> (T.Text, AttrName)+aSpaces n = (T.replicate n (T.singleton ' '), itemBlankAttr)+++-------------------------------------------------------------------------+-- Layout Computation and Drawing+-------------------------------------------------------------------------++-- | Given the current display width, computes the LinePosRange (x offset+-- and count) of each line that would be displayed. The display of+-- items for each group will be wrapped such that it does not exceed+-- the display width; the exception is if the group text would exceed+-- the display width, in which case there is no wrapping for the+-- groups and horizontal scrolling is indicated and the render data+-- width will be reset to the maximum width of the longest rendered+-- line without wrapping.+computeLinePosRanges :: Int -> ItemField -> RenderData+computeLinePosRanges dispWidth field =+ case partitionEithers $ layout (items field) of+ ([], l) -> RenderData dispWidth $ concat l+ (reqWidths, _) -> if maximum reqWidths == dispWidth+ then abort+ else computeLinePosRanges (maximum reqWidths) field+ where layout = snd . mapAccumL lay 0+ lay ind (ItemGroup nm gs) =+ (ind, snd $ lay (ind + T.length nm + sepwidth) gs)+ -- next is case where retried, but Items 0 so plot, don't Left again+ lay ind (Items 0) | ind <= dispWidth =+ (ind, Right [LinePosRange ind 0])+ lay ind (Items n) =+ let rwidth = dispWidth - ind+ (a,b) = n `divMod` rwidth+ rng = map (LinePosRange ind) $ replicate a rwidth <> endrng+ endrng = [b | a == 0 || b > 0 ]+ in if ind >= dispWidth+ then (ind, Left $ ind + n)+ else (ind, Right rng)+ sepwidth = T.length groupSepText+ abort = error $ "line computation cycling with " <> show dispWidth+++-- | This is the overall drawing routine. It generates a number of+-- lines that include the individual item states (via the `plot`+-- function below), along with any general messages or placeholders.+redrawSt8Lines :: Int -> [Items] -> [ItemState] -> RenderData -> [PlotLine]+redrawSt8Lines nLines si ss rdata =+ let sl = plot si ss rdata+ nCols = renderWidth rdata+ moreMsg = T.pack $ take nCols "+++ more +++"+ noneMsg = T.pack $ take nCols "[None identified yet]"+ centerTextLn t a = let ls = (nCols - T.length t) `div` 2+ rs = nCols - ls - T.length t+ in [ aSpaces ls, (t, a), aSpaces rs]+ slPlusMore = take (nLines-1) sl <>+ [centerTextLn moreMsg itemMoreMessageAttr]+ in if null si || cntItems si == 0+ then [centerTextLn noneMsg itemNoneMessageAttr]+ else if length sl <= nLines then sl else slPlusMore+++type PlotLine = [(T.Text, Brick.AttrMap.AttrName)]+++-- | This is the main internal drawing routine. Given the RenderData+-- calculations, the array of items, and the matching array of current+-- item states, this generates a list of each plotline.+plot :: [Items] -> [ItemState] -> RenderData -> [PlotLine]+plot ss st8st8 rdata = concat $ snd $ mapAccumL plt (st8st8, renderedLines rdata) ss+ where plt (si,rl) (Items 0) = ((si, tail rl), [[]])+ plt (si,rl) (Items n) =+ let (xx,yy) = splitAt curw $ si <> repeat Free+ rng = head rl+ curw = lineWidth rng+ thisl = map ssRep xx+ pltAcc' = (yy, tail rl)+ (pltAcc'', cons) = plt pltAcc' $ Items $ n - curw+ in if n <= curw+ then (pltAcc', [thisl])+ else (pltAcc'', thisl : cons)+ plt pltAcc (ItemGroup nm gs) =+ let (pltAcc', grpl) = plt pltAcc gs+ title = [(nm, itemHeaderAttr), groupSepImg]+ prefixes = title : repeat [aSpaces $ T.length nm + 1]+ glines = zipWith (<>) prefixes grpl+ in (pltAcc', glines)+++-------------------------------------------------------------------------+-- Information+-------------------------------------------------------------------------++-- | Given the ItemField state, return the rendered line number and+-- character offset for the current selected item.+curLine :: ItemField -> RenderData -> (Int, Int)+curLine st rdata =+ let cs = curSel st+ lens = renderedLines rdata+ findLC n _ [] = (n,0) -- startup condition, no items+ findLC n c (l:ls) = if c < l+ then (n, c)+ else findLC (n+1) (c-l) ls+ in findLC 0 cs $ map lineWidth lens++-- | Given coordinates, return an indication of which item(s) is+-- selected by those coordinates+coordinatesSel :: ItemField -> RenderData -> (Int, Int) -> Maybe ItemLocation+coordinatesSel field rdata (col,row) =+ let lens = renderedLines rdata+ indices = lineIndices lens+ li = indices !! row+ lr = lens !! row+ itm = (col - lineStart lr) + fromJust (lineFirstIndex li)+ in if row >= length lens+ then Nothing+ else case lineFirstIndex li of+ Nothing -> Nothing+ Just l -> if col >= lineEnd lr+ then Nothing+ else if col < lineStart lr+ then coordinatesGroup field col l+ else Just $ ItemLocNum itm++coordinatesGroup :: ItemField -> Int -> Int -> Maybe ItemLocation+coordinatesGroup field col atItemNum =+ let itms = items field+ walkToGroup _ [] = Nothing+ walkToGroup (curIdx,grps) (ItemGroup nm ii : is) =+ walkToGroup (curIdx, (T.length nm, nm) : grps) (ii : is)+ walkToGroup (curIdx,grps) (Items n : is)+ | curIdx + n - 1 < atItemNum = walkToGroup (curIdx + n, []) is+ | curIdx /= atItemNum = Nothing -- not at first line of group+ | otherwise = unwind (0,[]) $ reverse grps+ unwind _ [] = Nothing+ unwind (al,ag) ((l,g):gs) =+ if col < al + l+ then Just $ ItemLocGroup atItemNum $ T.intercalate (T.singleton '.') $ reverse $ g : ag+ else unwind (al + l + 1, g : ag) gs+ in walkToGroup (0,[]) itms++data ItemLocation = ItemLocNum Int | ItemLocGroup Int T.Text deriving Show+++-------------------------------------------------------------------------+-- Moving and selecting+-------------------------------------------------------------------------++pos_coordinates :: ItemField -> RenderData -> Maybe (Int, Int)+pos_coordinates field rdata =+ let (cl,cc) = curLine field rdata+ lens = renderedLines rdata+ lrange = lens !! cl+ curX = toEnum $ cc + lineStart lrange+ curY = toEnum cl+ in if cl >= length lens then Nothing else Just (curX, curY)+++update_position :: ([ItemState] -> Int -> Int) -> ItemField -> ([Int], ItemField)+update_position update_func field =+ let oldsel = curSel field+ newsel = update_func (itemst8 field) oldsel+ newfield = field { curSel = newsel }+ sel_range = if oldsel < newsel+ then [oldsel .. newsel]+ else [newsel .. oldsel]+ in (sel_range, newfield)+++bounded :: Ord b => (a -> b) -> b -> b -> a -> b+bounded f minV maxV = max minV . min maxV . f++boundedIdx :: Foldable t => (a -> Int) -> t c -> a -> Int+boundedIdx f l = bounded f 0 (length l - 1)+++-- | The FieldUpdateFunc modifies the current selection in an+-- ItemField, returning the old selection, the new selection, the+-- range over which the selection changed, and the updated field.+type FieldUpdateFunc = ItemField -> ([Int], ItemField)++select_next, select_prev :: FieldUpdateFunc+select_next = update_position (boundedIdx succ)+select_prev = update_position $ boundedIdx pred++select_forward_n, select_backward_n :: Int -> FieldUpdateFunc+select_forward_n n = update_position $ boundedIdx (n +)+select_backward_n n = update_position $ boundedIdx (\x -> x - n)+++select_next_line, select_prev_line :: RenderData -> FieldUpdateFunc+select_next_line rdata field =+ let lens = renderedLines rdata+ (cl, cc) = curLine field rdata+ cc' = if (cl + 1) < length lens+ then min cc $ nextLW (cl + 1) - 1+ else cc+ nextLW ln = if ln == length lens then 0+ else let tlw = lineWidth (lens !! ln)+ in if tlw > 0 then tlw+ else nextLW $ ln + 1+ inc = cc' + (lineWidth (lens !! cl) - cc)+ in update_position (boundedIdx (inc +)) field+++select_prev_line rdata field =+ let lens = renderedLines rdata+ (cl,cc) = curLine field rdata+ prevLW ln = if ln == 0 then 0+ else let tlw = lineWidth $ lens !! ln+ in if tlw > 0 then tlw+ else prevLW $ ln - 1+ cc' = if cl > 0+ then prevLW (cl-1) - min cc (prevLW (cl-1) - 1)+ else 0+ dec = cc + cc'+ in update_position (boundedIdx (\n -> n - dec)) field
+ src/TextUI/ItemField/Operations.hs view
@@ -0,0 +1,38 @@+module TextUI.ItemField.Operations where+++import Data.List (elemIndices)+import TextUI.ItemField.Types+++-- | Updates the state of the specified item number to the new state.+changeItemState :: ItemState -> ItemField -> Int -> ItemField+changeItemState newSt8 field st8idx =+ let ss = itemst8 field+ (b,a) = splitAt st8idx ss+ a' = if null a then [] else tail a+ in if null ss || st8idx >= length ss+ then field+ else field { itemst8 = b ++ (newSt8 : a') }+++-- | Returns the list of the currently marked items in the field+getMarked :: ItemField -> [Int]+getMarked = elemIndices Marked . itemst8+++-- | groupRange returns a tuple of the first and last indices of items+-- in group of which item n is a member.+groupRange :: NumItems -> [Items] -> (NumItems, NumItems)+groupRange _ [] = (0,0)+groupRange n (Items c:ss) = let (b,e) = groupRange (n - c) ss+ in if c > n then (0,max 0 (c-1)) else (c+b, c+e)+groupRange n (ItemGroup _ c:ss) = let gl = cntItems [c]+ (b,e) = groupRange (n - gl) ss+ in if gl > n then groupRange n [c] else (gl+b, gl+e)+++-- | setAllFree Converts the state of all items in the field to Free+setAllFree :: ItemField -> ItemField+setAllFree field = let num = cntItems $ items field+ in field { itemst8 = replicate num Free }
+ src/TextUI/ItemField/Types.hs view
@@ -0,0 +1,59 @@+module TextUI.ItemField.Types where++import qualified Data.Text as T+++type GroupName = T.Text+type NumItems = Int+data Items = ItemGroup GroupName Items | Items NumItems deriving Show+data ItemState = Free | Marked | Good | Bad | CaVa deriving (Show,Eq)+type ItemIdent = Maybe (Int -> ItemState -> T.Text)++-- KWQ: if Items were Foldable, could auto-compute length?+-- KWQ: if Items were Foldable, then ItemField would be Foldable? If items and itemst8 were combined as :: [(Item, ItemState)] ?? (or otherwise ensuring that items and itemst8 were matching in length+-- KWQ: ItemField is Functor over itemst8?++numItems :: Items -> NumItems+numItems (ItemGroup _ x) = numItems x+numItems (Items n) = n++-- | Returns the count of the number of items+cntItems :: [Items] -> NumItems+cntItems = sum . map numItems++++-- | The ItemField is the central management of the set of items and+-- their current states. There is simply a number of collections of+-- items, expressing only the number of items in the collection.,+-- although there may be a group name associated with each collection.+--+-- Each item has a corresponding state, which is maintained in+-- parallel and an item's state can be modified.+data ItemField = ItemFld { curSel :: Int+ -- ^ Currently "selected" item (usually+ -- where the cursor is)+ , items :: [Items]+ -- ^ Actual item counts, possibly with a group name+ , itemst8 :: [ItemState]+ -- ^ Current state of each item (length == cntItems)+ , elemIdent :: ItemIdent+ -- ^ Function returning an item description+ -- given the item number+ }+++instance Show ItemField where+ showsPrec p s = showParen (p > 10) $+ showString "ItemFld @ " . shows (curSel s)+ . showString " with " . shows (length $ itemst8 s)+ . showString " items:"+ . shows (items s)+ . showString " states:"+ . shows (itemst8 s)+++-- | Standard factory to create an ItemField from a specification of+-- Items and their potential identification function.+newItemField :: [Items] -> ItemIdent -> ItemField+newItemField itms = ItemFld 0 itms (replicate (cntItems itms) Free)
+ test/test_itemfield.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Test.HUnit+import Test.QuickCheck+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import qualified Data.Text as T+import Data.Monoid+import Data.Maybe+import Control.Monad+import TextUI.ItemField+import TextUI.ItemField.Operations+import TestDataGen+++main = defaultMain+ [ c1 , c2 , c3 , c4 , c5+ , s1 , s2+ , o1 , o2 , o3 , o4 , o5 , o6 , o7+ ]+++c1 = testProperty "count items" $ \(BoundedItems i t) -> t == cntItems i++c2 = testProperty "count new field items" $+ \(BoundedItems i t) -> t == (cntItems $ items $ newItemField i Nothing)++c3 = testProperty "count field items with state" $+ \(BoundedItems i t) s c -> t == (cntItems $ items $ ItemFld c i s Nothing)++c4 = testProperty "count field items with mixed states" $+ \(BoundedStateItems i s t) c ->+ length s == t && t == (cntItems $ items $ ItemFld c i s Nothing)++c5 = testProperty "count generated field items" $+ \i -> length (itemst8 i) == cntItems (items i)++s1 = testProperty "item field no description showable" $+ \(BoundedStateItems i s t) c ->+ show (ItemFld c i s Nothing) ++ "ok" /= "ok"++s2 = testProperty "item field with description showable" $+ \(BoundedStateItems i s t) c ->+ let f = (Just $ const $ const $ T.pack "item")+ in show (ItemFld c i s f) ++ "ok" /= "ok"++o1 = testProperty "change single item state is reversable" $+ \i s -> let n = curSel i+ i' = changeItemState s i n+ o_s = itemst8 i !! n+ i'' = changeItemState o_s i n+ in and [ itemst8 i'' == itemst8 i+ , null (itemst8 i') || s `elem` itemst8 i'+ , length (itemst8 i) == length (itemst8 i')+ , length (itemst8 i') == length (itemst8 i'')+ ]++o2 = testProperty "change multiple item state is reversable" $+ \i s -> let ns = filter (\x -> x `mod` 3 == 0) [0 .. length (itemst8 i) - 1]+ i' = foldl (changeItemState s) i ns+ o_s = itemst8 i+ i'' = foldl (\f p -> changeItemState (o_s !! p) f p) i' ns+ in and [ itemst8 i'' == itemst8 i+ , null (itemst8 i') || s `elem` itemst8 i'+ , length (itemst8 i) == length (itemst8 i')+ , length (itemst8 i') == length (itemst8 i'')+ ]++o3 = testProperty "change all item state is reversable" $+ \i s -> let ns = [0 .. length (itemst8 i) - 1]+ i' = foldl (changeItemState s) i ns+ o_s = itemst8 i+ i'' = foldl (\f p -> changeItemState (o_s !! p) f p) i' ns+ in and [ itemst8 i'' == itemst8 i+ , null (itemst8 i') || s `elem` itemst8 i'+ , length (itemst8 i) == length (itemst8 i')+ , length (itemst8 i') == length (itemst8 i'')+ ]++o4 = testProperty "retrieve marked" $+ \i -> (length $ filter ((==) Marked) $ itemst8 i) == (length $ getMarked i)+++o5 = testCase "group ranges" $+ let itms = [ Items 3+ , ItemGroup "g1" $ Items 5+ , Items 0+ , ItemGroup "g2" $ ItemGroup "g3" $ ItemGroup "g4" $ Items 2+ , ItemGroup "g2" $ ItemGroup "g3" $ Items 4+ , Items 9+ , ItemGroup "empty" $ Items 0+ , Items 5+ ]+ expected = replicate 3 (0,2) <>+ replicate 5 (3,7) <>+ replicate 2 (8,9) <>+ replicate 4 (10,13) <>+ replicate 9 (14,22) <>+ replicate 5 (23,27) <>+ replicate 2 (28,28) -- just final loc if beyond end.+ in map (flip groupRange itms) [0 .. 29] @?= expected++o6 = testProperty "empty group ranges" $ \n -> groupRange n [] == (0,0)++o7 = testProperty "setting all to free state" $+ \i -> replicate (cntItems $ items i) Free == (itemst8 $ setAllFree i)
+ test/test_layout.hs view
@@ -0,0 +1,405 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Main where++import Test.HUnit+import Test.QuickCheck+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import qualified Data.Text as T+import Data.Default+import Data.Monoid+import Control.Monad+import Brick.AttrMap (AttrName)+import TextUI.ItemField+import TextUI.ItemField.Layout+import Graphics.Vty.Image+import TestDataGen+++main = defaultMain tests+++instance Arbitrary LinePosRange where+ arbitrary = liftM2 LinePosRange (choose (0,500)) (choose (0,500))++ shrink (LinePosRange a b) = [LinePosRange a' b'+ | a' <- shrink a, b' <- shrink b]++++maxItemGroupLine = maximum . (:) 0 . map groupsize . items+ where groupsize (ItemGroup g r) = T.length g + 1 + groupsize r+ groupsize _ = 0+maxLongGroupLine width = foldl maxLongLine 0 . map fullsize . items+ where fullsize (ItemGroup g r) =+ let gsize = T.length g + 1+ subsize = fullsize r+ in (fst subsize + gsize, snd subsize + gsize)+ fullsize (Items n) = (0, n) -- + 1)+ maxLongLine o (g,n) = if g >= width then max o n else o+maxItemLine = maximum . ((:) 0) . map linesize . items+ where linesize (ItemGroup g r) = T.length g + 1 + linesize r+ linesize (Items n) = n+++tests =+ [ testGroup "RenderData"+ [ testCase "Empty Lines" $ [] @=? renderedLines (RenderData 1 [])+ , testProperty "recover lines" recover_lines++ , testProperty "rendered width calculation" $+ \f lpr1 lpr2 ->+ let (rdata,img) = itemFieldRender (ItemFieldWidget "hi" f) def w h+ w = lineWidth lpr1+ h = lineWidth lpr2+ expected_width = if maxItemGroupLine f >= w+ then maxLongGroupLine w f+ else w+ in expected_width == renderWidth rdata++ -- , testProperty "render zero items" $+ -- \w h -> w == (renderWidth $ fst $+ -- itemFieldRender (ItemFieldWidget "hi" $+ -- newItemField [Items 0] Nothing) def w h)++ , testCase "rendered width no items show centered empty message" $+ let (rdata,img) = itemFieldRender (ItemFieldWidget "hi" f) def w 100+ f = newItemField [] Nothing+ w = 100+ in assertEqual "" w (imageWidth img)++ , testCase "rendered width zero items" $+ let (rdata,img) = itemFieldRender (ItemFieldWidget "hi" f) def 100 100+ f = newItemField [Items 0] $ Just $ \a b -> "hi"+ in assertEqual "" 100 (imageWidth img) -- shows none message++ , testCase "rendered width too many items" $+ let (rdata,img) = itemFieldRender (ItemFieldWidget "hi" f) def w 3+ f = newItemField [Items 100] $ Just $ \a b -> "hi"+ w = 5+ in assertEqual "" w (imageWidth img)++ , testProperty "rendered width" $ prop_render_width++ , testCase "single group, one item per line, width" $+ let (rdata,img) = itemFieldRender (ItemFieldWidget "hi" f) def w h+ w = 11+ h = 500+ expected_width = 11+ f = newItemField+ [ItemGroup "grp1" (ItemGroup "grp0" (Items 4))]+ Nothing+ in assertEqual "" expected_width (imageWidth img)++ ]++ , testGroup "LineIndices"+ [ testProperty "Initial 0" line_index_zero_start+ , testProperty "Final count" line_index_final_length+ , testCase "No elements"+ $ (null $ lineIndices []) @? "empty output for empty input"+ , testCase "Zero size first element"+ $ Just 4 @=? (lineLastIndex $+ last $ lineIndices [ LinePosRange 3 0+ , LinePosRange 10 5+ ])+ , testCase "Zero size middle element"+ $ Just 7 @=? (lineLastIndex $+ last $ lineIndices [ LinePosRange 10 5+ , LinePosRange 3 0+ , LinePosRange 5 3+ ])+ , testCase "Zero size last element"+ $ Nothing @=? (lineLastIndex $+ last $ lineIndices [ LinePosRange 10 5+ , LinePosRange 3 0+ ])+ ]++ , testGroup "Line Computations" line_computations++ , testGroup "CursorPositioning"+ [ testProperty "valid coordinates" prop_coordinates+ ]+ ]+++prop_render_width f w =+ let (rdata,img) = itemFieldRender (ItemFieldWidget "hi" f) def w h+ h = 500+ expected_width = if maxItemGroupLine f >= w+ then maxLongGroupLine w f+ else min (maxItemLine f) w+ in w > 0 && w < 500 && cntItems (items f) > 0 ==>+ expected_width == imageWidth img+++prop_coordinates f w =+ let pc = pos_coordinates f rdata+ (Just (x,y)) = pc+ numItems = cntItems $ items f+ rdata = computeLinePosRanges w f+ in if numItems == 0+ then Nothing == pc+ else x >= 0 && y >= 0+++recover_lines lines = lines == (renderedLines $ RenderData 1 lines)++line_index_zero_start lines =+ let li = lineIndices lines+ line1 = head li+ in if null lines+ then null li+ else if line1 == EmptyLine+ then Nothing == lineFirstIndex line1+ else Just 0 == lineFirstIndex line1++line_index_final_length lines =+ let li = lineIndices lines+ num = foldl (\a l -> a + lineWidth l) 0 lines+ lineLast = last li+ last_index = lineLastIndex lineLast+ in if null lines+ then [] == li+ else if num == 0+ then Nothing == last_index+ else if lineLast == EmptyLine+ then last_index == Nothing+ else last_index == Just (num - 1)+++line_computations = [ line_comp1+ , line_comp2+ , line_comp3+ , line_comp4+ , line_comp5+ , line_comp6+ , line_comp7+ , line_comp8+ , line_comp9+ , line_comp10+ , line_comp11+ , line_comp12+ ]+++line_comp1 = testCase "empty itemfield renderdata" $+ RenderData 600 [] @=?+ computeLinePosRanges 600 (ItemFld 0 [] [] Nothing)++line_comp2 = testProperty "renderdata width matches value passed or full width" $+ \width itemfield ->+ let RenderData w _ = computeLinePosRanges width itemfield+ in w >= width++line_comp3 = testProperty "single Item per line RenderData" $+ \i ->+ let ttl = abs i+ items = [Items ttl]+ width = 10000 -- each items should be on a single line+ field = newItemField items Nothing+ RenderData w lprs = computeLinePosRanges width field+ in and [ w == width+ , length lprs == 1+ , head lprs == LinePosRange 0 ttl+ ]++lineHdrLen (Items _) = 0+lineHdrLen (ItemGroup g i) = T.length g + 1 + lineHdrLen i++line_comp4 = testProperty "single Item set per line RenderData" $+ \items ->+ let ttl = cntItems items+ width = 10000 -- each items should be on a single line+ field = newItemField items Nothing+ RenderData w lprs = computeLinePosRanges width field+ in and [ length lprs == length items+ , map lineStart lprs == map lineHdrLen items+ ]++sample_field1 = newItemField [ Items 13+ , ItemGroup "g1" $ Items 15+ , Items 0+ , ItemGroup "g2" $ ItemGroup "grp3" $ ItemGroup "g4" $ Items 6+ , ItemGroup "g2" $ ItemGroup "g3" $ Items 4+ , Items 90+ , ItemGroup "empty" $ Items 0+ , Items 5+ ] Nothing+++line_comp5 = testCase "Expected lineranges for width greater than all group titles" $+ ((renderedLines $ computeLinePosRanges 15 sample_field1)+ @?=+ sample_field1_linepos_width15)++sample_field1_linepos_width15 =+ [ LinePosRange 0 13+ , LinePosRange 3 (15 - 3), LinePosRange 3 3+ , LinePosRange 0 0+ , LinePosRange (3 + 5 + 3) (15 - 11), LinePosRange (3 + 5 + 3) 2+ , LinePosRange (3 + 3) 4+ , LinePosRange 0 15, LinePosRange 0 15, LinePosRange 0 15, LinePosRange 0 15+ , {- + -} LinePosRange 0 15, LinePosRange 0 15+ , LinePosRange 6 0+ , LinePosRange 0 5+ ]++line_comp6 = testCase "Expected lineranges for width shorter than some group titles" $+ ((renderedLines $ computeLinePosRanges 10 sample_field1)+ @?=+ [ LinePosRange 0 13+ , LinePosRange 3 14, LinePosRange 3 1+ , LinePosRange 0 0+ , LinePosRange (3 + 5 + 3) 6+ , LinePosRange (3 + 3) 4+ , LinePosRange 0 17, LinePosRange 0 17, LinePosRange 0 17, LinePosRange 0 17, LinePosRange 0 17, LinePosRange 0 5+ , LinePosRange 6 0+ , LinePosRange 0 5+ ])++line_comp7 = testCase "drawing no items output wide width tall" $+ let width = 50+ len = 500+ itms = []+ st8s = []+ rdata = computeLinePosRanges width $ newItemField itms Nothing+ redraw = redrawSt8Lines len itms st8s rdata+ blanks n = (T.replicate n (T.singleton ' ') , itemBlankAttr)+ noneline = [ blanks 14+ , (T.pack "[None identified yet]", itemNoneMessageAttr)+ , blanks 15+ ]+ in [ noneline ] @=? redraw+++line_comp8 = testCase "drawing expected output for wide width tall" $+ let width = 50+ len = 500+ itms = items sample_field1+ st8s = itemst8 sample_field1+ rdata = computeLinePosRanges width $ newItemField itms Nothing+ redraw = redrawSt8Lines len itms st8s rdata+ freedot = (".",itemFreeAttr)+ blank = (" ",itemBlankAttr)+ expected = [replicate 13 freedot+ ,[("g1",itemHeaderAttr) ,blank] <>+ replicate 15 freedot+ ,[]+ ,[("g2",itemHeaderAttr),blank+ ,("grp3",itemHeaderAttr),blank+ ,("g4",itemHeaderAttr),blank] <>+ replicate 6 freedot+ ,[("g2",itemHeaderAttr),blank+ ,("g3",itemHeaderAttr),blank+ ,freedot,freedot,freedot,freedot]+ , replicate 50 freedot+ , replicate 40 freedot+ ,[("empty",itemHeaderAttr),blank]+ ,[freedot,freedot,freedot,freedot,freedot]+ ]+ in expected @=? redraw++sample_field1_linepos_width50 =+ [ LinePosRange 0 13+ , LinePosRange 3 15+ , LinePosRange 0 0+ , LinePosRange (3 + 5 + 3) 6+ , LinePosRange (3 + 3) 4+ , LinePosRange 0 49, LinePosRange 0 41+ , LinePosRange 6 0+ , LinePosRange 0 5+ ]+++line_comp9 = testCase "drawing expected output for medium width tall" $+ let width = 15+ len = 500+ itms = items sample_field1+ st8s = itemst8 sample_field1+ rdata = computeLinePosRanges width $ newItemField itms Nothing+ redraw = redrawSt8Lines len itms st8s rdata+ freedot = (".",itemFreeAttr)+ blank = (" ",itemBlankAttr)+ expected = [replicate 13 freedot+ ,[("g1",itemHeaderAttr) ,blank] <>+ replicate 12 freedot+ ,[(" ",itemBlankAttr)+ ,freedot,freedot,freedot]+ ,[]+ ,[("g2",itemHeaderAttr),blank+ ,("grp3",itemHeaderAttr),blank+ ,("g4",itemHeaderAttr),blank] <>+ replicate 4 freedot+ ,[(" ",itemBlankAttr)+ ,(" ",itemBlankAttr)+ ,(" ",itemBlankAttr)+ ,freedot,freedot]+ ,[("g2",itemHeaderAttr),blank+ ,("g3",itemHeaderAttr),blank+ ,freedot,freedot,freedot,freedot]+ , replicate 15 freedot+ , replicate 15 freedot+ , replicate 15 freedot+ , replicate 15 freedot+ , replicate 15 freedot+ , replicate 15 freedot+ ,[("empty",itemHeaderAttr),blank]+ ,[freedot,freedot,freedot,freedot,freedot]+ ]+ tl = 1+ -- in (expected !! tl) @=? (redraw !! tl)+ in expected @=? redraw+++line_comp10 = testCase "empty but width is too short for none message" $+ let width = 15+ len = 500+ itms = []+ st8s = []+ rdata = computeLinePosRanges width $ newItemField itms Nothing+ redraw = redrawSt8Lines len itms st8s rdata+ blanks n = (T.replicate n (T.singleton ' ') , itemBlankAttr)+ noneline = [ (T.empty, itemBlankAttr)+ , (T.pack+ (take width "[None identified yet]")+ , itemNoneMessageAttr)+ , blanks 0+ ]+ in [noneline] @=? redraw++line_comp11 = testCase "drawing Items 0 output wide width tall" $+ let width = 50+ len = 500+ itms = [Items 0]+ st8s = []+ rdata = computeLinePosRanges width $ newItemField itms Nothing+ redraw = redrawSt8Lines len itms st8s rdata+ blanks n = (T.replicate n (T.singleton ' ') , itemBlankAttr)+ msg = "[None identified yet]"+ lpad = (width - (length msg + 1)) `div` 2+ rpad = width - lpad - length msg+ noneline = [ blanks lpad+ , (T.pack msg, itemNoneMessageAttr)+ , blanks rpad+ ]+ in [noneline] @=? redraw++line_comp12 = testCase "drawing with not enough state elements assumes Free" $+ let width = 50+ len = 500+ itms = [ItemGroup "a" $ Items 2, Items 4]+ st8s = []+ rdata = computeLinePosRanges width $ newItemField itms Nothing+ redraw = redrawSt8Lines len itms st8s rdata+ blank = (T.singleton ' ', itemBlankAttr)+ freedot = (".",itemFreeAttr)+ expected = [ [("a",itemHeaderAttr),blank,freedot,freedot]+ , [ freedot, freedot, freedot, freedot ]+ ]+ expLines = [LinePosRange 2 2, LinePosRange 0 4]+ in (expected, expLines) @=? (redraw, renderedLines rdata)