diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,102 @@ Brick changelog --------------- +2.12 +---- + +Package changes: + +* Raised upper bound on microlens to allow building with 0.5. + +2.11 +---- + +Bug fixes: + +* Fixed a bug in FileBrowser: if a user pressed Enter when the cursor + was on a selected entry, it was omitted from the list of + selected browser entries. As part of this change, the function + `actionFileBrowserSelectCurrent` previously toggled the selection + of the entry at the cursor, but should have selected it instead. + It now does so, and a new function for toggling was introduced: + `actionFileBrowserToggleCurrent`. + +Other changes: + +* Upper bounds on `base` and `microlens` were adjusted. + +2.10 +---- + +* Updated `brick` to build with `microlens == 0.5.0.0` which moved its + Field* classes to `Lens.Micro.FieldN`. + +2.9 +--- + +API changes: +* Added `Brick.Widgets.List.listFindFirst` function. + +2.8.3 +----- + +Bug fixes: + +* Fixed a bug that completely broke `makeVisible` that was introduced + in brick 2.6. +* Fixed context cropping in `cropRightBy` and `cropBottomBy`. + +2.8.2 +----- + +* Updated `Brick.Widgets.Core` functions `cropBottomBy`, `cropToBy`, + `cropLeftBy`, and `cropRightBy` to properly perform result cropping to + actually address the internal bug fixed in 2.8.1. + +2.8.1 +----- + +* Fixed a long-standing bug in `cropToContext` that resulted in some + extents getting left around when they should be dropped, possibly + leading to application bugs when handling mouse clicks in extent + regions that should have been removed from the rendering result. + +2.8 +--- + +Behavior changes: +* `FileBrowser` file marking with `Space` now honors the file browser's + configured file selector predicate. +* `FileBrowser` file marking with `Space` and `Enter` now toggles file + selection rather than just selecting files, allowing for selected + files to be unselected. + +2.7 +--- + +This release adds `Brick.Animation`, a module providing infrastructure +for adding animations to Brick interfaces. See the Haddock documentation +in `Brick.Animation` for full details; see `programs/AnimationDemo.hs` +for a working example. + +2.6 +--- + +Behavior changes: + * `Brick.Widgets.Core.relativeTo` now draws nothing if the requested + extent is not found. Previously it would draw the specified widget in + the upper-left corner of the layer. + +Bug fixes: + * Fixed the conditional import in `BorderMap` (#519) + * `Brick.Widgets.Center.hCenterWith` now properly accounts for centered + image width when computing additional right padding (#520) + * The Brick renderer now properly resets some render-specific state + in between renderings that was previously kept around, avoiding + preservation of stale extents across renderings + * `brick-tail-demo` and `brick-custom-event-demo` now shut down Vty + properly + 2.5 --- @@ -1776,7 +1872,7 @@ Bug fixes: * Fixed viewport behavior when the image in a viewport reduces its size enough to render the viewport offsets invalid. Before, this behavior - caused a crash during image croppin in vty; now the behavior is + caused a crash during image cropping in vty; now the behavior is handled sanely (fixes #22; reported by Hans-Peter Deifel) 0.2.2 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015-2018, Jonathan Daugherty. +Copyright (c) 2015-2025, Jonathan Daugherty. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -53,10 +53,11 @@ | [`2048Haskell`](https://github.com/8Gitbrix/2048Haskell) | An implementation of the 2048 game | | [`babel-cards`](https://github.com/srhoulam/babel-cards) | A TUI spaced-repetition memorization tool. Similar to Anki. | | [`bhoogle`](https://github.com/andrevdm/bhoogle) | A [Hoogle](https://www.haskell.org/hoogle/) client | +| [`bollama`](https://github.com/andrevdm/bollama) | A simple [Ollama](https://ollama.com/) TUI | | [`brewsage`](https://github.com/gerdreiss/brewsage#readme) | A TUI for Homebrew | | [`brick-trading-journal`](https://codeberg.org/amano.kenji/brick-trading-journal) | A TUI program that calculates basic statistics from trades | | [`Brickudoku`](https://github.com/Thecentury/brickudoku) | A hybrid of Tetris and Sudoku | -| [`cbookview`](https://github.com/mlang/chessIO) | A TUI for exploring polyglot chess opening book files | +| [`cbookview`](https://github.com/mlang/cbookview) | A TUI for exploring polyglot chess opening book files | | [`clifm`](https://github.com/pasqu4le/clifm) | A file manager | | [`codenames-haskell`](https://github.com/VigneshN1997/codenames-haskell) | An implementation of the Codenames game | | [`fifteen`](https://github.com/benjaminselfridge/fifteen) | An implementation of the [15 puzzle](https://en.wikipedia.org/wiki/15_puzzle) | @@ -72,11 +73,13 @@ | [`hledger-iadd`](http://github.com/rootzlevel/hledger-iadd) | An interactive terminal UI for adding hledger journal entries | | [`hledger-ui`](https://github.com/simonmichael/hledger) | A terminal UI for the hledger accounting system. | | [`homodoro`](https://github.com/c0nradLC/homodoro) | A terminal application to use the pomodoro technique and keep track of daily tasks | +| [`hskanban`](https://github.com/vincentaxhe/hskanban) | A Kanban organizer | | [`htyper`](https://github.com/Simon-Hostettler/htyper) | A typing speed test program | | [`hyahtzee2`](https://github.com/DamienCassou/hyahtzee2#readme) | Famous Yahtzee dice game | | [`kpxhs`](https://github.com/akazukin5151/kpxhs) | An interactive [Keepass](https://github.com/keepassxreboot/keepassxc/) database viewer | | [`matterhorn`](https://github.com/matterhorn-chat/matterhorn) | A client for [Mattermost](https://about.mattermost.com/) | | [`maze`](https://github.com/benjaminselfridge/maze) | A Brick-based maze game | +| [`monad-torrent`](https://github.com/davorluc/monad-torrent) | A simple and minimal torrent client | | [`monalog`](https://github.com/goosedb/Monalog) | Terminal logs observer | | [`mushu`](https://github.com/elaye/mushu) | An `MPD` client | | [`mywork`](https://github.com/kquick/mywork) [[Hackage]](https://hackage.haskell.org/package/mywork) | A tool to keep track of the projects you are working on | @@ -89,6 +92,7 @@ | [`summoner-tui`](https://github.com/kowainik/summoner/tree/master/summoner-tui) | An interactive frontend to the Summoner tool | | [`swarm`](https://github.com/byorgey/swarm/) | A 2D programming and resource gathering game | | [`tart`](https://github.com/jtdaugherty/tart) | A mouse-driven ASCII art drawing program | +| [`tick-tock-tui`](https://github.com/sectore/tick-tock-tui) | A stylish TUI app to handle Bitcoin data provided by [Mempool REST API](https://mempool.space/docs/api/rest) incl. blocks, fees and price converter. | | [`tetris`](https://github.com/SamTay/tetris) | An implementation of the Tetris game | | [`thock`](https://github.com/rmehri01/thock) | A modern TUI typing game featuring online racing against friends | | [`timeloop`](https://github.com/cdupont/timeloop) | A time-travelling demonstrator | @@ -101,12 +105,14 @@ | [`wrapping-editor`](https://github.com/ta0kira/wrapping-editor) | An embeddable editor with support for Brick | | [`youbrick`](https://github.com/florentc/youbrick) | A feed aggregator and launcher for Youtube channels | -These third-party packages also extend `brick`: +These additional packages also extend `brick`: -| Project | Description | -| ------- | ----------- | -| [`brick-filetree`](https://github.com/ChrisPenner/brick-filetree) [[Hackage]](http://hackage.haskell.org/package/brick-filetree) | A widget for exploring a directory tree and selecting or flagging files and directories | -| [`brick-panes`](https://github.com/kquick/brick-panes) [[Hackage]](https://hackage.haskell.org/package/brick-panes) | A Brick overlay library providing composition and isolation of screen areas for TUI apps. | +| Project | Description | Hackage | +| ------- | ----------- | ------- | +| [`brick-filetree`](https://github.com/ChrisPenner/brick-filetree) | A widget for exploring a directory tree and selecting or flagging files and directories | [Hackage](https://hackage.haskell.org/package/brick-filetree) | +| [`brick-panes`](https://github.com/kquick/brick-panes) | A Brick overlay library providing composition and isolation of screen areas for TUI apps. | [Hackage](https://hackage.haskell.org/package/brick-panes) | +| [`brick-calendar`](https://github.com/ldgrp/brick-calendar) | A library providing a calendar widget for Brick-based applications. | [Hackage](https://hackage.haskell.org/package/brick-calendar) | +| [`brick-skylighting`](https://github.com/jtdaugherty/brick-skylighting) | A library providing integration support for [Skylighting](https://hackage.haskell.org/package/skylighting)-based syntax highlighting. | [Hackage](https://hackage.haskell.org/package/brick-skylighting) | Getting Started --------------- @@ -142,6 +148,7 @@ * Progress bar widget * Simple dialog box widget * Border-drawing widgets (put borders around or in between things) + * Animation support * Generic scrollable viewports and viewport scroll bars * General-purpose layout control combinators * Extensible widget-building API @@ -207,6 +214,8 @@ If you decide to contribute, that's great! Here are some guidelines you should consider to make submitting patches easier for all concerned: + - Patches written completely or partially by AI are unlikely to be + accepted. - If you want to take on big things, talk to me first; let's have a design/vision discussion before you start coding. Create a GitHub issue and we can use that as the place to hash things out. diff --git a/brick.cabal b/brick.cabal --- a/brick.cabal +++ b/brick.cabal @@ -1,5 +1,5 @@ name: brick -version: 2.5 +version: 2.12 synopsis: A declarative terminal user interface library description: Write terminal user interfaces (TUIs) painlessly with 'brick'! You @@ -32,7 +32,7 @@ license-file: LICENSE author: Jonathan Daugherty maintainer: Jonathan Daugherty -copyright: (c) Jonathan Daugherty 2015-2024 +copyright: (c) Jonathan Daugherty 2015-2025 category: Graphics build-type: Simple cabal-version: 1.18 @@ -46,8 +46,10 @@ || == 9.0.2 || == 9.2.8 || == 9.4.8 - || == 9.6.3 - || == 9.8.1 + || == 9.6.7 + || == 9.8.4 + || == 9.10.3 + || == 9.12.2 extra-doc-files: README.md, docs/guide.rst, @@ -57,7 +59,7 @@ Source-Repository head type: git - location: git://github.com/jtdaugherty/brick.git + location: http://github.com/jtdaugherty/brick Flag demos Description: Build demonstration programs @@ -70,6 +72,7 @@ hs-source-dirs: src exposed-modules: Brick + Brick.Animation Brick.AttrMap Brick.BChan Brick.BorderMap @@ -98,13 +101,14 @@ Brick.Widgets.Table Data.IMap other-modules: + Brick.Animation.Clock Brick.Types.Common Brick.Types.TH Brick.Types.EventM Brick.Types.Internal Brick.Widgets.Internal - build-depends: base >= 4.9.0.0 && < 4.21.0.0, + build-depends: base >= 4.9.0.0 && < 4.23.0.0, vty >= 6.0, vty-crossplatform, bimap >= 0.5 && < 0.6, @@ -113,7 +117,7 @@ exceptions >= 0.10.0, filepath, containers >= 0.5.7, - microlens >= 0.3.0.0, + microlens >= 0.3.0.0 && < 0.6, microlens-th, microlens-mtl, mtl, @@ -126,7 +130,10 @@ deepseq >= 1.3 && < 1.6, unix-compat, bytestring, - word-wrap >= 0.2 + word-wrap >= 0.2, + unordered-containers, + hashable, + time executable brick-custom-keybinding-demo if !flag(demos) @@ -154,9 +161,7 @@ default-extensions: CPP main-is: TableDemo.hs build-depends: base, - brick, - text, - vty + brick executable brick-tail-demo if !flag(demos) @@ -170,7 +175,6 @@ brick, text, vty, - vty-crossplatform, random, microlens-th, microlens-mtl @@ -184,8 +188,7 @@ default-extensions: CPP main-is: ReadmeDemo.hs build-depends: base, - brick, - text + brick executable brick-file-browser-demo if !flag(demos) @@ -227,7 +230,6 @@ main-is: TextWrapDemo.hs build-depends: base, brick, - text, word-wrap executable brick-cache-demo @@ -241,9 +243,6 @@ build-depends: base, brick, vty, - text, - microlens >= 0.3.0.0, - microlens-th, mtl executable brick-visibility-demo @@ -256,7 +255,6 @@ build-depends: base, brick, vty, - text, microlens >= 0.3.0.0, microlens-th, microlens-mtl @@ -273,8 +271,6 @@ brick, vty, vty-crossplatform, - text, - microlens, microlens-mtl, microlens-th @@ -288,9 +284,7 @@ main-is: ViewportScrollDemo.hs build-depends: base, brick, - vty, - text, - microlens + vty executable brick-dialog-demo if !flag(demos) @@ -301,9 +295,7 @@ main-is: DialogDemo.hs build-depends: base, brick, - vty, - text, - microlens + vty executable brick-mouse-demo if !flag(demos) @@ -315,11 +307,9 @@ build-depends: base, brick, vty, - text, microlens >= 0.3.0.0, microlens-th, microlens-mtl, - text-zipper, mtl executable brick-layer-demo @@ -332,7 +322,6 @@ build-depends: base, brick, vty, - text, microlens >= 0.3.0.0, microlens-th, microlens-mtl @@ -347,7 +336,6 @@ build-depends: base, brick, vty, - text, microlens >= 0.3.0.0, microlens-th @@ -360,9 +348,7 @@ main-is: CroppingDemo.hs build-depends: base, brick, - vty, - text, - microlens + vty executable brick-padding-demo if !flag(demos) @@ -373,9 +359,7 @@ main-is: PaddingDemo.hs build-depends: base, brick, - vty, - text, - microlens + vty executable brick-theme-demo if !flag(demos) @@ -387,9 +371,7 @@ build-depends: base, brick, vty, - text, - mtl, - microlens + mtl executable brick-attr-demo if !flag(demos) @@ -400,9 +382,7 @@ main-is: AttrDemo.hs build-depends: base, brick, - vty, - text, - microlens + vty executable brick-tabular-list-demo if !flag(demos) @@ -414,11 +394,9 @@ build-depends: base, brick, vty, - text, microlens >= 0.3.0.0, microlens-mtl, microlens-th, - mtl, vector executable brick-list-demo @@ -431,7 +409,6 @@ build-depends: base, brick, vty, - text, microlens >= 0.3.0.0, microlens-mtl, mtl, @@ -447,12 +424,25 @@ build-depends: base, brick, vty, - text, microlens >= 0.3.0.0, microlens-mtl, mtl, vector +executable brick-animation-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -Wcompat -O2 + default-language: Haskell2010 + main-is: AnimationDemo.hs + build-depends: base, + brick, + vty, + vty-crossplatform, + containers, + microlens-platform + executable brick-custom-event-demo if !flag(demos) Buildable: False @@ -463,7 +453,6 @@ build-depends: base, brick, vty, - text, microlens >= 0.3.0.0, microlens-th, microlens-mtl @@ -476,10 +465,7 @@ default-language: Haskell2010 main-is: FillDemo.hs build-depends: base, - brick, - vty, - text, - microlens + brick executable brick-hello-world-demo if !flag(demos) @@ -489,10 +475,7 @@ default-language: Haskell2010 main-is: HelloWorldDemo.hs build-depends: base, - brick, - vty, - text, - microlens + brick executable brick-edit-demo if !flag(demos) @@ -504,9 +487,6 @@ build-depends: base, brick, vty, - text, - vector, - mtl, microlens >= 0.3.0.0, microlens-th, microlens-mtl @@ -521,9 +501,6 @@ build-depends: base, brick, vty, - text, - vector, - mtl, microlens >= 0.3.0.0, microlens-th, microlens-mtl @@ -539,8 +516,7 @@ build-depends: base, brick, vty, - text, - microlens + text executable brick-dynamic-border-demo if !flag(demos) @@ -551,10 +527,7 @@ default-language: Haskell2010 main-is: DynamicBorderDemo.hs build-depends: base <= 5, - brick, - vty, - text, - microlens + brick executable brick-progressbar-demo if !flag(demos) @@ -567,8 +540,6 @@ build-depends: base, brick, vty, - text, - microlens, microlens-mtl, microlens-th diff --git a/docs/guide.rst b/docs/guide.rst --- a/docs/guide.rst +++ b/docs/guide.rst @@ -1966,6 +1966,14 @@ so by consulting the ``ctxDynBorders`` field of the rendering context before writing to your ``Result``'s ``borders`` field. +Animations +========== + +Brick provides animation support in ``Brick.Animation``. See the Haddock +documentation in that module for a complete explanation of the API; see +``programs/AnimationDemo.hs`` (``brick-animation-demo``) for a working +example. + The Rendering Cache =================== @@ -1985,8 +1993,8 @@ border $ str "This will be cached" -In the example above, the first time the ``border $ str "This will be -cached"`` widget is rendered, the resulting Vty image will be stored +In the example above, the first time the ``border $ str "This will be cached"`` +widget is rendered, the resulting Vty image will be stored in the rendering cache under the key ``ExpensiveThing``. On subsequent renderings the cached Vty image will be used instead of re-rendering the widget. This example doesn't need caching to improve performance, but diff --git a/programs/AnimationDemo.hs b/programs/AnimationDemo.hs new file mode 100644 --- /dev/null +++ b/programs/AnimationDemo.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} +module Main where + +import Control.Monad (void) +import Lens.Micro.Platform +import Data.List (intersperse) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid +#endif +import qualified Data.Map as M +import qualified Graphics.Vty as V +import Graphics.Vty.CrossPlatform (mkVty) + +import Brick.BChan +import Brick.Util (fg) +import Brick.Main (App(..), neverShowCursor, customMain, halt) +import Brick.AttrMap (AttrName, AttrMap, attrMap, attrName) +import Brick.Types (Widget, EventM, BrickEvent(..), Location(..)) +import Brick.Widgets.Border (border) +import Brick.Widgets.Center (center) +import Brick.Widgets.Core ((<+>), str, vBox, hBox, hLimit, vLimit, translateBy, withDefAttr) +import qualified Brick.Animation as A + +data CustomEvent = + AnimationUpdate (EventM () St ()) + -- ^ The state update constructor required by the animation API + +data St = + St { _stAnimationManager :: A.AnimationManager St CustomEvent () + -- ^ The animation manager that will run all of our animations + , _animation1 :: Maybe (A.Animation St ()) + , _animation2 :: Maybe (A.Animation St ()) + , _animation3 :: Maybe (A.Animation St ()) + , _clickAnimations :: M.Map Location (A.Animation St ()) + -- ^ The various fields for storing animation states. For mouse + -- animations, we store animations for each screen location that + -- was clicked. + } + +makeLenses ''St + +drawUI :: St -> [Widget ()] +drawUI st = drawClickAnimations st <> [drawAnimations st] + +drawClickAnimations :: St -> [Widget ()] +drawClickAnimations st = + drawClickAnimation st <$> M.toList (st^.clickAnimations) + +drawClickAnimation :: St -> (Location, A.Animation St ()) -> Widget () +drawClickAnimation st (l, a) = + translateBy l $ + A.renderAnimation (const $ str " ") st (Just a) + +drawAnimations :: St -> Widget () +drawAnimations st = + let animStatus label key a = + str (label <> ": ") <+> + maybe (str "Not running") (const $ str "Running") a <+> + str (" (Press " <> key <> " to toggle)") + statusMessages = statusMessage <$> zip [(0::Int)..] animations + statusMessage (i, (c, config)) = + animStatus ("Animation #" <> (show $ i + 1)) [c] + (st^.(animationTarget config)) + animationDrawings = hBox $ intersperse (str " ") $ + drawSingleAnimation <$> animations + drawSingleAnimation (_, config) = + A.renderAnimation (const $ str " ") st (st^.(animationTarget config)) + in vBox [ str "Click and drag the mouse or press keys to start animations." + , str " " + , vBox statusMessages + , animationDrawings + ] + +clip1 :: A.Clip a () +clip1 = A.newClip_ $ str <$> [".", "o", "O", "^", " "] + +clip2 :: A.Clip a () +clip2 = A.newClip_ $ str <$> ["|", "/", "-", "\\"] + +clip3 :: A.Clip a () +clip3 = + A.newClip_ $ + (hLimit 9 . vLimit 9 . border . center) <$> + [ border $ str " " + , border $ vBox $ replicate 3 $ str $ replicate 3 ' ' + , border $ vBox $ replicate 5 $ str $ replicate 5 ' ' + ] + +mouseClickClip :: A.Clip a () +mouseClickClip = + A.newClip_ + [ withDefAttr attr6 $ str "0" + , withDefAttr attr5 $ str "O" + , withDefAttr attr4 $ str "o" + , withDefAttr attr3 $ str "•" + , withDefAttr attr2 $ str "*" + , withDefAttr attr2 $ str "." + ] + +attr6 :: AttrName +attr6 = attrName "attr6" + +attr5 :: AttrName +attr5 = attrName "attr5" + +attr4 :: AttrName +attr4 = attrName "attr4" + +attr3 :: AttrName +attr3 = attrName "attr3" + +attr2 :: AttrName +attr2 = attrName "attr2" + +attr1 :: AttrName +attr1 = attrName "attr1" + +attrs :: AttrMap +attrs = + attrMap V.defAttr + [ (attr6, fg V.white) + , (attr5, fg V.brightYellow) + , (attr4, fg V.brightGreen) + , (attr3, fg V.cyan) + , (attr2, fg V.blue) + , (attr1, fg V.black) + ] + +-- | Animation settings grouped together for lookup by keystroke. +data AnimationConfig = + AnimationConfig { animationTarget :: Lens' St (Maybe (A.Animation St ())) + , animationClip :: A.Clip St () + , animationFrameTime :: Integer + , animationMode :: A.RunMode + } + +animations :: [(Char, AnimationConfig)] +animations = + [ ('1', AnimationConfig animation1 clip1 1000 A.Loop) + , ('2', AnimationConfig animation2 clip2 100 A.Loop) + , ('3', AnimationConfig animation3 clip3 100 A.Once) + ] + +-- | Start the animation specified by this config. +startAnimationFromConfig :: AnimationConfig -> EventM () St () +startAnimationFromConfig config = do + mgr <- use stAnimationManager + A.startAnimation mgr (animationClip config) + (animationFrameTime config) + (animationMode config) + (animationTarget config) + +-- | If the animation specified in this config is not running, start it. +-- Otherwise stop it. +toggleAnimationFromConfig :: AnimationConfig -> EventM () St () +toggleAnimationFromConfig config = do + mgr <- use stAnimationManager + mOld <- use (animationTarget config) + case mOld of + Just a -> A.stopAnimation mgr a + Nothing -> startAnimationFromConfig config + +-- | Start a new mouse click animation at the specified location if one +-- is not already running there. +startMouseClickAnimation :: Location -> EventM () St () +startMouseClickAnimation l = do + mgr <- use stAnimationManager + a <- use (clickAnimations.at l) + case a of + Just {} -> return () + Nothing -> A.startAnimation mgr mouseClickClip 100 A.Once (clickAnimations.at l) + +appEvent :: BrickEvent () CustomEvent -> EventM () St () +appEvent e = do + case e of + -- A mouse click starts an animation at the click location. + VtyEvent (V.EvMouseDown col row _ _) -> + startMouseClickAnimation (Location (col, row)) + + -- If we got a character keystroke, see if there is a specific + -- animation mapped to that character and toggle the resulting + -- animation. + VtyEvent (V.EvKey (V.KChar c) []) + | Just aConfig <- lookup c animations -> + toggleAnimationFromConfig aConfig + + -- Apply a state update from the animation manager. + AppEvent (AnimationUpdate act) -> act + + VtyEvent (V.EvKey V.KEsc []) -> halt + + _ -> return () + +theApp :: App St CustomEvent () +theApp = + App { appDraw = drawUI + , appChooseCursor = neverShowCursor + , appHandleEvent = appEvent + , appStartEvent = return () + , appAttrMap = const attrs + } + +main :: IO () +main = do + chan <- newBChan 10 + mgr <- A.startAnimationManager 50 chan AnimationUpdate + + let initialState = + St { _stAnimationManager = mgr + , _animation1 = Nothing + , _animation2 = Nothing + , _animation3 = Nothing + , _clickAnimations = mempty + } + buildVty = do + v <- mkVty V.defaultConfig + V.setMode (V.outputIface v) V.Mouse True + return v + + initialVty <- buildVty + void $ customMain initialVty buildVty (Just chan) theApp initialState diff --git a/programs/CustomEventDemo.hs b/programs/CustomEventDemo.hs --- a/programs/CustomEventDemo.hs +++ b/programs/CustomEventDemo.hs @@ -82,4 +82,5 @@ writeBChan chan Counter threadDelay 1000000 - void $ customMainWithDefaultVty (Just chan) theApp initialState + (_, vty) <- customMainWithDefaultVty (Just chan) theApp initialState + V.shutdown vty diff --git a/programs/LayerDemo.hs b/programs/LayerDemo.hs --- a/programs/LayerDemo.hs +++ b/programs/LayerDemo.hs @@ -46,8 +46,8 @@ [ C.centerLayer $ B.border $ str "This layer is centered but other\nlayers are placed underneath it." , arrowLayer - , middleLayer st - , bottomLayer st + , middleLayer (st^.middleLayerLocation) + , bottomLayer (st^.bottomLayerLocation) ] arrowLayer :: Widget Name @@ -59,15 +59,15 @@ withDefAttr arrowAttr $ str msg -middleLayer :: St -> Widget Name -middleLayer st = - translateBy (st^.middleLayerLocation) $ +middleLayer :: Location -> Widget Name +middleLayer l = + translateBy l $ reportExtent MiddleLayerElement $ B.border $ str "Middle layer\n(Arrow keys move)" -bottomLayer :: St -> Widget Name -bottomLayer st = - translateBy (st^.bottomLayerLocation) $ +bottomLayer :: Location -> Widget Name +bottomLayer l = + translateBy l $ B.border $ str "Bottom layer\n(Ctrl-arrow keys move)" appEvent :: T.BrickEvent Name e -> T.EventM Name St () diff --git a/programs/TailDemo.hs b/programs/TailDemo.hs --- a/programs/TailDemo.hs +++ b/programs/TailDemo.hs @@ -147,4 +147,5 @@ -- Run thread to simulate incoming data void $ forkIO $ generateLines chan - void $ customMainWithDefaultVty (Just chan) app initialState + (_, vty) <- customMainWithDefaultVty (Just chan) app initialState + V.shutdown vty diff --git a/src/Brick/Animation.hs b/src/Brick/Animation.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Animation.hs @@ -0,0 +1,588 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} +-- | This module provides some infrastructure for adding animations to +-- Brick applications. See @programs/AnimationDemo.hs@ for a complete +-- working example of this API. +-- +-- At a high level, this works as follows: +-- +-- This module provides a threaded animation manager that manages a set +-- of running animations. The application creates the manager and starts +-- animations, which automatically loop or run once, depending on their +-- configuration. Each animation has some state in the application's +-- state that is automatically managed by the animation manager using a +-- lens-based API. Whenever animations need to be redrawn, the animation +-- manager sends a custom event with a state update to the application, +-- which must be evaluated by the main event loop to update animation +-- states. Each animation is associated with a 'Clip' -- sequence of +-- frames -- which may be static or may be built from the application +-- state at rendering time. +-- +-- To use this module: +-- +-- * Use a custom event type @e@ in your 'Brick.Main.App' and give the +-- event type a constructor @EventM n s () -> e@ (where @s@ and +-- @n@ are those in @App s e n@). This will require the use of +-- 'Brick.Main.customMain' and will also require the creation of a +-- 'Brick.BChan.BChan' for custom events. +-- +-- * Add an 'AnimationManager' field to the application state @s@. +-- +-- * Create an 'AnimationManager' at startup with +-- 'startAnimationManager', providing the custom event constructor and +-- 'BChan' created above. Store the manager in the application state. +-- +-- * For each animation you want to run at any given time, add a field +-- to the application state of type @Maybe (Animation s n)@, +-- initialized to 'Nothing'. A value of 'Nothing' indicates that the +-- animation is not running. +-- +-- * Ensure that each animation state field in @s@ has a lens, usually +-- by using 'Lens.Micro.TH.makeLenses'. +-- +-- * Start new animations in 'EventM' with 'startAnimation'; stop them +-- with 'stopAnimation'. Supply clips for new animations with +-- 'newClip', 'newClip_', and the clip transformation functions. +-- +-- * Call 'renderAnimation' in 'Brick.Main.appDraw' for each animation in the +-- application state. +-- +-- * If needed, stop the animation manager with 'stopAnimationManager'. +-- +-- See 'AnimationManager' and the docs for the rest of this module for +-- details. +module Brick.Animation + ( -- * Animation managers + AnimationManager + , startAnimationManager + , stopAnimationManager + , minTickTime + + -- * Animations + , Animation + , animationFrameIndex + + -- * Starting and stopping animations + , RunMode(..) + , startAnimation + , stopAnimation + + -- * Rendering animations + , renderAnimation + + -- * Creating clips + , Clip + , newClip + , newClip_ + , clipLength + + -- * Transforming clips + , pingPongClip + , reverseClip + ) +where + +import Control.Concurrent (threadDelay, forkIO, ThreadId, killThread, myThreadId) +import qualified Control.Concurrent.STM as STM +import Control.Monad (forever, when) +import Control.Monad.State.Strict +import Data.Foldable (foldrM) +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) +import qualified Data.Vector as V +import Lens.Micro ((^.), (%~), (.~), (&), Traversal', _Just) +import Lens.Micro.TH (makeLenses) +import Lens.Micro.Mtl + +import Brick.BChan +import Brick.Types (EventM, Widget) +import qualified Brick.Animation.Clock as C + +-- | A sequence of a animation frames. +newtype Clip s n = Clip (V.Vector (s -> Widget n)) + deriving (Semigroup) + +-- | Get the number of frames in a clip. +clipLength :: Clip s n -> Int +clipLength (Clip fs) = V.length fs + +-- | Build a clip. +-- +-- Each frame in a clip is represented by a function from a state to a +-- 'Widget'. This allows applications to determine on a per-frame basis +-- what should be drawn in an animation based on application state, if +-- desired, in the same style as 'Brick.Main.appDraw'. +-- +-- If the provided list is empty, this calls 'error'. +newClip :: [s -> Widget n] -> Clip s n +newClip [] = error "clip: got an empty list" +newClip fs = Clip $ V.fromList fs + +-- | Like 'newClip' but for static frames. +newClip_ :: [Widget n] -> Clip s n +newClip_ ws = newClip $ const <$> ws + +-- | Extend a clip so that when the end of the original clip is reached, +-- it continues in reverse order to create a loop. +-- +-- For example, if this is given a clip with frames A, B, C, and D, then +-- this returns a clip with frames A, B, C, D, C, and B. +-- +-- If the given clip contains less than two frames, this is equivalent +-- to 'id'. +pingPongClip :: Clip s n -> Clip s n +pingPongClip (Clip fs) | V.length fs >= 2 = + Clip $ fs <> V.reverse (V.init $ V.tail fs) +pingPongClip c = c + +-- | Reverse a clip. +reverseClip :: Clip s n -> Clip s n +reverseClip (Clip fs) = Clip $ V.reverse fs + +data AnimationManagerRequest s n = + Tick C.Time + | StartAnimation (Clip s n) Integer RunMode (Traversal' s (Maybe (Animation s n))) + -- ^ Clip, frame duration in milliseconds, run mode, updater + | StopAnimation (Animation s n) + | Shutdown + +-- | The running mode for an animation. +data RunMode = + Once + -- ^ Run the animation once and then end + | Loop + -- ^ Run the animation in a loop forever + deriving (Eq, Show, Ord) + +newtype AnimationID = AnimationID Int + deriving (Eq, Ord, Show, Hashable) + +-- | The state of a running animation. +-- +-- Put one of these (wrapped in 'Maybe') in your application state for +-- each animation that you'd like to run concurrently. +data Animation s n = + Animation { animationFrameIndex :: Int + -- ^ The animation's current frame index, provided for + -- convenience. Applications won't need to access this in + -- most situations; use 'renderAnimation' instead. + , animationID :: AnimationID + -- ^ The animation's internally-managed ID + , animationClip :: Clip s n + -- ^ The animation's clip + } + +-- | Render an animation. +renderAnimation :: (s -> Widget n) + -- ^ The fallback function to use for drawing if the + -- animation is not running + -> s + -- ^ The state to provide when rendering the animation's + -- current frame + -> Maybe (Animation s n) + -- ^ The animation state itself + -> Widget n +renderAnimation fallback input mAnim = + draw input + where + draw = fromMaybe fallback $ do + a <- mAnim + let idx = animationFrameIndex a + Clip fs = animationClip a + fs V.!? idx + +data AnimationState s n = + AnimationState { _animationStateID :: AnimationID + , _animationNumFrames :: Int + , _animationCurrentFrame :: Int + , _animationFrameMilliseconds :: Integer + , _animationRunMode :: RunMode + , animationFrameUpdater :: Traversal' s (Maybe (Animation s n)) + , _animationNextFrameTime :: C.Time + } + +makeLenses ''AnimationState + +-- | A manager for animations. The type variables for this type are the +-- same as those for 'Brick.Main.App'. +-- +-- This asynchronously manages a set of running animations, advancing +-- each one over time. When a running animation's current frame needs +-- to be changed, the manager sends an 'EventM' update for that +-- animation to the application's event loop to perform the update to +-- the animation in the application state. The manager will batch such +-- updates if more than one animation needs to be changed at a time. +-- +-- The manager has a /tick duration/ in milliseconds which is the +-- resolution at which animations are checked to see if they should +-- be updated. Animations also have their own frame duration in +-- milliseconds. For example, if a manager has a tick duration of 50 +-- milliseconds and is running an animation with a frame duration of 100 +-- milliseconds, then the manager will advance that animation by one +-- frame every two ticks. On the other hand, if a manager has a tick +-- duration of 100 milliseconds and is running an animation with a frame +-- duration of 50 milliseconds, the manager will advance that animation +-- by two frames on each tick. +-- +-- Animation managers are started with 'startAnimationManager' and +-- stopped with 'stopAnimationManager'. +-- +-- Animations are started with 'startAnimation' and stopped with +-- 'stopAnimation'. Each animation must be associated with an +-- application state field accessible with a traversal given to +-- 'startAnimation'. +-- +-- When an animation is started, every time it advances a frame, and +-- when it is ended, the manager communicates these changes to the +-- application by using the custom event constructor provided to +-- 'startAnimationManager'. The manager uses that to schedule a state +-- update which the application is responsible for evaluating. The state +-- updates are built from the traversals provided to 'startAnimation'. +-- +-- The manager-updated 'Animation' values in the application state are +-- then drawn with 'renderAnimation'. +-- +-- Animations in 'Loop' mode are run forever until stopped with +-- 'stopAnimation'; animations in 'Once' mode run once and are removed +-- from the application state (set to 'Nothing') when they finish. All +-- state updates to the application state are performed by the manager's +-- custom event mechanism; the application never needs to directly +-- modify the 'Animation' application state fields except to initialize +-- them to 'Nothing'. +-- +-- There is nothing here to prevent an application from running multiple +-- managers, each at a different tick rate. That may have performance +-- consequences, though, due to the loss of batch efficiency in state +-- updates, so we recommend using only one manager per application at a +-- sufficiently short tick duration. +data AnimationManager s e n = + AnimationManager { animationMgrRequestThreadId :: ThreadId + , animationMgrTickThreadId :: ThreadId + , animationMgrOutputChan :: BChan e + , animationMgrInputChan :: STM.TChan (AnimationManagerRequest s n) + , animationMgrEventConstructor :: EventM n s () -> e + , animationMgrRunning :: STM.TVar Bool + } + +tickThreadBody :: Int + -> STM.TChan (AnimationManagerRequest s n) + -> IO () +tickThreadBody tickMilliseconds outChan = do + let nextTick = C.addOffset tickOffset + tickOffset = C.offsetFromMs $ toInteger tickMilliseconds + go targetTime = do + now <- C.getTime + STM.atomically $ STM.writeTChan outChan $ Tick now + + -- threadDelay does not guarantee that we will wake up on + -- time; it only ensures that we won't wake up earlier than + -- requested. Since we can therefore oversleep, instead of + -- always sleeping for tickMilliseconds (which would cause + -- us to drift off of schedule as delays accumulate) we + -- determine sleep time by measuring the distance between + -- now and the next scheduled tick. This is still unreliable + -- as we can still oversleep, but it keeps the oversleeping + -- under control over time. It means most ticks may be + -- slightly late (about 1-2 milliseconds is common) but this + -- will prevent that per-tick error from accumulating. + let nextTickTime = nextTick targetTime + sleepMs = fromInteger $ + C.offsetToMs $ + C.subtractTime nextTickTime now + + -- threadDelay works microseconds. + threadDelay $ sleepMs * 1000 + go nextTickTime + + go =<< C.getTime + +setNextFrameTime :: C.Time -> AnimationState s n -> AnimationState s n +setNextFrameTime t a = a & animationNextFrameTime .~ t + +data ManagerState s e n = + ManagerState { _managerStateInChan :: STM.TChan (AnimationManagerRequest s n) + , _managerStateOutChan :: BChan e + , _managerStateEventBuilder :: EventM n s () -> e + , _managerStateAnimations :: HM.HashMap AnimationID (AnimationState s n) + , _managerStateIDVar :: STM.TVar AnimationID + } + +makeLenses ''ManagerState + +animationManagerThreadBody :: STM.TChan (AnimationManagerRequest s n) + -> BChan e + -> (EventM n s () -> e) + -> IO () +animationManagerThreadBody inChan outChan mkEvent = do + idVar <- STM.newTVarIO $ AnimationID 1 + let initial = ManagerState { _managerStateInChan = inChan + , _managerStateOutChan = outChan + , _managerStateEventBuilder = mkEvent + , _managerStateAnimations = mempty + , _managerStateIDVar = idVar + } + evalStateT runManager initial + +type ManagerM s e n a = StateT (ManagerState s e n) IO a + +getNextManagerRequest :: ManagerM s e n (AnimationManagerRequest s n) +getNextManagerRequest = do + inChan <- use managerStateInChan + liftIO $ STM.atomically $ STM.readTChan inChan + +sendApplicationStateUpdate :: EventM n s () -> ManagerM s e n () +sendApplicationStateUpdate act = do + outChan <- use managerStateOutChan + mkEvent <- use managerStateEventBuilder + liftIO $ writeBChan outChan $ mkEvent act + +removeAnimation :: AnimationID -> ManagerM s e n () +removeAnimation aId = + managerStateAnimations %= HM.delete aId + +lookupAnimation :: AnimationID -> ManagerM s e n (Maybe (AnimationState s n)) +lookupAnimation aId = + HM.lookup aId <$> use managerStateAnimations + +insertAnimation :: AnimationState s n -> ManagerM s e n () +insertAnimation a = + managerStateAnimations %= HM.insert (a^.animationStateID) a + +getNextAnimationID :: ManagerM s e n AnimationID +getNextAnimationID = do + var <- use managerStateIDVar + liftIO $ STM.atomically $ do + AnimationID i <- STM.readTVar var + let next = AnimationID $ i + 1 + STM.writeTVar var next + return $ AnimationID i + +runManager :: ManagerM s e n () +runManager = forever $ do + getNextManagerRequest >>= handleManagerRequest + +handleManagerRequest :: AnimationManagerRequest s n -> ManagerM s e n () +handleManagerRequest (StartAnimation clip frameMs runMode updater) = do + aId <- getNextAnimationID + now <- liftIO C.getTime + let next = C.addOffset frameOffset now + frameOffset = C.offsetFromMs frameMs + a = AnimationState { _animationStateID = aId + , _animationNumFrames = clipLength clip + , _animationCurrentFrame = 0 + , _animationFrameMilliseconds = frameMs + , _animationRunMode = runMode + , animationFrameUpdater = updater + , _animationNextFrameTime = next + } + + insertAnimation a + sendApplicationStateUpdate $ updater .= Just (Animation { animationID = aId + , animationFrameIndex = 0 + , animationClip = clip + }) +handleManagerRequest (StopAnimation a) = do + let aId = animationID a + mA <- lookupAnimation aId + case mA of + Nothing -> return () + Just aState -> do + -- Remove the animation from the manager + removeAnimation aId + + -- Set the current animation state in the application state + -- to none + sendApplicationStateUpdate $ clearStateAction aState +handleManagerRequest Shutdown = do + as <- HM.elems <$> use managerStateAnimations + + let updater = sequence_ $ clearStateAction <$> as + when (not $ null as) $ do + sendApplicationStateUpdate updater + + liftIO $ myThreadId >>= killThread +handleManagerRequest (Tick tickTime) = do + -- Check all animation states for frame advances + -- based on the relationship between the tick time + -- and each animation's next frame time + mUpdateAct <- checkAnimations tickTime + case mUpdateAct of + Nothing -> return () + Just act -> sendApplicationStateUpdate act + +clearStateAction :: AnimationState s n -> EventM n s () +clearStateAction a = animationFrameUpdater a .= Nothing + +frameUpdateAction :: AnimationState s n -> EventM n s () +frameUpdateAction a = + animationFrameUpdater a._Just %= + (\an -> an { animationFrameIndex = a^.animationCurrentFrame }) + +updateAnimationState :: C.Time -> AnimationState s n -> AnimationState s n +updateAnimationState now a = + let differenceMs = C.offsetToMs $ + C.subtractTime now (a^.animationNextFrameTime) + numFrames = 1 + (differenceMs `div` (a^.animationFrameMilliseconds)) + newNextTime = C.addOffset (C.offsetFromMs $ numFrames * (a^.animationFrameMilliseconds)) + (a^.animationNextFrameTime) + + -- The new frame is obtained by advancing from the current frame by + -- numFrames. + in setNextFrameTime newNextTime $ advanceBy numFrames a + +checkAnimations :: C.Time -> ManagerM s e n (Maybe (EventM n s ())) +checkAnimations now = do + let go a updaters = do + result <- checkAnimation now a + return $ case result of + Nothing -> updaters + Just u -> u : updaters + + anims <- use managerStateAnimations + updaters <- foldrM go [] anims + + case updaters of + [] -> return Nothing + _ -> return $ Just $ sequence_ updaters + +-- For each active animation, check to see if the animation's next frame +-- time has passed. If it has, advance its frame counter as appropriate +-- and schedule its frame index to be updated in the application state. +checkAnimation :: C.Time -> AnimationState s n -> ManagerM s e n (Maybe (EventM n s ())) +checkAnimation now a + | isFinished a = do + -- This animation completed in a previous check, so clear it + -- from the manager and the application state. + removeAnimation (a^.animationStateID) + return $ Just $ clearStateAction a + | (now < a^.animationNextFrameTime) = + -- This animation is not due for an update, so don't do + -- anything. + return Nothing + | otherwise = do + -- This animation is still running, so determine how many frames + -- have elapsed for it and then advance the frame index based + -- the elapsed time. Also set its next frame time. + let a' = updateAnimationState now a + managerStateAnimations %= HM.insert (a'^.animationStateID) a' + return $ Just $ frameUpdateAction a' + +isFinished :: AnimationState s n -> Bool +isFinished a = + case a^.animationRunMode of + Once -> a^.animationCurrentFrame == a^.animationNumFrames - 1 + Loop -> False + +advanceBy :: Integer -> AnimationState s n -> AnimationState s n +advanceBy n a + | n <= 0 = a + | otherwise = + advanceBy (n - 1) $ + advanceByOne a + +advanceByOne :: AnimationState s n -> AnimationState s n +advanceByOne a = + if a^.animationCurrentFrame == a^.animationNumFrames - 1 + then case a^.animationRunMode of + Loop -> a & animationCurrentFrame .~ 0 + Once -> a + else a & animationCurrentFrame %~ (+ 1) + +-- | The minimum tick duration in milliseconds allowed by +-- 'startAnimationManager'. +minTickTime :: Int +minTickTime = 25 + +-- | Start a new animation manager. For full details about how managers +-- work, see 'AnimationManager'. +-- +-- If the specified tick duration is less than 'minTickTime', this will +-- call 'error'. This bound is in place to prevent API misuse leading to +-- ticking so fast that the terminal can't keep up with redraws. +startAnimationManager :: (MonadIO m) + => Int + -- ^ The tick duration for this manager in milliseconds + -> BChan e + -- ^ The event channel to use to send updates to + -- the application (i.e. the same one given to + -- e.g. 'Brick.Main.customVty') + -> (EventM n s () -> e) + -- ^ A constructor for building custom events + -- that perform application state updates. The + -- application must evaluate these custom events' + -- 'EventM' actions in order to record animation + -- updates in the application state. + -> m (AnimationManager s e n) +startAnimationManager tickMilliseconds _ _ | tickMilliseconds < minTickTime = + error $ "startAnimationManager: tick duration too small (minimum is " <> show minTickTime <> ")" +startAnimationManager tickMilliseconds outChan mkEvent = liftIO $ do + inChan <- STM.newTChanIO + reqTid <- forkIO $ animationManagerThreadBody inChan outChan mkEvent + tickTid <- forkIO $ tickThreadBody tickMilliseconds inChan + runningVar <- STM.newTVarIO True + return $ AnimationManager { animationMgrRequestThreadId = reqTid + , animationMgrTickThreadId = tickTid + , animationMgrEventConstructor = mkEvent + , animationMgrOutputChan = outChan + , animationMgrInputChan = inChan + , animationMgrRunning = runningVar + } + +-- | Execute the specified action only when this manager is running. +whenRunning :: (MonadIO m) => AnimationManager s e n -> IO () -> m () +whenRunning mgr act = do + running <- liftIO $ STM.atomically $ STM.readTVar (animationMgrRunning mgr) + when running $ liftIO act + +-- | Stop the animation manager, ending all running animations. +stopAnimationManager :: (MonadIO m) => AnimationManager s e n -> m () +stopAnimationManager mgr = + whenRunning mgr $ do + tellAnimationManager mgr Shutdown + killThread $ animationMgrTickThreadId mgr + STM.atomically $ STM.writeTVar (animationMgrRunning mgr) False + +-- | Send a request to an animation manager. +tellAnimationManager :: (MonadIO m) + => AnimationManager s e n + -- ^ The manager + -> AnimationManagerRequest s n + -- ^ The request to send + -> m () +tellAnimationManager mgr req = + liftIO $ + STM.atomically $ + STM.writeTChan (animationMgrInputChan mgr) req + +-- | Start a new animation at its first frame. +-- +-- This will result in an application state update to initialize the +-- animation state at the provided traversal's location. +startAnimation :: (MonadIO m) + => AnimationManager s e n + -- ^ The manager to run the animation + -> Clip s n + -- ^ The frames for the animation + -> Integer + -- ^ The animation's frame duration in milliseconds + -> RunMode + -- ^ The animation's run mode + -> Traversal' s (Maybe (Animation s n)) + -- ^ Where in the application state to manage this + -- animation's state + -> m () +startAnimation mgr frames frameMs runMode updater = + tellAnimationManager mgr $ StartAnimation frames frameMs runMode updater + +-- | Stop an animation. +-- +-- This will result in an application state update to remove the +-- animation state. +stopAnimation :: (MonadIO m) + => AnimationManager s e n + -> Animation s n + -> m () +stopAnimation mgr a = + tellAnimationManager mgr $ StopAnimation a diff --git a/src/Brick/Animation/Clock.hs b/src/Brick/Animation/Clock.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Animation/Clock.hs @@ -0,0 +1,64 @@ +-- | This module provides an API for working with +-- 'Data.Time.Clock.System.SystemTime' values similar to that of +-- 'Data.Time.Clock.UTCTime'. @SystemTime@s are more efficient to +-- obtain than @UTCTime@s, which is important to avoid animation +-- tick thread delays associated with expensive clock reads. In +-- addition, the @UTCTime@-based API provides unpleasant @Float@-based +-- conversions. Since the @SystemTime@-based API doesn't provide some +-- of the operations we need, and since it is easier to work with at +-- millisecond granularity, it is extended here for internal use. +module Brick.Animation.Clock + ( Time + , getTime + , addOffset + , subtractTime + + , Offset + , offsetFromMs + , offsetToMs + ) +where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Data.Time.Clock.System as C + +newtype Time = Time C.SystemTime + deriving (Ord, Eq) + +-- | Signed difference in milliseconds +newtype Offset = Offset Integer + deriving (Ord, Eq) + +offsetFromMs :: Integer -> Offset +offsetFromMs = Offset + +offsetToMs :: Offset -> Integer +offsetToMs (Offset ms) = ms + +getTime :: (MonadIO m) => m Time +getTime = Time <$> liftIO C.getSystemTime + +addOffset :: Offset -> Time -> Time +addOffset (Offset ms) (Time (C.MkSystemTime s ns)) = + Time $ C.MkSystemTime (fromInteger s') (fromInteger ns') + where + -- Note that due to the behavior of divMod, this works even when + -- the offset is negative: the number of seconds is decremented + -- and the remainder of nanoseconds is correct. + s' = newSec + toInteger s + (newSec, ns') = (nsPerMs * ms + toInteger ns) + `divMod` (msPerS * nsPerMs) + +subtractTime :: Time -> Time -> Offset +subtractTime t1 t2 = Offset $ timeToMs t1 - timeToMs t2 + +timeToMs :: Time -> Integer +timeToMs (Time (C.MkSystemTime s ns)) = + (toInteger s) * msPerS + + (toInteger ns) `div` nsPerMs + +nsPerMs :: Integer +nsPerMs = 1000000 + +msPerS :: Integer +msPerS = 1000 diff --git a/src/Brick/BorderMap.hs b/src/Brick/BorderMap.hs --- a/src/Brick/BorderMap.hs +++ b/src/Brick/BorderMap.hs @@ -17,7 +17,9 @@ ) where import Brick.Types.Common (Edges(..), Location(..), eTopL, eBottomL, eRightL, eLeftL, origin) +#if !(MIN_VERSION_base(4,18,0)) import Control.Applicative (liftA2) +#endif import Data.IMap (IMap, Run(Run)) import GHC.Generics import Control.DeepSeq diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs --- a/src/Brick/Main.hs +++ b/src/Brick/Main.hs @@ -238,6 +238,10 @@ -- | Like 'customMainWithVty', except that Vty is initialized with the -- default configuration. +-- +-- The returned 'Vty' handle still has control of the terminal. The +-- caller is responsible for calling 'shutdown' to restore the terminal +-- state. customMainWithDefaultVty :: (Ord n) => Maybe (BChan e) -- ^ An event channel for sending custom diff --git a/src/Brick/Types/Common.hs b/src/Brick/Types/Common.hs --- a/src/Brick/Types/Common.hs +++ b/src/Brick/Types/Common.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE CPP #-} module Brick.Types.Common ( Location(..) , locL @@ -16,10 +17,14 @@ import GHC.Generics import Control.DeepSeq import Lens.Micro (_1, _2) +#if MIN_VERSION_microlens(0,5,0) +import Lens.Micro.FieldN (Field1, Field2) +#else import Lens.Micro.Internal (Field1, Field2) +#endif -- | A terminal screen location. -data Location = Location { loc :: (Int, Int) +data Location = Location { loc :: !(Int, Int) -- ^ (Column, Row) } deriving (Show, Eq, Ord, Read, Generic, NFData) @@ -43,7 +48,7 @@ mempty = origin mappend = (Sem.<>) -data Edges a = Edges { eTop, eBottom, eLeft, eRight :: a } +data Edges a = Edges { eTop, eBottom, eLeft, eRight :: !a } deriving (Eq, Ord, Read, Show, Functor, Generic, NFData) suffixLenses ''Edges diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs --- a/src/Brick/Types/Internal.hs +++ b/src/Brick/Types/Internal.hs @@ -103,16 +103,16 @@ import Brick.AttrMap (AttrName, AttrMap) import Brick.Widgets.Border.Style (BorderStyle) -data ScrollRequest = HScrollBy Int - | HScrollPage Direction +data ScrollRequest = HScrollBy !Int + | HScrollPage !Direction | HScrollToBeginning | HScrollToEnd - | VScrollBy Int - | VScrollPage Direction + | VScrollBy !Int + | VScrollPage !Direction | VScrollToBeginning | VScrollToEnd - | SetTop Int - | SetLeft Int + | SetTop !Int + | SetLeft !Int deriving (Read, Show, Generic, NFData) -- | Widget size policies. These policies communicate how a widget uses @@ -131,9 +131,9 @@ -- | The type of widgets. data Widget n = - Widget { hSize :: Size + Widget { hSize :: !Size -- ^ This widget's horizontal growth policy - , vSize :: Size + , vSize :: !Size -- ^ This widget's vertical growth policy , render :: RenderM n (Result n) -- ^ This widget's rendering function @@ -230,21 +230,21 @@ } data VisibilityRequest = - VR { vrPosition :: Location - , vrSize :: DisplayRegion + VR { vrPosition :: !Location + , vrSize :: !DisplayRegion } deriving (Show, Eq, Read, Generic, NFData) -- | Describes the state of a viewport as it appears as its most recent -- rendering. data Viewport = - VP { _vpLeft :: Int + VP { _vpLeft :: !Int -- ^ The column offset of left side of the viewport. - , _vpTop :: Int + , _vpTop :: !Int -- ^ The row offset of the top of the viewport. - , _vpSize :: DisplayRegion + , _vpSize :: !DisplayRegion -- ^ The size of the viewport. - , _vpContentSize :: DisplayRegion + , _vpContentSize :: !DisplayRegion -- ^ The size of the contents of the viewport. } deriving (Show, Read, Generic, NFData) @@ -274,9 +274,9 @@ } data VtyContext = - VtyContext { vtyContextBuilder :: IO Vty - , vtyContextHandle :: Vty - , vtyContextThread :: ThreadId + VtyContext { vtyContextBuilder :: !(IO Vty) + , vtyContextHandle :: !Vty + , vtyContextThread :: !ThreadId , vtyContextPutEvent :: Event -> IO () } @@ -330,27 +330,27 @@ -- | A border character has four segments, one extending in each direction -- (horizontally and vertically) from the center of the character. data BorderSegment = BorderSegment - { bsAccept :: Bool + { bsAccept :: !Bool -- ^ Would this segment be willing to be drawn if a neighbor wanted to -- connect to it? - , bsOffer :: Bool + , bsOffer :: !Bool -- ^ Does this segment want to connect to its neighbor? - , bsDraw :: Bool + , bsDraw :: !Bool -- ^ Should this segment be represented visually? } deriving (Eq, Ord, Read, Show, Generic, NFData) -- | Information about how to redraw a dynamic border character when it abuts -- another dynamic border character. data DynBorder = DynBorder - { dbStyle :: BorderStyle + { dbStyle :: !BorderStyle -- ^ The 'Char's to use when redrawing the border. Also used to filter -- connections: only dynamic borders with equal 'BorderStyle's will connect -- to each other. - , dbAttr :: Attr + , dbAttr :: !Attr -- ^ What 'Attr' to use to redraw the border character. Also used to filter -- connections: only dynamic borders with equal 'Attr's will connect to -- each other. - , dbSegments :: Edges BorderSegment + , dbSegments :: !(Edges BorderSegment) } deriving (Eq, Read, Show, Generic, NFData) -- | The type of result returned by a widget's rendering function. The @@ -394,23 +394,23 @@ } -- | The type of events. -data BrickEvent n e = VtyEvent Event +data BrickEvent n e = VtyEvent !Event -- ^ The event was a Vty event. - | AppEvent e + | AppEvent !e -- ^ The event was an application event. - | MouseDown n Button [Modifier] Location + | MouseDown !n !Button ![Modifier] !Location -- ^ A mouse-down event on the specified region was -- received. The 'n' value is the resource name of -- the clicked widget (see 'clickable'). - | MouseUp n (Maybe Button) Location + | MouseUp !n !(Maybe Button) !Location -- ^ A mouse-up event on the specified region was -- received. The 'n' value is the resource name of -- the clicked widget (see 'clickable'). deriving (Show, Eq, Ord) -data EventRO n = EventRO { eventViewportMap :: M.Map n Viewport - , latestExtents :: [Extent n] - , oldState :: RenderState n +data EventRO n = EventRO { eventViewportMap :: !(M.Map n Viewport) + , latestExtents :: ![Extent n] + , oldState :: !(RenderState n) } -- | Clickable elements of a scroll bar. @@ -432,22 +432,22 @@ -- to render, which bordering style should be used, and the attribute map -- available for rendering. data Context n = - Context { ctxAttrName :: AttrName - , availWidth :: Int - , availHeight :: Int - , windowWidth :: Int - , windowHeight :: Int - , ctxBorderStyle :: BorderStyle - , ctxAttrMap :: AttrMap - , ctxDynBorders :: Bool - , ctxVScrollBarOrientation :: Maybe VScrollBarOrientation - , ctxVScrollBarRenderer :: Maybe (VScrollbarRenderer n) - , ctxHScrollBarOrientation :: Maybe HScrollBarOrientation - , ctxHScrollBarRenderer :: Maybe (HScrollbarRenderer n) - , ctxVScrollBarShowHandles :: Bool - , ctxHScrollBarShowHandles :: Bool - , ctxVScrollBarClickableConstr :: Maybe (ClickableScrollbarElement -> n -> n) - , ctxHScrollBarClickableConstr :: Maybe (ClickableScrollbarElement -> n -> n) + Context { ctxAttrName :: !AttrName + , availWidth :: !Int + , availHeight :: !Int + , windowWidth :: !Int + , windowHeight :: !Int + , ctxBorderStyle :: !BorderStyle + , ctxAttrMap :: !AttrMap + , ctxDynBorders :: !Bool + , ctxVScrollBarOrientation :: !(Maybe VScrollBarOrientation) + , ctxVScrollBarRenderer :: !(Maybe (VScrollbarRenderer n)) + , ctxHScrollBarOrientation :: !(Maybe HScrollBarOrientation) + , ctxHScrollBarRenderer :: !(Maybe (HScrollbarRenderer n)) + , ctxVScrollBarShowHandles :: !Bool + , ctxHScrollBarShowHandles :: !Bool + , ctxVScrollBarClickableConstr :: !(Maybe (ClickableScrollbarElement -> n -> n)) + , ctxHScrollBarClickableConstr :: !(Maybe (ClickableScrollbarElement -> n -> n)) } suffixLenses ''RenderState diff --git a/src/Brick/Widgets/Center.hs b/src/Brick/Widgets/Center.hs --- a/src/Brick/Widgets/Center.hs +++ b/src/Brick/Widgets/Center.hs @@ -60,7 +60,7 @@ c <- getContext let rWidth = result^.imageL.to imageWidth rHeight = result^.imageL.to imageHeight - remainder = max 0 $ c^.availWidthL - (leftPaddingAmount * 2) + remainder = max 0 $ c^.availWidthL - (rWidth + (leftPaddingAmount * 2)) leftPaddingAmount = max 0 $ (c^.availWidthL - rWidth) `div` 2 rightPaddingAmount = max 0 $ leftPaddingAmount + remainder leftPadding = charFill (c^.attrL) ch leftPaddingAmount rHeight diff --git a/src/Brick/Widgets/Core.hs b/src/Brick/Widgets/Core.hs --- a/src/Brick/Widgets/Core.hs +++ b/src/Brick/Widgets/Core.hs @@ -340,7 +340,7 @@ -- input text should not contain escape sequences or carriage returns. txt :: T.Text -> Widget n txt s = - -- Althoguh vty Image uses lazy Text internally, using lazy text at this + -- Although vty Image uses lazy Text internally, using lazy text at this -- level may not be an improvement. Indeed it can be much worse, due -- the overhead of lazy Text being significant compared to the typically -- short string content used to compose UIs. @@ -719,12 +719,11 @@ (concatMap extents allTranslatedResults) newBorders -catDynBorder - :: Lens' (Edges BorderSegment) BorderSegment - -> Lens' (Edges BorderSegment) BorderSegment - -> DynBorder - -> DynBorder - -> Maybe DynBorder +catDynBorder :: Lens' (Edges BorderSegment) BorderSegment + -> Lens' (Edges BorderSegment) BorderSegment + -> DynBorder + -> DynBorder + -> Maybe DynBorder catDynBorder towardsA towardsB a b -- Currently, we check if the 'BorderStyle's are exactly the same. In the -- future, it might be nice to relax this restriction. For example, if a @@ -742,12 +741,11 @@ = Just (a & dbSegmentsL.towardsB.bsDrawL .~ True) | otherwise = Nothing -catDynBorders - :: Lens' (Edges BorderSegment) BorderSegment - -> Lens' (Edges BorderSegment) BorderSegment - -> I.IMap DynBorder - -> I.IMap DynBorder - -> I.IMap DynBorder +catDynBorders :: Lens' (Edges BorderSegment) BorderSegment + -> Lens' (Edges BorderSegment) BorderSegment + -> I.IMap DynBorder + -> I.IMap DynBorder + -> I.IMap DynBorder catDynBorders towardsA towardsB am bm = I.mapMaybe id $ I.intersectionWith (catDynBorder towardsA towardsB) am bm @@ -757,9 +755,8 @@ -- images to keep the image in sync with the border information. -- -- The input borders are assumed to be disjoint. This property is not checked. -catBorders - :: (border ~ BM.BorderMap DynBorder, rewrite ~ I.IMap V.Image) - => BoxRenderer n -> border -> border -> ((rewrite, rewrite), border) +catBorders :: (border ~ BM.BorderMap DynBorder, rewrite ~ I.IMap V.Image) + => BoxRenderer n -> border -> border -> ((rewrite, rewrite), border) catBorders br r l = if lCoord + 1 == rCoord then ((lRe, rRe), lr') else ((I.empty, I.empty), lr) @@ -788,20 +785,20 @@ -- overlap and are strictly increasing in the primary direction), produce: a -- list of rewrites for the lo and hi directions of each border, respectively, -- and the borders describing the fully concatenated object. -catAllBorders :: - BoxRenderer n -> - [BM.BorderMap DynBorder] -> - ([(I.IMap V.Image, I.IMap V.Image)], BM.BorderMap DynBorder) +catAllBorders :: BoxRenderer n + -> [BM.BorderMap DynBorder] + -> ([(I.IMap V.Image, I.IMap V.Image)], BM.BorderMap DynBorder) catAllBorders _ [] = ([], BM.empty) catAllBorders br (bm:bms) = (zip ([I.empty]++los) (his++[I.empty]), bm') where (rewrites, bm') = runState (traverse (state . catBorders br) bms) bm (his, los) = unzip rewrites -rewriteEdge :: - (Int -> V.Image -> V.Image) -> - (Int -> V.Image -> V.Image) -> - ([V.Image] -> V.Image) -> - I.IMap V.Image -> V.Image -> V.Image +rewriteEdge :: (Int -> V.Image -> V.Image) + -> (Int -> V.Image -> V.Image) + -> ([V.Image] -> V.Image) + -> I.IMap V.Image + -> V.Image + -> V.Image rewriteEdge splitLo splitHi combine = (combine .) . go . offsets 0 . I.unsafeToAscList where -- convert absolute positions into relative ones @@ -1084,15 +1081,16 @@ -- | Given a widget, translate it to position it relative to the -- upper-left coordinates of a reported extent with the specified -- positioning offset. If the specified name has no reported extent, --- this just draws the specified widget with no special positioning. +-- this draws nothing on the basis that it only makes sense to draw what +-- was requested when the relative position can be known. -- -- This is only useful for positioning something in a higher layer -- relative to a reported extent in a lower layer. Any other use is --- likely to result in the specified widget being rendered as-is with --- no translation. This is because this function relies on information --- about lower layer renderings in order to work; using it with a --- resource name that wasn't rendered in a lower layer will result in --- this being equivalent to @id@. +-- likely to result in the specified widget not being rendered. This +-- is because this function relies on information about lower layer +-- renderings in order to work; using it with a resource name that +-- wasn't rendered in a lower layer will result in this being equivalent +-- to @emptyWidget@. -- -- For example, if you have two layers @topLayer@ and @bottomLayer@, -- then a widget drawn in @bottomLayer@ with @reportExtent Foo@ can be @@ -1103,7 +1101,7 @@ Widget (hSize w) (vSize w) $ do mExt <- lookupReportedExtent n case mExt of - Nothing -> render w + Nothing -> render emptyWidget Just ext -> render $ translateBy (extentUpperLeft ext <> off) w -- | Crop the specified widget on the left by the specified number of @@ -1114,8 +1112,11 @@ result <- render p let amt = V.imageWidth (result^.imageL) - cols cropped img = if amt < 0 then V.emptyImage else V.cropLeft amt img - return $ addResultOffset (Location (-1 * cols, 0)) - $ result & imageL %~ cropped + render $ Widget (hSize p) (vSize p) $ + withReaderT (availWidthL .~ amt) $ + cropResultToContext $ + addResultOffset (Location (-1 * cols, 0)) $ + result & imageL %~ cropped -- | Crop the specified widget to the specified size from the left. -- Defers to the cropped widget for growth policy. @@ -1137,7 +1138,8 @@ result <- render p let amt = V.imageWidth (result^.imageL) - cols cropped img = if amt < 0 then V.emptyImage else V.cropRight amt img - return $ result & imageL %~ cropped + withReaderT (availWidthL .~ amt) $ + cropResultToContext $ result & imageL %~ cropped -- | Crop the specified widget to the specified size from the right. -- Defers to the cropped widget for growth policy. @@ -1159,8 +1161,11 @@ result <- render p let amt = V.imageHeight (result^.imageL) - rows cropped img = if amt < 0 then V.emptyImage else V.cropTop amt img - return $ addResultOffset (Location (0, -1 * rows)) - $ result & imageL %~ cropped + render $ Widget (hSize p) (vSize p) $ + withReaderT (availHeightL .~ amt) $ + cropResultToContext $ + addResultOffset (Location (0, -1 * rows)) $ + result & imageL %~ cropped -- | Crop the specified widget to the specified size from the top. -- Defers to the cropped widget for growth policy. @@ -1182,7 +1187,8 @@ result <- render p let amt = V.imageHeight (result^.imageL) - rows cropped img = if amt < 0 then V.emptyImage else V.cropBottom amt img - return $ result & imageL %~ cropped + withReaderT (availHeightL .~ amt) $ + cropResultToContext $ result & imageL %~ cropped -- | Crop the specified widget to the specified size from the bottom. -- Defers to the cropped widget for growth policy. @@ -1253,7 +1259,6 @@ renderedClickables renderResult = do allClickables <- use clickableNamesL return [extentName e | e <- renderResult^.extentsL, extentName e `elem` allClickables] - cacheLookup :: (Ord n) => n -> RenderM n (Maybe ([n], Result n)) cacheLookup n = do diff --git a/src/Brick/Widgets/Edit.hs b/src/Brick/Widgets/Edit.hs --- a/src/Brick/Widgets/Edit.hs +++ b/src/Brick/Widgets/Edit.hs @@ -169,7 +169,7 @@ -> Editor T.Text n editorText = editor --- | Construct an editor over 'String' values +-- | Construct an editor over generic text values editor :: Z.GenericTextZipper a => n -- ^ The editor's name (must be unique) diff --git a/src/Brick/Widgets/FileBrowser.hs b/src/Brick/Widgets/FileBrowser.hs --- a/src/Brick/Widgets/FileBrowser.hs +++ b/src/Brick/Widgets/FileBrowser.hs @@ -71,6 +71,7 @@ , actionFileBrowserBeginSearch , actionFileBrowserSelectEnter , actionFileBrowserSelectCurrent + , actionFileBrowserToggleCurrent , actionFileBrowserListPageUp , actionFileBrowserListPageDown , actionFileBrowserListHalfPageUp @@ -158,7 +159,7 @@ import qualified Data.Set as Set import qualified Data.Vector as V import Lens.Micro -import Lens.Micro.Mtl ((%=)) +import Lens.Micro.Mtl ((%=), use) import Lens.Micro.TH (lensRules, generateUpdateableOptics) import qualified Graphics.Vty as Vty import qualified System.Directory as D @@ -602,7 +603,7 @@ -- -- * @/@: 'actionFileBrowserBeginSearch' -- * @Enter@: 'actionFileBrowserSelectEnter' --- * @Space@: 'actionFileBrowserSelectCurrent' +-- * @Space@: 'actionFileBrowserToggleCurrent' -- * @g@: 'actionFileBrowserListTop' -- * @G@: 'actionFileBrowserListBottom' -- * @j@: 'actionFileBrowserListNext' @@ -625,6 +626,10 @@ actionFileBrowserSelectCurrent = selectCurrentEntry +actionFileBrowserToggleCurrent :: EventM n (FileBrowser n) () +actionFileBrowserToggleCurrent = + toggleCurrentEntrySelected + actionFileBrowserListPageUp :: Ord n => EventM n (FileBrowser n) () actionFileBrowserListPageUp = zoom fileBrowserEntriesL listMovePageUp @@ -697,8 +702,8 @@ -- Select file or enter directory actionFileBrowserSelectEnter Vty.EvKey (Vty.KChar ' ') [] -> - -- Select entry - actionFileBrowserSelectCurrent + -- Toggle selected status of current entry + actionFileBrowserToggleCurrent _ -> handleFileBrowserEventCommon e @@ -728,9 +733,29 @@ _ -> zoom fileBrowserEntriesL $ handleListEvent e -markSelected :: FileInfo -> EventM n (FileBrowser n) () -markSelected e = fileBrowserSelectedFilesL %= Set.insert (fileInfoFilename e) +toggleSelected :: FileInfo -> EventM n (FileBrowser n) () +toggleSelected e = do + sel <- fileBrowserIsSelected e + if sel + then fileBrowserRemoveSelected e + else fileBrowserAddSelected e +fileBrowserIsSelected :: FileInfo -> EventM n (FileBrowser n) Bool +fileBrowserIsSelected e = do + fs <- use fileBrowserSelectedFilesL + let fName = fileInfoFilename e + return $ Set.member fName fs + +fileBrowserAddSelected :: FileInfo -> EventM n (FileBrowser n) () +fileBrowserAddSelected e = do + let fName = fileInfoFilename e + fileBrowserSelectedFilesL %= Set.insert fName + +fileBrowserRemoveSelected :: FileInfo -> EventM n (FileBrowser n) () +fileBrowserRemoveSelected e = do + let fName = fileInfoFilename e + fileBrowserSelectedFilesL %= Set.delete fName + -- | If the browser's current entry is selectable according to -- @fileBrowserSelectable@, add it to the selection set and return. -- If not, and if the entry is a directory or a symlink targeting a @@ -742,14 +767,23 @@ b <- get for_ (fileBrowserCursor b) $ \entry -> if fileBrowserSelectable b entry - then markSelected entry + then fileBrowserAddSelected entry else when (selectDirectories entry) $ put =<< liftIO (setWorkingDirectory (fileInfoFilePath entry) b) selectCurrentEntry :: EventM n (FileBrowser n) () selectCurrentEntry = do b <- get - for_ (fileBrowserCursor b) markSelected + for_ (fileBrowserCursor b) $ \entry -> + when (fileBrowserSelectable b entry) $ + fileBrowserAddSelected entry + +toggleCurrentEntrySelected :: EventM n (FileBrowser n) () +toggleCurrentEntrySelected = do + b <- get + for_ (fileBrowserCursor b) $ \entry -> + when (fileBrowserSelectable b entry) $ + toggleSelected entry -- | Render a file browser. This renders a list of entries in the -- working directory, a cursor to select from among the entries, a diff --git a/src/Brick/Widgets/Internal.hs b/src/Brick/Widgets/Internal.hs --- a/src/Brick/Widgets/Internal.hs +++ b/src/Brick/Widgets/Internal.hs @@ -8,7 +8,7 @@ ) where -import Lens.Micro ((^.), (&), (%~)) +import Lens.Micro ((^.), (&), (%~), (.~)) import Lens.Micro.Mtl ((%=)) import Control.Monad import Control.Monad.State.Strict @@ -35,7 +35,13 @@ renderFinal aMap layerRenders (w, h) chooseCursor rs = (newRS, picWithBg, theCursor, concat layerExtents) where - (layerResults, !newRS) = flip runState rs $ sequence $ + -- Reset various fields from the last rendering state so they + -- don't accumulate or affect this rendering. + resetRs = rs & reportedExtentsL .~ mempty + & observedNamesL .~ mempty + & clickableNamesL .~ mempty + + (layerResults, !newRS) = flip runState resetRs $ sequence $ (\p -> runReaderT p ctx) <$> (\layerWidget -> do result <- render $ cropToContext layerWidget @@ -107,29 +113,31 @@ cropExtents :: Context n -> [Extent n] -> [Extent n] cropExtents ctx es = mapMaybe cropExtent es where - -- An extent is cropped in places where it is not within the - -- region described by the context. - -- - -- If its entirety is outside the context region, it is dropped. - -- - -- Otherwise its size is adjusted so that it is contained within - -- the context region. cropExtent (Extent n (Location (c, r)) (w, h)) = - -- Determine the new lower-right corner - let endCol = c + w - endRow = r + h - -- Then clamp the lower-right corner based on the - -- context - endCol' = min (ctx^.availWidthL) endCol - endRow' = min (ctx^.availHeightL) endRow - -- Then compute the new width and height from the - -- clamped lower-right corner. - w' = endCol' - c - h' = endRow' - r - e = Extent n (Location (c, r)) (w', h') - in if w' < 0 || h' < 0 - then Nothing - else Just e + -- Clamp the original extent's UL corner to the context. + -- + -- Clamp the original extent's LR corner to the context. + -- + -- Keep the modified extent (i.e. with clamped corners) + -- only if the resulting extent has non-zero size in both + -- dimensions. + let nonEmpty = nonEmptyH && nonEmptyV + nonEmptyH = newWidth > 0 + nonEmptyV = newHeight > 0 + newWidth = newEndCol - newStartCol + newHeight = newEndRow - newStartRow + (newStartCol, newStartRow) = clampCorner (c, r) + (newEndCol, newEndRow) = clampCorner (c + w, r + h) + clampCorner (cols, rows) = + ( clampRange (ctx^.availWidthL) cols + , clampRange (ctx^.availHeightL) rows + ) + clampRange bound val = + min bound $ max 0 val + newExtent = Extent n (Location (newStartCol, newStartRow)) (newWidth, newHeight) + in if nonEmpty + then Just newExtent + else Nothing cropBorders :: Context n -> BorderMap DynBorder -> BorderMap DynBorder cropBorders ctx = BM.crop Edges diff --git a/src/Brick/Widgets/List.hs b/src/Brick/Widgets/List.hs --- a/src/Brick/Widgets/List.hs +++ b/src/Brick/Widgets/List.hs @@ -63,6 +63,9 @@ , listReverse , listModify + -- * Querying a list + , listFindFirst + -- * Attributes , listAttr , listSelectedAttr @@ -577,6 +580,20 @@ -> GenericList n t e -> GenericList n t e listMoveToElement e = listFindBy (== e) . set listSelectedL Nothing + +-- | Find the first element in the list that satisfies the specified +-- predicate. If such an element is found, return the resulting index +-- and element. +-- +-- /O(n)/. +listFindFirst :: (Semigroup (t e), Splittable t, Traversable t) + => (e -> Bool) + -> GenericList n t e + -> Maybe (Int, e) +listFindFirst f l = + listSelectedElement $ + listFindBy f $ + set listSelectedL Nothing l -- | Starting from the currently-selected position, attempt to find -- and select the next element matching the predicate. If there are no diff --git a/tests/List.hs b/tests/List.hs --- a/tests/List.hs +++ b/tests/List.hs @@ -348,6 +348,15 @@ in l' ^. listSelectedL == Just 1 && l'' ^. listSelectedL == Just 3 +prop_listFindFirst :: Bool +prop_listFindFirst = + let v = L [1..5] :: L Int + l = list () v 1 + result1 = listFindFirst even l + result2 = listFindFirst (> 10) l + in result1 == Just (1, 2) && + result2 == Nothing + prop_listSelectedElement_lazy :: Bool prop_listSelectedElement_lazy = let v = L (1:2:3:4:undefined) :: L Int