diff --git a/compat/brick_015plus/TextUI/ItemField/BrickHelper.hs b/compat/brick_015plus/TextUI/ItemField/BrickHelper.hs --- a/compat/brick_015plus/TextUI/ItemField/BrickHelper.hs +++ b/compat/brick_015plus/TextUI/ItemField/BrickHelper.hs @@ -8,6 +8,18 @@ import Brick.Widgets.Core (Named(..)) import Data.Monoid ((<>)) import Lens.Micro ((^.)) +import Control.Concurrent + +-- Brick 0.16 introduces the BChan to abstract over the underlying +-- Chan implementation. + +type BChan = Chan + +newBChan :: Int -> IO BChan +newBChan = const . newChan + +writeBChan = writeChan +readBChan = readChan -- | When processing a global EvMouseDown VtyEvent, the coordinates of diff --git a/compat/brick_016/TextUI/ItemField/BrickHelper.hs b/compat/brick_016/TextUI/ItemField/BrickHelper.hs new file mode 100644 --- /dev/null +++ b/compat/brick_016/TextUI/ItemField/BrickHelper.hs @@ -0,0 +1,61 @@ +module TextUI.ItemField.BrickHelper + ( getEventWidgetLocation + , BChan, newBChan, writeBChan, readBChan + ) + 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 ((^.)) +import Brick.BChan (BChan, newBChan, writeBChan, readBChan) + + +-- | 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 clicked 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 + + +-- brick now uses bounded channels (Brick.BChan.BChan for event communications instead of Control.Concurrent.Chan unbounded channels +-- Brick.List now has listModify for modifying the selected element +-- hBox and vBox use more efficient DList data struct diff --git a/compat/brick_pre015/TextUI/ItemField/BrickHelper.hs b/compat/brick_pre015/TextUI/ItemField/BrickHelper.hs --- a/compat/brick_pre015/TextUI/ItemField/BrickHelper.hs +++ b/compat/brick_pre015/TextUI/ItemField/BrickHelper.hs @@ -1,5 +1,7 @@ module TextUI.ItemField.BrickHelper - (getEventWidgetLocation) + ( getEventWidgetLocation + , BChan, newBChan, writeBChan, readBChan + ) where import Brick.Main (lookupViewport, lookupExtent, clickedExtent) @@ -8,6 +10,18 @@ import Brick.Widgets.Core (Named(..)) import Data.Monoid ((<>)) import Lens.Micro ((^.)) +import Control.Concurrent + +-- Brick 0.16 introduces the BChan to abstract over the underlying +-- Chan implementation. + +type BChan = Chan + +newBChan :: Int -> IO BChan +newBChan = const . newChan + +writeBChan = writeChan +readBChan = readChan -- | When processing a global EvMouseDown VtyEvent, the coordinates of diff --git a/examples/workreport.hs b/examples/workreport.hs --- a/examples/workreport.hs +++ b/examples/workreport.hs @@ -23,6 +23,7 @@ import Brick.Widgets.Border import Lens.Micro ((^.), Lens', (.~), (&)) import Lens.Micro.TH (makeLenses) +import TextUI.ItemField.BrickHelper (BChan, newBChan, writeBChan) import Control.Concurrent import Control.Monad import Control.Monad.IO.Class @@ -33,13 +34,13 @@ data WorkerTeams n = WorkerTeams { _workers :: ItemFieldWidget n - , _reqChannel :: Chan WorkEvent + , _reqChannel :: BChan WorkEvent } makeLenses ''WorkerTeams -setupFactory :: n -> Chan WorkEvent -> WorkerTeams n +setupFactory :: n -> BChan WorkEvent -> WorkerTeams n setupFactory n = let teams = [ ItemGroup "Team 1" (Items 28) , ItemGroup "Team 2" (Items 238) @@ -51,7 +52,6 @@ , ItemGroup "Team 5" $ Items 0 , ItemGroup "Team 6" $ Items 3 ] - -- teams = [] -- alternative: no workers, not very interesting in WorkerTeams (ItemFieldWidget n $ newItemField teams Nothing) @@ -135,17 +135,14 @@ in liftIO (mapM_ (startwork chan) marked) >> continue wt -doWork :: Chan WorkEvent -> Int -> IO () +doWork :: BChan WorkEvent -> Int -> IO () doWork reportChan myId = do r <- randomRIO (100000,3000000) threadDelay r s <- ([Good, Bad, Pending] !!) <$> randomRIO (0,2) - writeChan reportChan $ WorkerFinished myId s + writeBChan reportChan $ WorkerFinished myId s when (s == Pending) $ 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 @@ -168,7 +165,7 @@ main :: IO () main = do - chan <- newChan + chan <- newBChan 100 let allworkers = setupFactory WorkerTeamsName chan app = App { appDraw = drawWorkers , appHandleEvent = workEvent diff --git a/itemfield.cabal b/itemfield.cabal --- a/itemfield.cabal +++ b/itemfield.cabal @@ -1,5 +1,5 @@ name: itemfield -version: 1.2.2.1 +version: 1.2.3.0 synopsis: A brick Widget for selectable summary of many elements on a terminal description: @@ -32,18 +32,21 @@ * 1.2.2.0 -- added compatibility for GHC7.10 . * 1.2.2.1 -- added stack.yaml for using itemfield with stack + . + * 1.2.3.0 -- added brick 0.16 compatibility license: BSD3 license-file: LICENSE author: Kevin Quick maintainer: quick@sparq.org -copyright: Kevin Quick, 2013-2016 +copyright: Kevin Quick, 2013-2017 category: Graphics, Console build-type: Simple cabal-version: >=1.8 extra-source-files: compat/brick_015plus/TextUI/ItemField/BrickHelper.hs compat/brick_pre015/TextUI/ItemField/BrickHelper.hs + compat/brick_016/TextUI/ItemField/BrickHelper.hs compat/base_pre48/Compat.hs compat/base48/Compat.hs @@ -56,7 +59,7 @@ , TextUI.ItemField.Layout , TextUI.ItemField.BrickHelper , Compat - build-depends: vty < 5.14 + build-depends: vty , text < 1.3 , microlens < 0.5 if flag(base48) @@ -65,12 +68,16 @@ else build-depends: base < 4.8 hs-source-dirs: compat/base_pre48 - if flag(brick015plus) - build-depends: brick >= 0.15 - hs-source-dirs: compat/brick_015plus + if flag(brick016) + build-depends: brick >= 0.16 + hs-source-dirs: compat/brick_016 else - build-depends: brick >= 0.13 && < 0.15 - hs-source-dirs: compat/brick_pre015 + if flag(brick015) + build-depends: brick >= 0.15 && < 0.16 + hs-source-dirs: compat/brick_015plus + else + build-depends: brick >= 0.13 && < 0.15 + hs-source-dirs: compat/brick_pre015 ghc-options: -Wall -fno-warn-unused-do-bind -O3 @@ -78,10 +85,14 @@ Description: Build example programs Default: True -Flag brick015plus - Description: true for Brick version 0.15 or later +Flag brick016 + Description: true for Brick version 0.16 or later Default: True +Flag brick015 + Description: true for Brick version 0.15.x + Default: True + Flag base48 Description: base 4.8 or later Default: True @@ -94,19 +105,23 @@ executable bookcase if !flag(examples) Buildable: False - hs-source-dirs: src, examples + hs-source-dirs: examples if flag(base48) build-depends: base >= 4.8 && < 5.0 hs-source-dirs: compat/base48 else build-depends: base < 4.8 hs-source-dirs: compat/base_pre48 - if flag(brick015plus) - build-depends: brick >= 0.15 - hs-source-dirs: compat/brick_015plus + if flag(brick016) + build-depends: brick >= 0.16 + hs-source-dirs: compat/brick_016 else - build-depends: brick >= 0.13 && < 0.15 - hs-source-dirs: compat/brick_pre015 + if flag(brick015) + build-depends: brick >= 0.15 && < 0.16 + hs-source-dirs: compat/brick_015plus + else + build-depends: brick >= 0.13 && < 0.15 + hs-source-dirs: compat/brick_pre015 ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 -- default-language: Haskell2010 main-is: bookcase.hs @@ -117,7 +132,7 @@ executable workreport if !flag(examples) Buildable: False - hs-source-dirs: src, examples + hs-source-dirs: examples if flag(base49) build-depends: base >= 4.9 && < 5.0 hs-source-dirs: compat/base48 @@ -128,15 +143,21 @@ else build-depends: base < 4.8, transformers hs-source-dirs: compat/base_pre48 - if flag(brick015plus) - build-depends: brick >= 0.15 - hs-source-dirs: compat/brick_015plus + if flag(brick016) + build-depends: brick >= 0.16 + hs-source-dirs: compat/brick_016 else - build-depends: brick >= 0.13 && < 0.15 - hs-source-dirs: compat/brick_pre015 + if flag(brick015) + build-depends: brick >= 0.15 && < 0.16 + hs-source-dirs: compat/brick_015plus + else + build-depends: brick >= 0.13 && < 0.15 + hs-source-dirs: compat/brick_pre015 ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 -- default-language: Haskell2010 main-is: workreport.hs + other-modules: TextUI.ItemField.BrickHelper + , Compat build-depends: vty, text, microlens, microlens-th , itemfield, data-default, random @@ -151,13 +172,25 @@ else build-depends: base < 4.8 hs-source-dirs: compat/base_pre48 - if flag(brick015plus) - build-depends: brick >= 0.15 - hs-source-dirs: compat/brick_015plus + if flag(brick016) + build-depends: brick >= 0.16 + hs-source-dirs: compat/brick_016 else - build-depends: brick >= 0.13 && < 0.15 - hs-source-dirs: compat/brick_pre015 + if flag(brick015) + build-depends: brick >= 0.15 && < 0.16 + hs-source-dirs: compat/brick_015plus + else + build-depends: brick >= 0.13 && < 0.15 + hs-source-dirs: compat/brick_pre015 ghc-options: -threaded -O0 + other-modules: TextUI.ItemField.Types + , TextUI.ItemField.Attrs + , TextUI.ItemField.Operations + , TextUI.ItemField.Layout + , TextUI.ItemField.BrickHelper + , TextUI.ItemField + , Compat + , TestDataGen build-depends: HUnit, QuickCheck , test-framework, test-framework-hunit , test-framework-quickcheck2 @@ -174,13 +207,25 @@ else build-depends: base < 4.8 hs-source-dirs: compat/base_pre48 - if flag(brick015plus) - build-depends: brick >= 0.15 - hs-source-dirs: compat/brick_015plus + if flag(brick016) + build-depends: brick >= 0.16 + hs-source-dirs: compat/brick_016 else - build-depends: brick >= 0.13 && < 0.15 - hs-source-dirs: compat/brick_pre015 + if flag(brick015) + build-depends: brick >= 0.15 && < 0.16 + hs-source-dirs: compat/brick_015plus + else + build-depends: brick >= 0.13 && < 0.15 + hs-source-dirs: compat/brick_pre015 ghc-options: -threaded -O0 + other-modules: TextUI.ItemField.Types + , TextUI.ItemField.Attrs + , TextUI.ItemField.Operations + , TextUI.ItemField.Layout + , TextUI.ItemField.BrickHelper + , TextUI.ItemField + , Compat + , TestDataGen cpp-options: -DTEST build-depends: HUnit, QuickCheck , test-framework, test-framework-hunit diff --git a/src/TextUI/ItemField.hs b/src/TextUI/ItemField.hs --- a/src/TextUI/ItemField.hs +++ b/src/TextUI/ItemField.hs @@ -118,10 +118,9 @@ -- 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? + Widget Fixed Fixed $ fieldImageW field s = Widget Fixed Fixed . summaryW field in case elemIdent $ itemField field of Nothing -> i @@ -136,7 +135,7 @@ (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?? + return $ Result newImage [cursor] [VR cursorloc (1,1)] [] summaryW :: ItemFieldWidget n -> (Int -> ItemState -> T.Text) -> RenderM n (Result n) diff --git a/src/TextUI/ItemField/Types.hs b/src/TextUI/ItemField/Types.hs --- a/src/TextUI/ItemField/Types.hs +++ b/src/TextUI/ItemField/Types.hs @@ -9,10 +9,6 @@ data ItemState = Free | Marked | Good | Bad | Pending 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 diff --git a/test/TestDataGen.hs b/test/TestDataGen.hs new file mode 100644 --- /dev/null +++ b/test/TestDataGen.hs @@ -0,0 +1,77 @@ +module TestDataGen where + +import Data.Monoid +import Test.QuickCheck +import qualified Data.Text as T +import TextUI.ItemField + + +instance Arbitrary Items where + arbitrary = return . head =<< gen_items 1 + + shrink (ItemGroup _ i) = shrink i + shrink (Items n) = map Items $ shrink n + + +instance Arbitrary ItemState where + arbitrary = elements [Free, Marked, Good, Bad, Pending] + + +-- Convenience quickcheck generatable input. Last field is total item count. +data BoundedItems = BoundedItems [Items] Int + deriving Show + +numBounded (BoundedItems _ n) = n + + +instance Arbitrary BoundedItems where + arbitrary = sized $ \s -> + do ttl <- choose (0, s `min` 5000) + itms <- gen_items ttl + return $ BoundedItems itms ttl + shrink (BoundedItems i n) = [BoundedItems i' (cntItems i') | i' <- shrink i] + + +gen_items n = + do cnt <- choose (0, n) + grp <- choose (0, 5 :: Int) + let ii = if grp == 0 + then (Items cnt) + else foldl addGrp (Items cnt) [0 .. grp] + remcnt = n - cnt + remitems <- if remcnt > 0 + then gen_items remcnt + else return [] + return $ ii : remitems + where addGrp i g = ItemGroup (T.pack $ "grp" <> show g) i + + +-- Convenience quickcheck generatable input with random state for each +-- item. Last field is total item count. +data BoundedStateItems = BoundedStateItems [Items] [ItemState] Int + deriving Show + + +instance Arbitrary BoundedStateItems where + arbitrary = do (BoundedItems items cnt) <- arbitrary + st8 <- vectorOf cnt arbitrary + return $ BoundedStateItems items st8 cnt + shrink (BoundedStateItems i s n) = + let newBSI n = BoundedStateItems n (take (cntItems n) s) (cntItems n) + in [ newBSI i' | i' <- shrink i ] + + +instance Arbitrary ItemField where + arbitrary = sized $ \s -> + do ttl <- choose (0, s `min` 5000) + i <- gen_items ttl + s <- vectorOf ttl arbitrary + c <- choose (0, max 0 $ ttl - 1) + f <- elements [Nothing, Just $ const $ const $ T.pack "item"] + return $ ItemFld c i s f + + shrink i = + let newfld x = ItemFld (newsel x) x (newst8 x) (elemIdent i) + newsel x = curSel i `max` (cntItems x - 1) + newst8 x = take (cntItems x) $ itemst8 i + in [newfld i' | i' <- shrink (items i) ]