reflex-vty 0.1.4.2 → 0.2.0.0
raw patch · 21 files changed
+2576/−1367 lines, 21 filesdep +extradep +hspecdep +mmorphdep −text-icudep ~basedep ~containersdep ~reflex
Dependencies added: extra, hspec, mmorph, ordered-containers
Dependencies removed: text-icu
Dependency ranges changed: base, containers, reflex, text, vty
Files
- ChangeLog.md +87/−0
- README.md +2/−3
- reflex-vty.cabal +86/−5
- src-bin/Example/CPU.hs +231/−0
- src-bin/example.hs +213/−151
- src/Control/Monad/NodeId.hs +4/−7
- src/Data/Text/Zipper.hs +291/−156
- src/Reflex/Class/Switchable.hs +0/−29
- src/Reflex/Spider/Orphans.hs +0/−3
- src/Reflex/Vty.hs +6/−0
- src/Reflex/Vty/Host.hs +0/−7
- src/Reflex/Vty/Widget.hs +556/−735
- src/Reflex/Vty/Widget/Box.hs +124/−0
- src/Reflex/Vty/Widget/Input.hs +40/−22
- src/Reflex/Vty/Widget/Input/Mouse.hs +106/−0
- src/Reflex/Vty/Widget/Input/Text.hs +22/−22
- src/Reflex/Vty/Widget/Layout.hs +491/−227
- src/Reflex/Vty/Widget/Split.hs +92/−0
- src/Reflex/Vty/Widget/Text.hs +106/−0
- test/Data/Text/ZipperSpec.hs +104/−0
- test/Spec.hs +15/−0
ChangeLog.md view
@@ -1,11 +1,98 @@ # Revision history for reflex-vty +## 0.2.0.0++* _Module Reorganization_: The following modules have been added (and are all re-exported by Reflex.Vty):+ * Reflex.Vty.Widget.Box for all the box functions and datatypes+ * Reflex.Vty.Widget.Input.Mouse for clicking, dragging, and scrolling+ * Reflex.Vty.Widget.Split contains `splitV`, `splitH`, etc+ * Reflex.Vty.Widget.Text contains text rendering functions like `text` and `display`+* _Bugfixes_:+ * Remove text-icu dependency and switch to `wcwidth` from vty package to compute character width in `Data.Text.Zipper`.+ * `goToDisplayLinePosition` in `Data.Text.Zipper` correctly accounts for character width now.+ * [#37](https://github.com/reflex-frp/reflex-vty/issues/37) `Layout` should support focus changes through nested layouts (thanks @pdlla for getting this started -- see entry on Layout and Focus below).+ * Fix distribution of available space when it cannot be evenly distributed. Previously, all leftover space would be allocated to the first stretchable widget.+* _Breaking Changes_:+ * Layout and focus have been substantially refactored to fix [#37](https://github.com/reflex-frp/reflex-vty/issues/37) and support a wider variety of layouts and focus switching requirements.+ * Added a new `HasFocus` class (the old one is now `HasFocusReader`) to produce focusable elements, and manage focus state. See the "Focus" section of the Reflex.Vty.Widget.Layout module documentation.+ * `Layout` no longer has any focus-tracking responsibility. See the "Layout" section of the Reflex.Vty.Widget.Layout module documentation.+ * `tile` no longer takes a configuration record and no longer requires that its child widget return a focus request event. Focus requests are instead handled using calls to `requestFocus` in the child widget.+ * Calls to `fixed` and `stretch` must now be replaced with `tile . fixed` and `tile . stretch`+ * `stretch` now takes a minimum size argument+ * Added `flex` which is equivalent to `stretch 0`+ * `tabNavigation` no longer returns an `Event`. Instead it calls `requestFocus` directly with the appropriate `Refocus_Shift` value.+ * Added `axis` (in `HasLayout`), a lower-level primitive which is used to implement `row` and `col`.+ * Added `region` (in `HasLayout`), which is used to claim screen real estate and used to implement `tile` and `grout`+ * Added `grout`, a container element that is not itself focusable (though its children can be)+ * Removed `VtyWidget` and replaced it with a number of separate classes and monad transformers+ * Replace `HasDisplaySize` with `HasDisplayRegion` which carries around a region instead of just a width and height. `displayWidth` and `displayHeight` are now functions implemented in terms of `askRegion` instead of class methods.+ * Add a `DisplayRegion` monad transformer+ * Rename `ImageWriter` to `HasImageWriter`+ * Introduce an `ImageWriter` monad transformer+ * Rename `HasFocus` to `HasFocusReader`+ * Introduce a `FocusReader` monad transformer+ * Replace `HasVtyInput` with `HasInput`+ * Introduce an `Input` monad transformer+ * Introduce `HasTheme` reader class to allow setting Vty attributes of all built-in widgets+ * Introduce `ThemeReader` monad transformer+ * Remove `DynRegion` and `currentRegion`. Use `Dynamic t Region` and `current` instead. This also changes the type of `pane`'s argument.+ * `CheckboxConfig` now has a field taking an `Event` to set the value of the checkbox.+ * `checkbox` now accepts keyboard input (spacebar to check and uncheck) and is displayed in bold when focused.+ * `HasInput` (formerly `HasVtyInput`) now has a method `localInput` for filtering the input a child widget may receive+ * `HasImageWriter` now has a method `mapImages` for transforming the images emitted by a child widget+ * `boxTitle` now takes a `Behavior t Text` as its title, instead of a plain `Text`+ * `fill` now takes a `Behavior t Char` instead of a `Char`+ * The following functions are no longer specialized to `VtyWidget`:+ * `pane`: Now requires `HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m`+ * `drag`: Now requires `HasInput`+ * `mouseDown`: Now requires `HasInput`+ * `mouseUp`: Now requires `HasInput`+ * `mouseScroll`: Now requires `HasInput`+ * `key`: Now requires `HasInput`+ * `keys`: Now requires `HasInput`+ * `keyCombo`: Now requires `HasInput`+ * `keyCombos`: Now requires `HasInput`+ * `splitV`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`+ * `splitH`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`+ * `splitVDrag`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`+ * `fill`: Now requires `HasImageWriter` and `HasDisplayRegion`+ * `boxTitle`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`+ * `box`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`+ * `boxStatic`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`+ * `richText`: Now requires `HasImageWriter`, and `HasDisplayRegion`+ * `scrollableText`: Now requires `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`+ * `blank`: Now requires `Monad`+ * `button`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`+ * `textButton`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`+ * `textButtonStatic`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`+ * `link`: Now requires `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`+ * `checkbox`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`+ * TextZipper interface changes+ * `_displayLines_offsetMap` type changed to `OffsetMapWithAlignment`+ * `_displayLines_cursorY` replaced with `_displayLines_cursorPos` which include X position+ * some exposed methods intended for internal use only have been removed+ * `textInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`+ * `multilineTextInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`+ * `textInputTile`: Now requires `HasFocusReader`, `HasInput`, `HasLayout`, `HasTheme`, and `HasFocus`+* _Misc_:+ * (#40 Add alignment support to TextZipper)[https://github.com/reflex-frp/reflex-vty/pull/40]+ * Add alignment (left/center/right) support to TextZipper+ * Add basic unit tests for newly created alignment methods in TextZipper+ * Add default instances for `HasInput`, `HasFocus`, and `HasImageWriter`+ * Export `withinImage` and add `imagesInRegion` to crop images to a region+ * Add `anyChildFocused`, which provides information about whether subwidgets are focused+ * Add `filterKeys`, which is the same as `localInput` but only cares about keyboard events+ * Add `hoistRunLayout` to apply a transformation to the context of a `Layout` action and run that action+ * Add various `MFunctor` instances+ * Add a CPU usage indicator to the example executable+ ## 0.1.4.2 * Wider bounds for GHC 8.10 support ## 0.1.4.1 +## 0.1.4.1 * Migrate to new dependent-sum / dependent-map (after the "some" package split) ## 0.1.4.0
README.md view
@@ -14,10 +14,9 @@ Enter a nix-shell for the project: ```bash-git clone git@github.com:reflex-frp/reflex-platform-git clone git@github.com:reflex-frp/reflex-vty+git clone https://github.com/reflex-frp/reflex-vty.git cd reflex-vty-../reflex-platform/scripts/work-on ghc ./.+nix-shell ``` From within the nix-shell you can:
reflex-vty.cabal view
@@ -1,5 +1,5 @@ name: reflex-vty-version: 0.1.4.2+version: 0.2.0.0 synopsis: Reflex FRP host and widgets for VTY applications description: Build terminal applications using functional reactive programming (FRP) with Reflex FRP (<https://reflex-frp.org>).@@ -28,11 +28,14 @@ exposed-modules: Reflex.Vty , Reflex.Vty.Host , Reflex.Vty.Widget+ , Reflex.Vty.Widget.Box , Reflex.Vty.Widget.Input+ , Reflex.Vty.Widget.Input.Mouse , Reflex.Vty.Widget.Input.Text , Reflex.Vty.Widget.Layout+ , Reflex.Vty.Widget.Split+ , Reflex.Vty.Widget.Text , Data.Text.Zipper- , Reflex.Class.Switchable , Reflex.Spider.Orphans , Control.Monad.NodeId build-depends:@@ -45,22 +48,52 @@ data-default >= 0.7.1 && < 0.8, dependent-map >= 0.4 && < 0.5, text >= 1.2.3 && < 1.3,- text-icu >= 0.7 && < 0.8, dependent-sum >= 0.7 && < 0.8, exception-transformers >= 0.4.0 && < 0.5,+ mmorph >= 1.1 && < 1.2,+ ordered-containers >= 0.2.2 && < 0.3, primitive >= 0.6.3 && < 0.8, ref-tf >= 0.4.0 && < 0.5, reflex >= 0.8 && < 0.9, time >= 1.8.0 && < 1.10,- vty >= 5.21 && < 5.29+ vty >= 5.28 && < 5.29 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall+ default-extensions:+ BangPatterns+ ConstraintKinds+ CPP+ DataKinds+ DefaultSignatures+ DeriveFunctor+ DeriveGeneric+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ OverloadedStrings+ PatternGuards+ PolyKinds+ QuasiQuotes+ RankNTypes+ RecursiveDo+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies executable example hs-source-dirs: src-bin main-is: example.hs- ghc-options: -threaded+ ghc-options: -threaded -Wall build-depends: base, containers,@@ -70,4 +103,52 @@ time, transformers, vty+ default-language: Haskell2010+ other-modules: Example.CPU+ default-extensions:+ BangPatterns+ ConstraintKinds+ CPP+ DataKinds+ DefaultSignatures+ DeriveFunctor+ DeriveGeneric+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ OverloadedStrings+ PatternGuards+ PolyKinds+ QuasiQuotes+ RankNTypes+ RecursiveDo+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+++test-suite reflex-vty-test+ hs-source-dirs: test+ main-is: Spec.hs+ type: exitcode-stdio-1.0+ ghc-options: -threaded+ other-modules:+ Data.Text.ZipperSpec+ build-depends:+ base,+ reflex,+ containers,+ reflex-vty,+ text,+ extra,+ hspec >= 2.7 && < 2.8 default-language: Haskell2010
+ src-bin/Example/CPU.hs view
@@ -0,0 +1,231 @@+{-|+ Description: A CPU usage indicator+-}+module Example.CPU where++import Control.Exception+import Control.Monad.Fix+import Control.Monad.IO.Class+import Data.Ratio+import Data.Time+import Data.Word+import qualified Data.Text as T+import qualified Graphics.Vty as V+import Text.Printf++import Reflex+import Reflex.Vty++-- | Each constructor represents a cpu statistic column as presented in @/proc/stat@+data CpuStat+ = CpuStat_User+ | CpuStat_Nice+ | CpuStat_System+ | CpuStat_Idle+ | CpuStat_Iowait+ | CpuStat_Irq+ | CpuStat_Softirq+ | CpuStat_Steal+ | CpuStat_Guest+ | CpuStat_GuestNice+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++-- | Read @/proc/stat@+getCpuStat :: IO (Maybe (CpuStat -> Word64))+getCpuStat = do+ s <- readFile "/proc/stat"+ _ <- evaluate $ length s -- Make readFile strict+ pure $ do+ cpuSummaryLine : _ <- pure $ lines s+ [user, nice, system, idle, iowait, irq, softirq, steal, guest, guestNice] <- pure $ map read $ words $ drop 4 cpuSummaryLine+ pure $ \case+ CpuStat_User -> user+ CpuStat_Nice -> nice+ CpuStat_System -> system+ CpuStat_Idle -> idle+ CpuStat_Iowait -> iowait+ CpuStat_Irq -> irq+ CpuStat_Softirq -> softirq+ CpuStat_Steal -> steal+ CpuStat_Guest -> guest+ CpuStat_GuestNice -> guestNice++sumStats :: (CpuStat -> Word64) -> [CpuStat] -> Word64+sumStats get stats = sum $ get <$> stats++-- | user + nice + system + irq + softirq + steal+nonIdleStats :: [CpuStat]+nonIdleStats =+ [ CpuStat_User+ , CpuStat_Nice+ , CpuStat_System+ , CpuStat_Irq+ , CpuStat_Softirq+ , CpuStat_Steal+ ]++-- | idle + iowait+idleStats :: [CpuStat]+idleStats =+ [ CpuStat_Idle+ , CpuStat_Iowait+ ]++-- | Draws the cpu usage percent as a live-updating bar graph. The output should look like:+--+-- > ╔══════ CPU Usage: 38% ══════╗+-- > ║ ║+-- > ║ ║+-- > ║ ║+-- > ║ ║+-- > ║ ║+-- > ║ ║+-- > ║█████████████████████████████║+-- > ║█████████████████████████████║+-- > ║█████████████████████████████║+-- > ║█████████████████████████████║+-- > ╚═════════════════════════════╝+--+cpuStats+ :: ( Reflex t+ , MonadFix m+ , MonadHold t m+ , MonadIO (Performable m)+ , MonadIO m+ , PerformEvent t m+ , PostBuild t m+ , TriggerEvent t m+ , HasDisplayRegion t m+ , HasImageWriter t m+ , HasLayout t m+ , HasFocus t m+ , HasInput t m+ , HasFocusReader t m, HasTheme t m+ )+ => m ()+cpuStats = do+ tick <- tickLossy 0.25 =<< liftIO getCurrentTime+ cpuStat :: Event t (Word64, Word64) <- fmap (fmapMaybe id) $+ performEvent $ ffor tick $ \_ -> do+ get <- liftIO getCpuStat+ pure $ case get of+ Nothing -> Nothing+ Just get' -> Just (sumStats get' nonIdleStats, sumStats get' idleStats)+ active <- foldDyn cpuPercentStep ((0, 0), 0) cpuStat+ let pct = fmap snd active+ chart pct++chart+ :: ( MonadFix m+ , HasFocus t m+ , HasLayout t m+ , HasImageWriter t m+ , HasInput t m+ , HasDisplayRegion t m+ , HasFocusReader t m, HasTheme t m+ )+ => Dynamic t (Ratio Word64) -> m ()+chart pct = do+ let title = ffor pct $ \x -> mconcat+ [ " CPU Usage: "+ , T.pack (printf "%3d" $ (ceiling $ x * 100 :: Int))+ , "% "+ ]+ boxTitle (pure doubleBoxStyle) (current title) $ col $ do+ grout flex blank+ dh <- displayHeight+ let heights = calcRowHeights <$> dh <*> pct+ quarters = fst <$> heights+ eighths = snd <$> heights+ eighthRow = ffor eighths $ \x -> if x == 0 then 0 else 1+ grout (fixed eighthRow) $ fill' (current $ eighthBlocks <$> eighths) $ current $+ ffor quarters $ \q ->+ if | _quarter_fourth q > 0 -> red+ | _quarter_third q > 0 -> orange+ | _quarter_second q > 0 -> yellow+ | otherwise -> white+ grout (fixed $ _quarter_fourth <$> quarters) $ fill' (pure '█') (pure red)+ grout (fixed $ _quarter_third <$> quarters) $ fill' (pure '█') (pure orange)+ grout (fixed $ _quarter_second <$> quarters) $ fill' (pure '█') (pure yellow)+ grout (fixed $ _quarter_first <$> quarters) $ fill' (pure '█') (pure white)+ where+ -- Calculate number of full rows, height of partial row+ calcRowHeights :: Int -> Ratio Word64 -> (Quarter Int, Int)+ calcRowHeights h r =+ let (full, leftovers) = divMod (numerator r * fromIntegral h) (denominator r)+ partial = ceiling $ 8 * (leftovers % denominator r)+ quarter = ceiling $ fromIntegral h / (4 :: Double)+ n = fromIntegral full+ in if | n <= quarter ->+ (Quarter n 0 0 0, partial)+ | n <= (2 * quarter) ->+ (Quarter quarter (n - quarter) 0 0, partial)+ | n <= (3 * quarter) ->+ (Quarter quarter quarter (n - (2 * quarter)) 0, partial)+ | otherwise ->+ (Quarter quarter quarter quarter (n - (3 * quarter)), partial)+ fill' bc attr = do+ dw <- displayWidth+ dh <- displayHeight+ let fillImg =+ (\w h c a -> [V.charFill a c w h])+ <$> current dw+ <*> current dh+ <*> bc+ <*> attr+ tellImages fillImg+ color :: Int -> Int -> Int -> V.Color+ color = V.rgbColor+ red = V.withForeColor V.defAttr $ color 255 0 0+ orange = V.withForeColor V.defAttr $ color 255 165 0+ yellow = V.withForeColor V.defAttr $ color 255 255 0+ white = V.withForeColor V.defAttr $ color 255 255 255++data Quarter a = Quarter+ { _quarter_first :: a+ , _quarter_second :: a+ , _quarter_third :: a+ , _quarter_fourth :: a+ }++eighthBlocks :: (Eq a, Num a, Ord a) => a -> Char+eighthBlocks n =+ if+ | n <= 0 -> ' '+ | n == 1 -> '▁'+ | n == 2 -> '▂'+ | n == 3 -> '▃'+ | n == 4 -> '▄'+ | n == 5 -> '▅'+ | n == 6 -> '▆'+ | n == 7 -> '▇'+ | otherwise -> '█'++-- | Determine the current percentage usage according to this algorithm:+--+-- PrevIdle = previdle + previowait+-- Idle = idle + iowait+--+-- PrevNonIdle = prevuser + prevnice + prevsystem + previrq + prevsoftirq + prevsteal+-- NonIdle = user + nice + system + irq + softirq + steal+--+-- PrevTotal = PrevIdle + PrevNonIdle+-- Total = Idle + NonIdle+--+-- totald = Total - PrevTotal+-- idled = Idle - PrevIdle+--+-- CPU_Percentage = (totald - idled)/totald+--+-- Source: https://stackoverflow.com/questions/23367857/accurate-calculation-of-cpu-usage-given-in-percentage-in-linux+cpuPercentStep+ :: (Word64, Word64) -- Current active, Current idle+ -> ((Word64, Word64), Ratio Word64) -- (Previous idle, Previous total), previous percent+ -> ((Word64, Word64), Ratio Word64) -- (New idle, new total), percent+cpuPercentStep (nonidle, idle) ((previdle, prevtotal), _) =+ let total = idle + nonidle+ idled = idle - previdle+ totald = total - prevtotal+ in ( (idle, total)+ , (totald - idled) % totald+ )
src-bin/example.hs view
@@ -1,130 +1,151 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -threaded #-}- import Control.Applicative import Control.Monad import Control.Monad.Fix-import Control.Monad.NodeId+import Data.Functor import Data.Functor.Misc import Data.Map (Map)-import Data.Maybe import qualified Data.Map as Map+import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Zipper as TZ import qualified Graphics.Vty as V import Reflex import Reflex.Network-import Reflex.Class.Switchable import Reflex.Vty +import Example.CPU++type VtyExample t m =+ ( MonadFix m+ , Reflex t+ , HasInput t m+ , HasImageWriter t m+ , HasDisplayRegion t m+ , HasFocus t m+ , HasFocusReader t m, HasTheme t m+ )++type Manager t m =+ ( HasLayout t m+ , HasFocus t m+ )+ data Example = Example_TextEditor | Example_Todo | Example_ScrollableTextDisplay+ | Example_ClickButtonsGetEmojis+ | Example_CPUStat deriving (Show, Read, Eq, Ord, Enum, Bounded) +withCtrlC :: (Monad m, HasInput t m, Reflex t) => m () -> m (Event t ())+withCtrlC f = do+ inp <- input+ f+ return $ fforMaybe inp $ \case+ V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()+ _ -> Nothing++darkTheme :: V.Attr+darkTheme = V.Attr {+ V.attrStyle = V.SetTo V.standout+ , V.attrForeColor = V.SetTo V.black+ , V.attrBackColor = V.Default+ , V.attrURL = V.Default+}+ main :: IO ()-main = mainWidget $ do+main = mainWidget $ withCtrlC $ do+ initManager_ $ do+ tabNavigation+ let gf = grout . fixed+ t = tile flex+ buttons = col $ do+ gf 3 $ col $ do+ gf 1 $ text "Select an example."+ gf 1 $ text "Esc will bring you back here."+ gf 1 $ text "Ctrl+c to quit."+ a <- t $ textButtonStatic def "Todo List"+ b <- t $ textButtonStatic def "Text Editor"+ c <- t $ textButtonStatic def "Scrollable text display"+ d <- t $ textButtonStatic def "Clickable buttons"+ e <- t $ textButtonStatic def "CPU Usage"+ return $ leftmost+ [ Left Example_Todo <$ a+ , Left Example_TextEditor <$ b+ , Left Example_ScrollableTextDisplay <$ c+ , Left Example_ClickButtonsGetEmojis <$ d+ , Left Example_CPUStat <$ e+ ]+ let escapable w = do+ void w+ i <- input+ return $ fforMaybe i $ \case+ V.EvKey V.KEsc [] -> Just $ Right ()+ _ -> Nothing+ rec out <- networkHold buttons $ ffor (switch (current out)) $ \case+ Left Example_Todo -> escapable taskList+ Left Example_TextEditor -> escapable $ localTheme (const (constant darkTheme)) testBoxes+ Left Example_ScrollableTextDisplay -> escapable scrolling+ Left Example_ClickButtonsGetEmojis -> escapable easyExample+ Left Example_CPUStat -> escapable cpuStats+ Right () -> buttons+ return ()++-- * Mouse button and emojis example+easyExample :: (VtyExample t m, Manager t m, MonadHold t m) => m (Event t ())+easyExample = do+ row $ grout (fixed 39) $ col $ do+ (a1,b1,c1) <- grout (fixed 3) $ row $ do+ a <- tile flex $ btn "POTATO"+ b <- tile flex $ btn "TOMATO"+ c <- tile flex $ btn "EGGPLANT"+ return (a,b,c)+ (a2,b2,c2) <- grout (fixed 3) $ row $ do+ a <- tile flex $ btn "CHEESE"+ b <- tile flex $ btn "BEES"+ c <- tile flex $ btn "MY KNEES"+ return (a,b,c)+ (a3,b3,c3) <- grout (fixed 3) $ row $ do+ a <- tile flex $ btn "TIME"+ b <- tile flex $ btn "RHYME"+ c <- tile flex $ btn "A BIG CRIME"+ return (a,b,c)+ tile (fixed 7) $ boxTitle (constant def) "CLICK BUTTONS TO DRAW*" $ do+ outputDyn <- foldDyn (<>) "" $ mergeWith (<>)+ [a1 $> "\129364", b1 $> "🍅", c1 $> "🍆", a2 $> "\129472", b2 $> "🐝🐝", c2 $> "💘", a3 $> "⏰", b3 $> "📜", c3 $> "💰🔪🔒"]+ text (current outputDyn)+ tile flex $ text "* Requires font support for emojis. Box may render incorrectly unless your vty is initialized with an updated char width map." inp <- input- let buttons = col $ do- fixed 4 $ col $ do- fixed 1 $ text "Select an example."- fixed 1 $ text "Esc will bring you back here."- fixed 1 $ text "Ctrl+c to quit."- a <- fixed 5 $ textButtonStatic def "Todo List"- b <- fixed 5 $ textButtonStatic def "Text Editor"- c <- fixed 5 $ textButtonStatic def "Scrollable text display"- return $ leftmost- [ Left Example_Todo <$ a- , Left Example_TextEditor <$ b- , Left Example_ScrollableTextDisplay <$ c- ]- escapable w = do- void w- i <- input- return $ fforMaybe i $ \case- V.EvKey V.KEsc [] -> Just $ Right ()- _ -> Nothing- rec out <- networkHold buttons $ ffor (switch (current out)) $ \case- Left Example_TextEditor -> escapable testBoxes- Left Example_Todo -> escapable taskList- Left Example_ScrollableTextDisplay -> escapable scrolling- Right () -> buttons return $ fforMaybe inp $ \case V.EvKey (V.KChar 'c') [V.MCtrl] -> Just () _ -> Nothing- + where+ btn label = do+ let cfg = def { _buttonConfig_focusStyle = pure doubleBoxStyle }+ buttonClick <- textButtonStatic cfg label+ keyPress <- keyCombos $ Set.fromList+ [ (V.KEnter, [])+ , (V.KChar ' ', [])+ ]+ pure $ leftmost [() <$ buttonClick, () <$ keyPress]++-- * Task list example taskList- :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m)- => VtyWidget t m ()-taskList = do- let btn = textButtonStatic def "Add another task"- inp <- input+ :: (VtyExample t m, Manager t m, MonadHold t m, Adjustable t m, PostBuild t m)+ => m ()+taskList = col $ do let todos0 = [ Todo "Find reflex-vty" True , Todo "Become functional reactive" False , Todo "Make vty apps" False ]- rec let todos' = todos todos0 $ leftmost- [ () <$ e- , fforMaybe inp $ \case- V.EvKey V.KEnter [] -> Just ()- _ -> Nothing- ]- (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $- splitV (pure (subtract 3)) (pure (True, True)) btn (display $ Map.size <$> current m)+ btn = textButtonStatic def "Add another task"+ enter <- fmap (const ()) <$> key V.KEnter+ rec void $ grout flex $ todos todos0 $ enter <> click+ click <- tile (fixed 3) btn return () -testBoxes- :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId m)- => VtyWidget t m ()-testBoxes = do- dw <- displayWidth- dh <- displayHeight- let region1 = DynRegion (div' dw 6) (div' dh 6) (div' dw 2) (div' dh 2)- region2 = DynRegion (div' dw 4) (div' dh 4) (2 * div' dw 3) (2 * div' dh 3)- pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput- _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $- let cfg = def- { _textInputConfig_initialValue =- "This box is a text input. The box below responds to mouse drag inputs. You can also drag the separator between the boxes to resize them."- }- textBox = boxTitle (pure roundedBoxStyle) "Text Edit" $- multilineTextInput cfg- dragBox = boxStatic roundedBoxStyle dragTest- in splitVDrag (hRule doubleBoxStyle) textBox dragBox- return ()- where- div' :: (Integral a, Applicative f) => f a -> f a -> f a- div' = liftA2 div--debugFocus :: (Reflex t, Monad m) => VtyWidget t m ()-debugFocus = do- f <- focus- text $ T.pack . show <$> current f--debugInput :: (Reflex t, MonadHold t m) => VtyWidget t m ()-debugInput = do- lastEvent <- hold "No event yet" . fmap show =<< input- text $ T.pack <$> lastEvent--dragTest :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()-dragTest = do- lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft- text $ T.pack <$> lastEvent--testStringBox :: (Reflex t, Monad m, MonadNodeId m) => VtyWidget t m ()-testStringBox = boxStatic singleBoxStyle .- text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])- data Todo = Todo { _todo_label :: Text , _todo_done :: Bool@@ -135,87 +156,128 @@ { _todoOutput_todo :: Dynamic t Todo , _todoOutput_delete :: Event t () , _todoOutput_height :: Dynamic t Int+ , _todoOutput_focusId :: FocusId } -instance Reflex t => Switchable t (TodoOutput t) where- switching t0 e = TodoOutput- <$> switching (_todoOutput_todo t0) (_todoOutput_todo <$> e)- <*> switching (_todoOutput_delete t0) (_todoOutput_delete <$> e)- <*> switching (_todoOutput_height t0) (_todoOutput_height <$> e)- todo- :: (MonadHold t m, MonadFix m, Reflex t, MonadNodeId m)+ :: (VtyExample t m, Manager t m, MonadHold t m) => Todo- -> VtyWidget t m (TodoOutput t)-todo t0 = do- w <- displayWidth- rec let checkboxWidth = 3- checkboxRegion = DynRegion 0 0 checkboxWidth 1- labelHeight = _textInput_lines ti- labelWidth = w - 1 - checkboxWidth- labelLeft = checkboxWidth + 1 - labelTop = constDyn 0- labelRegion = DynRegion labelLeft labelTop labelWidth labelHeight- value <- pane checkboxRegion (pure True) $ checkbox def $ _todo_done t0- (ti, d) <- pane labelRegion (pure True) $ do- i <- input- v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }- let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i- return (v, deleteSelf)- return $ TodoOutput- { _todoOutput_todo = Todo <$> _textInput_value ti <*> value- , _todoOutput_delete = d- , _todoOutput_height = _textInput_lines ti- }+ -> m (TodoOutput t)+todo t0 = row $ do+ let toggleKeys = Set.fromList+ [ (V.KChar ' ', [V.MCtrl])+ , (V.KChar '@', [V.MCtrl])+ ]+ anyChildFocused $ \focused -> do+ toggleE <- keyCombos toggleKeys+ filterKeys (flip Set.notMember $ Set.insert (V.KChar '\t', []) toggleKeys) $ do+ rec let cfg = def+ { _checkboxConfig_setValue = setVal+ }+ value <- tile (fixed 4) $ checkbox cfg $ _todo_done t0+ let setVal = attachWith (\v _ -> not v) (current value) $ gate (current focused) toggleE+ (fid, (ti, d)) <- tile' flex $ do+ i <- input+ v <- textInput $ def+ { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }+ let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i+ return (v, deleteSelf)+ return $ TodoOutput+ { _todoOutput_todo = Todo <$> _textInput_value ti <*> value+ , _todoOutput_delete = d+ , _todoOutput_height = _textInput_lines ti+ , _todoOutput_focusId = fid+ } where backspaceOnEmpty v = \case V.EvKey V.KBS _ | T.null v -> Just () _ -> Nothing -scrolling :: (Reflex t, MonadHold t m, MonadFix m, PostBuild t m, MonadNodeId m) => VtyWidget t m ()-scrolling = col $ do- fixed 2 $ text "Use your mouse wheel or up and down arrows to scroll:"- out <- fixed 5 $ boxStatic def $ scrollableText never $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant."- fixed 1 $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)- todos :: forall t m. ( MonadHold t m- , MonadFix m- , Reflex t+ , Manager t m+ , VtyExample t m , Adjustable t m- , NotReady t m , PostBuild t m- , MonadNodeId m ) => [Todo] -> Event t ()- -> VtyWidget t m (Dynamic t (Map Int (TodoOutput t)))+ -> m (Dynamic t (Map Int (TodoOutput t))) todos todos0 newTodo = do let todosMap0 = Map.fromList $ zip [0..] todos0- rec tabNav <- tabNavigation- let insertNav = 1 <$ insert- nav = leftmost [tabNav, insertNav]- tileCfg = def { _tileConfig_constraint = pure $ Constraint_Fixed 1}- listOut <- runLayout (pure Orientation_Column) 0 nav $- listHoldWithKey todosMap0 updates $ \k t -> tile tileCfg $ do- let sel = select selectOnDelete $ Const2 k- click <- void <$> mouseDown V.BLeft- pb <- getPostBuild- let focusMe = leftmost [ click, sel, pb ]- r <- todo t- return (focusMe, r)- let delete = ffor todoDelete $ \k -> Map.singleton k Nothing+ rec listOut <- listHoldWithKey todosMap0 updates $ \k t -> grout (fixed 1) $ do+ to <- todo t+ let sel = select selectOnDelete $ Const2 k+ pb <- getPostBuild+ requestFocus $ Refocus_Id (_todoOutput_focusId to) <$ leftmost [pb, sel]+ pure to+ let delete = flip Map.singleton Nothing <$> todoDelete+ todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut+ insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of+ Nothing -> Map.singleton 0 $ Just $ Todo "" False+ Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False updates = leftmost [insert, delete] todoDelete = switch . current $ leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut- todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut- insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of- Nothing -> Map.singleton 0 $ Just $ Todo "" False- Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False+ selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe (\m k -> let (before, after) = Map.split k m in fmap fst $ Map.lookupMax before <|> Map.lookupMin after) (current todosMap) todoDelete return listOut++-- * Scrollable text example++scrolling :: (VtyExample t m, MonadHold t m, Manager t m, PostBuild t m) => m ()+scrolling = col $ do+ grout (fixed 2) $ text "Use your mouse wheel or up and down arrows to scroll:"+ (fid, out) <- tile' (fixed 5) $ boxStatic def $ scrollableText never $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant."+ pb <- getPostBuild+ requestFocus $ Refocus_Id fid <$ pb+ grout (fixed 1) $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)++-- * Text editor example with resizable boxes++testBoxes+ :: (MonadHold t m, VtyExample t m)+ => m ()+testBoxes = do+ dw <- displayWidth+ dh <- displayHeight+ let region1 = Region <$> (div' dw 6) <*> (div' dh 6) <*> (div' dw 2) <*> (div' dh 2)+ region2 = Region <$> (div' dw 4) <*> (div' dh 4) <*> (2 * div' dw 3) <*> (2 * div' dh 3)+ pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput+ _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $+ let cfg = def+ { _textInputConfig_initialValue =+ "This box is a text input. The box below responds to mouse drag inputs. You can also drag the separator between the boxes to resize them."+ }+ textBox = boxTitle (pure roundedBoxStyle) "Text Edit" $+ multilineTextInput cfg+ dragBox = boxStatic roundedBoxStyle dragTest+ in splitVDrag (hRule doubleBoxStyle) textBox dragBox+ return ()+ where+ div' :: (Integral a, Applicative f) => f a -> f a -> f a+ div' = liftA2 div++debugFocus :: (VtyExample t m) => m ()+debugFocus = do+ f <- focus+ text $ T.pack . show <$> current f++debugInput :: (VtyExample t m, MonadHold t m) => m ()+debugInput = do+ lastEvent <- hold "No event yet" . fmap show =<< input+ text $ T.pack <$> lastEvent++dragTest :: (VtyExample t m, MonadHold t m) => m ()+dragTest = do+ lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft+ text $ T.pack <$> lastEvent++testStringBox :: VtyExample t m => m ()+testStringBox = boxStatic singleBoxStyle .+ text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
src/Control/Monad/NodeId.hs view
@@ -2,12 +2,7 @@ Module: Control.Monad.NodeId Description: Monad providing a supply of unique identifiers -}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}+{-# Language UndecidableInstances #-} module Control.Monad.NodeId ( NodeId , MonadNodeId (..)@@ -15,6 +10,7 @@ , runNodeIdT ) where +import Control.Monad.Morph import Control.Monad.Reader import Control.Monad.Ref import Data.IORef@@ -39,10 +35,12 @@ deriving ( Functor , Applicative+ , MFunctor , Monad , MonadFix , MonadHold t , MonadIO+ , MonadRef , MonadReflexCreateTrigger t , MonadSample t , MonadTrans@@ -50,7 +48,6 @@ , PerformEvent t , PostBuild t , TriggerEvent t- , MonadRef ) instance MonadNodeId m => MonadNodeId (ReaderT x m)
src/Data/Text/Zipper.hs view
@@ -7,27 +7,28 @@ 'TextZipper's can be converted into 'DisplayLines', which describe how the contents of the zipper will be displayed when wrapped to fit within a container of a certain width. It also provides some convenience facilities for converting interactions with the rendered DisplayLines back into manipulations of the underlying TextZipper. -}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-} module Data.Text.Zipper where +import Prelude++import Control.Exception (assert)+import Control.Monad.State (evalState, forM, get, put) import Data.Char (isSpace) import Data.Map (Map)-import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.String-import Control.Monad.State (evalState, forM, get, put)- import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.ICU.Char import Data.Text.Internal (Text(..), text) import Data.Text.Internal.Fusion (stream) import Data.Text.Internal.Fusion.Types (Stream(..), Step(..)) import Data.Text.Unsafe+import qualified Data.List as L+import qualified Data.Map as Map+import qualified Data.Text as T +import Graphics.Text.Width (wcwidth)++ -- | A zipper of the logical text input contents (the "document"). The lines -- before the line containing the cursor are stored in reverse order. -- The cursor is logically between the "before" and "after" text.@@ -169,7 +170,7 @@ -- | Insert up to n spaces to get to the next logical column that is a multiple of n tab :: Int -> TextZipper -> TextZipper tab n z@(TextZipper _ b _ _) =- insert (T.replicate (fromEnum $ n - (T.length b `mod` max 1 n)) " ") z+ insert (T.replicate (fromEnum $ n - T.length b `mod` max 1 n) " ") z -- | The plain text contents of the zipper value :: TextZipper -> Text@@ -192,186 +193,319 @@ data Span tag = Span tag Text deriving (Show) +-- | Text alignment type+data TextAlignment =+ TextAlignment_Left+ | TextAlignment_Right+ | TextAlignment_Center+ deriving (Eq, Show)++-- A map from the index (row) of display line to (fst,snd)+-- fst: leading empty spaces from left (may be negative) to adjust for alignment+-- snd: the text offset from the beginning of the document+-- to the first character of the display line+type OffsetMapWithAlignment = Map Int (Int, Int)++-- helper type representing a single visual line that may be part of a wrapped logical line+data WrappedLine = WrappedLine+ { _wrappedLines_text :: Text+ , _wrappedLines_hiddenWhitespace :: Bool -- ^ 'True' if this line ends with a deleted whitespace character+ , _wrappedLines_offset :: Int -- ^ offset from beginning of line+ }+ deriving (Eq, Show)+ -- | Information about the document as it is displayed (i.e., post-wrapping) data DisplayLines tag = DisplayLines { _displayLines_spans :: [[Span tag]]- , _displayLines_offsetMap :: Map Int Int- , _displayLines_cursorY :: Int+ , _displayLines_offsetMap :: OffsetMapWithAlignment+ , _displayLines_cursorPos :: (Int, Int) -- cursor position relative to upper left hand corner } deriving (Show) +-- | Split a 'Text' at the given column index. For example+--+-- > splitAtWidth 3 "ᄀabc" == ("ᄀa", "bc")+--+-- because the first character has a width of two (see 'charWidth' for more on that).+splitAtWidth :: Int -> Text -> (Text, Text)+splitAtWidth n t@(Text arr off len)+ | n <= 0 = (T.empty, t)+ | n >= textWidth t = (t, T.empty)+ | otherwise = let k = toLogicalIndex n t+ in (text arr off k, text arr (off+k) (len-k))++toLogicalIndex :: Int -> Text -> Int+toLogicalIndex n' t'@(Text _ _ len') = loop 0 0+ where loop !i !cnt+ | i >= len' || cnt + w > n' = i+ | otherwise = loop (i+d) (cnt + w)+ where Iter c d = iter t' i+ w = charWidth c++-- | Takes the given number of columns of characters. For example+--+-- > takeWidth 3 "ᄀabc" == "ᄀa"+--+-- because the first character has a width of 2 (see 'charWidth' for more on that).+-- This function will not take a character if its width exceeds the width it seeks to take.+takeWidth :: Int -> Text -> Text+takeWidth n = fst . splitAtWidth n++-- | Drops the given number of columns of characters. For example+--+-- > dropWidth 2 "ᄀabc" == "abc"+--+-- because the first character has a width of 2 (see 'charWidth' for more on that).+-- This function will not drop a character if its width exceeds the width it seeks to drop.+dropWidth :: Int -> Text -> Text+dropWidth n = snd . splitAtWidth n++-- | Get the display width of a 'Char'. "Full width" and "wide" characters+-- take two columns and everything else takes a single column. See+-- <https://www.unicode.org/reports/tr11/> for more information+-- This is implemented using wcwidth from Vty such that it matches what will+-- be displayed on the terminal. Note that this method can change depending+-- on how vty is configed. Please see vty documentation for details.+charWidth :: Char -> Int+charWidth = wcwidth++-- | Get the width of the text in a set of 'Span's, taking into account unicode character widths+spansWidth :: [Span tag] -> Int+spansWidth = sum . map (\(Span _ t) -> textWidth t)++-- | Get the length (number of characters) of the text in a set of 'Span's+spansLength :: [Span tag] -> Int+spansLength = sum . map (\(Span _ t) -> T.length t)++-- | Compute the width of some 'Text', taking into account fullwidth+-- unicode forms.+textWidth :: Text -> Int+textWidth t = widthI (stream t)++-- | Compute the width of a stream of characters, taking into account+-- fullwidth unicode forms.+widthI :: Stream Char -> Int+widthI (Stream next s0 _len) = loop_length 0 s0+ where+ loop_length !z s = case next s of+ Done -> z+ Skip s' -> loop_length z s'+ Yield c s' -> loop_length (z + charWidth c) s'+{-# INLINE[0] widthI #-}++-- | Compute the logical index position of a stream of characters from a visual+-- position taking into account fullwidth unicode forms.+charIndexAt :: Int -> Stream Char -> Int+charIndexAt pos (Stream next s0 _len) = loop_length 0 0 s0+ where+ loop_length i !z s = case next s of+ Done -> i+ Skip s' -> loop_length i z s'+ Yield c s' -> if w > pos then i else loop_length (i+1) w s' where+ w = z + charWidth c+{-# INLINE[0] charIndexAt #-}+++++-- | Same as T.words except whitespace characters are included at end (i.e. ["line1 ", ...])+-- 'Char's representing white space.+wordsWithWhitespace :: Text -> [Text]+wordsWithWhitespace t@(Text arr off len) = loop 0 0 False+ where+ loop !start !n !wasSpace+ | n >= len = [Text arr (start+off) (n-start) | not (start == n)]+ | isSpace c = loop start (n+d) True+ | wasSpace = Text arr (start+off) (n-start) : loop n n False+ | otherwise = loop start (n+d) False+ where Iter c d = iter t n+{-# INLINE wordsWithWhitespace #-}++-- | Split words into logical lines, 'True' in the tuple indicates line ends with a whitespace character that got deleted+splitWordsAtDisplayWidth :: Int -> [Text] -> [(Text, Bool)]+splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 [] where+ appendOut :: [(Text,Bool)] -> Text -> Bool -> [(Text,Bool)]+ appendOut [] t b = [(t,b)]+ appendOut ((t',_):ts') t b = (t'<>t,b) : ts'++ -- remove the last whitespace in output+ modifyOutForNewLine :: [(Text,Bool)] -> [(Text,Bool)]+ modifyOutForNewLine [] = error "should never happen"+ modifyOutForNewLine ((t',_):ts) = case T.unsnoc t' of+ Nothing -> error "should never happen"+ Just (t,lastChar) -> assert (isSpace lastChar) $ (t,True):ts -- assume last char is whitespace++ loop :: [Text] -> Int -> [(Text,Bool)] -> [(Text,Bool)]+ loop [] _ out = out+ loop (x:xs) cumw out = r where+ newWidth = textWidth x + cumw+ r = if newWidth > maxWidth+ then if isSpace $ T.index x (toLogicalIndex (maxWidth - cumw) x)+ -- if line runs over but character of splitting is whitespace then split on the whitespace+ then let (t1,t2) = splitAtWidth (maxWidth - cumw) x+ in loop (T.drop 1 t2:xs) 0 [] <> appendOut out t1 True+ else if cumw == 0+ -- single word exceeds max width, so just split on the word+ then let (t1,t2) = splitAtWidth (maxWidth - cumw) x+ in loop (t2:xs) 0 [] <> appendOut out t1 False+ -- otherwise start a new line+ else loop (x:xs) 0 [] <> modifyOutForNewLine out+ else loop xs newWidth $ appendOut out x False++++-- | Wraps a logical line of text to fit within the given width. The first+-- wrapped line is offset by the number of columns provided. Subsequent wrapped+-- lines are not.+wrapWithOffsetAndAlignment+ :: TextAlignment+ -> Int -- ^ Maximum width+ -> Int -- ^ Offset for first line+ -> Text -- ^ Text to be wrapped+ -> [WrappedLine] -- (words on that line, hidden space char, offset from beginning of line)+wrapWithOffsetAndAlignment _ maxWidth _ _ | maxWidth <= 0 = []+wrapWithOffsetAndAlignment alignment maxWidth n txt = assert (n <= maxWidth) r where+ -- we pad by offset amount with any non-space character which we will remove later so that no changes need to be made to splitWordsAtDisplayWidth+ r' = splitWordsAtDisplayWidth maxWidth $ wordsWithWhitespace ( T.replicate n "." <> txt)+ fmapfn (t,b) = case alignment of+ TextAlignment_Left -> WrappedLine t b 0+ TextAlignment_Right -> WrappedLine t b (maxWidth-l)+ TextAlignment_Center -> WrappedLine t b ((maxWidth-l) `div` 2)+ where l = textWidth t+ r'' = case r' of+ [] -> []+ (x,b):xs -> (T.drop n x,b):xs+ r = fmap fmapfn r''++-- converts deleted eol spaces into logical lines+eolSpacesToLogicalLines :: [[WrappedLine]] -> [[(Text, Int)]]+eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a,c))) . concatMap (L.groupBy (\(WrappedLine _ b _) _ -> not b))++offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment+offsetMapWithAlignmentInternal = offsetMapWithAlignment . eolSpacesToLogicalLines++offsetMapWithAlignment+ :: [[(Text, Int)]] -- ^ The outer list represents logical lines, inner list represents wrapped lines+ -> OffsetMapWithAlignment+offsetMapWithAlignment ts = evalState (offsetMap' ts) (0, 0)+ where+ offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do+ maps <- forM x $ \(line,align) -> do+ let l = T.length line+ (dl, o) <- get+ put (dl + 1, o + l)+ return $ Map.singleton dl (align, o)+ (dl, o) <- get+ put (dl, o + 1)+ -- add additional offset to last line in wrapped lines (for newline char)+ return $ Map.adjust (\(align,_)->(align,o+1)) dl $ Map.unions maps++ -- | Given a width and a 'TextZipper', produce a list of display lines -- (i.e., lines of wrapped text) with special attributes applied to -- certain segments (e.g., the cursor). Additionally, produce the current -- y-coordinate of the cursor and a mapping from display line number to text -- offset-displayLines- :: Int -- ^ Width, used for wrapping+displayLinesWithAlignment+ :: TextAlignment+ -> Int -- ^ Width, used for wrapping -> tag -- ^ Metadata for normal characters -> tag -- ^ Metadata for the cursor -> TextZipper -- ^ The text input contents and cursor state -> DisplayLines tag-displayLines width tag cursorTag (TextZipper lb b a la) =- let linesBefore :: [[Text]] -- The wrapped lines before the cursor line- linesBefore = map (wrapWithOffset width 0) $ reverse lb- linesAfter :: [[Text]] -- The wrapped lines after the cursor line- linesAfter = map (wrapWithOffset width 0) la- offsets :: Map Int Int- offsets = offsetMap $ mconcat+displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =+ let linesBefore :: [[WrappedLine]] -- The wrapped lines before the cursor line+ linesBefore = map (wrapWithOffsetAndAlignment alignment width 0) $ reverse lb+ linesAfter :: [[WrappedLine]] -- The wrapped lines after the cursor line+ linesAfter = map (wrapWithOffsetAndAlignment alignment width 0) la++ -- simulate trailing cursor character when computing OffsetMap+ afterWithCursor = if T.null a then " " else a+ offsets :: OffsetMapWithAlignment+ offsets = offsetMapWithAlignmentInternal $ mconcat [ linesBefore- , [wrapWithOffset width 0 $ b <> a]+ , [wrapWithOffsetAndAlignment alignment width 0 $ b <> afterWithCursor] , linesAfter ]- spansBefore = map ((:[]) . Span tag) $ concat linesBefore- spansAfter = map ((:[]) . Span tag) $ concat linesAfter+ flattenLines = concatMap (fmap _wrappedLines_text)+ spansBefore = map ((:[]) . Span tag) $ flattenLines linesBefore+ spansAfter = map ((:[]) . Span tag) $ flattenLines linesAfter -- Separate the spans before the cursor into -- * spans that are on earlier display lines (though on the same logical line), and -- * spans that are on the same display line+ (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $- initLast $ map ((:[]) . Span tag) (wrapWithOffset width 0 b)+ initLast $ map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width 0 b) -- Calculate the number of columns on the cursor's display line before the cursor curLineOffset = spansWidth spansCurLineBefore -- Check whether the spans on the current display line are long enough that -- the cursor has to go to the next line cursorAfterEOL = curLineOffset == width cursorCharWidth = case T.uncons a of- Nothing -> 1+ Nothing -> 1 Just (c, _) -> charWidth c+ -- Separate the span after the cursor into -- * spans that are on the same display line, and -- * spans that are on later display lines (though on the same logical line)+ (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $ headTail $ case T.uncons a of Nothing -> [[Span cursorTag " "]] Just (c, rest) -> let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth cursor = Span cursorTag (T.singleton c)- in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of- [] -> [[cursor]]+ in case map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width o rest) of+ [] -> [[cursor]] (l:ls) -> (cursor : l) : ls++ curLineSpanNormalCase = if cursorAfterEOL+ then [ spansCurLineBefore, spansCurLineAfter ]+ else [ spansCurLineBefore <> spansCurLineAfter ]++ -- for right alignment, we want draw the cursor tag to be on the character just before the logical cursor position+ curLineSpan = if alignment == TextAlignment_Right && not cursorAfterEOL+ then case reverse spansCurLineBefore of+ [] -> curLineSpanNormalCase+ (Span _ x):xs -> case spansCurLineAfter of+ [] -> error "should not be possible" -- curLineSpanNormalCase+ (Span _ y):ys -> [reverse (Span cursorTag x:xs) <> ((Span tag y):ys)]+ else curLineSpanNormalCase++ cursorY = sum+ [ length spansBefore+ , length spansCurrentBefore+ , if cursorAfterEOL then 1 else 0+ ]+ -- a little silly to convert back to text but whatever, it works+ cursorX = if cursorAfterEOL then 0 else textWidth (mconcat $ fmap (\(Span _ t) -> t) spansCurLineBefore)+ in DisplayLines { _displayLines_spans = concat [ spansBefore , spansCurrentBefore- , if cursorAfterEOL- then [ spansCurLineBefore, spansCurLineAfter ]- else [ spansCurLineBefore <> spansCurLineAfter ]+ , curLineSpan , spansCurrentAfter , spansAfter ] , _displayLines_offsetMap = offsets- , _displayLines_cursorY = sum- [ length spansBefore- , length spansCurrentBefore- , if cursorAfterEOL then cursorCharWidth else 0- ]+ , _displayLines_cursorPos = (cursorX, cursorY) } where initLast :: [a] -> Maybe ([a], a) initLast = \case [] -> Nothing (x:xs) -> case initLast xs of- Nothing -> Just ([], x)+ Nothing -> Just ([], x) Just (ys, y) -> Just (x:ys, y) headTail :: [a] -> Maybe (a, [a]) headTail = \case [] -> Nothing x:xs -> Just (x, xs) --- | Wraps a logical line of text to fit within the given width. The first--- wrapped line is offset by the number of columns provided. Subsequent wrapped--- lines are not.-wrapWithOffset- :: Int -- ^ Maximum width- -> Int -- ^ Offset for first line- -> Text -- ^ Text to be wrapped- -> [Text]-wrapWithOffset maxWidth _ _ | maxWidth <= 0 = []-wrapWithOffset maxWidth n xs =- let (firstLine, rest) = splitAtWidth (maxWidth - n) xs- in firstLine : (fmap (takeWidth maxWidth) . takeWhile (not . T.null) . iterate (dropWidth maxWidth) $ rest) --- | Split a 'Text' at the given column index. For example------ > splitAtWidth 3 "ᄀabc" == ("ᄀa", "bc")------ because the first character has a width of two (see 'charWidth' for more on that).-splitAtWidth :: Int -> Text -> (Text, Text)-splitAtWidth n t@(Text arr off len)- | n <= 0 = (T.empty, t)- | n >= textWidth t = (t, T.empty)- | otherwise = let k = iterNWidth n t- in (text arr off k, text arr (off+k) (len-k))- where- iterNWidth :: Int -> Text -> Int- iterNWidth n' t'@(Text _ _ len') = loop 0 0- where loop !i !cnt- | i >= len' || cnt + w > n' = i- | otherwise = loop (i+d) (cnt + w)- where Iter c d = iter t' i- w = charWidth c---- | Takes the given number of columns of characters. For example------ > takeWidth 3 "ᄀabc" == "ᄀa"------ because the first character has a width of 2 (see 'charWidth' for more on that).--- This function will not take a character if its width exceeds the width it seeks to take.-takeWidth :: Int -> Text -> Text-takeWidth n = fst . splitAtWidth n---- | Drops the given number of columns of characters. For example------ > dropWidth 2 "ᄀabc" == "abc"------ because the first character has a width of 2 (see 'charWidth' for more on that).--- This function will not drop a character if its width exceeds the width it seeks to drop.-dropWidth :: Int -> Text -> Text-dropWidth n = snd . splitAtWidth n---- | Get the display width of a 'Char'. "Full width" and "wide" characters--- take two columns and everything else takes a single column. See--- <https://www.unicode.org/reports/tr11/> for more information.-charWidth :: Char -> Int-charWidth c = case property EastAsianWidth c of- EAFull -> 2- EAWide -> 2- _ -> 1---- | For a given set of wrapped logical lines, computes a map--- from display line index to text offset in the original text.--- This is used to help determine how interactions with the displayed--- text map back to the original text.--- For example, given the document @\"AA\\nBBB\\nCCCCCCCC\\n\"@ wrapped to 5 columns,--- this function will compute the offset in the original document of each character--- in column 1:------ > AA... (0, 0)--- > BBB.. (1, 3)--- > CCCCC (2, 7) -- (this line wraps to the next row)--- > CCC.. (3, 12)--- > ..... (4, 16)-offsetMap- :: [[Text]] -- ^ The outer list represents logical lines, and the- -- inner list represents the display lines into which- -- the logical line has been wrapped- -> Map Int Int -- ^ A map from the index (row) of display line to- -- the text offset from the beginning of the document- -- to the first character of the display line-offsetMap ts = evalState (offsetMap' ts) (0, 0)- where- offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do- maps <- forM x $ \line -> do- let l = T.length line- (dl, o) <- get- put (dl + 1, o + l)- return $ Map.singleton dl o- (dl, o) <- get- put (dl, o + 1)- return $ Map.insert dl (o + 1) $ Map.unions maps- -- | Move the cursor of the given 'TextZipper' to the logical position indicated--- by the given display line coordinates, using the provided 'DisplayLines'+-- by the given display line coordinates, using the provided 'DisplayLinesWithAlignment' -- information. If the x coordinate is beyond the end of a line, the cursor is -- moved to the end of the line. goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper@@ -379,32 +513,33 @@ let offset = Map.lookup y $ _displayLines_offsetMap dl in case offset of Nothing -> tz- Just o ->- let displayLineLength = case drop y $ _displayLines_spans dl of- [] -> x- (s:_) -> spansWidth s- in rightN (o + min displayLineLength x) $ top tz---- | Get the width of the text in a set of 'Span's, taking into account unicode character widths-spansWidth :: [Span tag] -> Int-spansWidth = sum . map (\(Span _ t) -> textWidth t)---- | Get the length (number of characters) of the text in a set of 'Span's-spansLength :: [Span tag] -> Int-spansLength = sum . map (\(Span _ t) -> T.length t)+ Just (alignOff,o) ->+ let+ trueX = max 0 (x - alignOff)+ moveRight = case drop y $ _displayLines_spans dl of+ [] -> 0+ (s:_) -> charIndexAt trueX . stream . mconcat . fmap (\(Span _ t) -> t) $ s+ in rightN (o + moveRight) $ top tz --- | Compute the width of some 'Text', taking into account fullwidth--- unicode forms.-textWidth :: Text -> Int-textWidth t = widthI (stream t)+-- | Given a width and a 'TextZipper', produce a list of display lines+-- (i.e., lines of wrapped text) with special attributes applied to+-- certain segments (e.g., the cursor). Additionally, produce the current+-- y-coordinate of the cursor and a mapping from display line number to text+-- offset+displayLines+ :: Int -- ^ Width, used for wrapping+ -> tag -- ^ Metadata for normal characters+ -> tag -- ^ Metadata for the cursor+ -> TextZipper -- ^ The text input contents and cursor state+ -> DisplayLines tag+displayLines = displayLinesWithAlignment TextAlignment_Left --- | Compute the width of a stream of characters, taking into account--- fullwidth unicode forms.-widthI :: Stream Char -> Int-widthI (Stream next s0 _len) = loop_length 0 s0- where- loop_length !z s = case next s of- Done -> z- Skip s' -> loop_length z s'- Yield c s' -> loop_length (z + charWidth c) s'-{-# INLINE[0] widthI #-}+-- | Wraps a logical line of text to fit within the given width. The first+-- wrapped line is offset by the number of columns provided. Subsequent wrapped+-- lines are not.+wrapWithOffset+ :: Int -- ^ Maximum width+ -> Int -- ^ Offset for first line+ -> Text -- ^ Text to be wrapped+ -> [Text]+wrapWithOffset maxWidth n xs = _wrappedLines_text <$> wrapWithOffsetAndAlignment TextAlignment_Left maxWidth n xs
− src/Reflex/Class/Switchable.hs
@@ -1,29 +0,0 @@-{-|-Module: Reflex.Class.Switchable-Description: A class for things that can be switched on the firing of an event--}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}-module Reflex.Class.Switchable where--import Control.Monad-import Reflex---- | Class representing things that can be switched when the provided event occurs-class Reflex t => Switchable t w | w -> t where- switching :: MonadHold t m => w -> Event t w -> m w--instance Reflex t => Switchable t (Event t a) where- switching = switchHold--instance Reflex t => Switchable t (Dynamic t a) where- switching a e = fmap join $ holdDyn a e--instance Reflex t => Switchable t (Behavior t a) where- switching = switcher--instance (Reflex t, Switchable t a, Switchable t b) => Switchable t (a, b) where- switching (a, b) e = (,)- <$> switching a (fmap fst e)- <*> switching b (fmap snd e)
src/Reflex/Spider/Orphans.hs view
@@ -2,9 +2,6 @@ Module: Reflex.Spider.Orphans Description: Orphan instances for SpiderTimeline and SpiderHost -}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Reflex.Spider.Orphans where
src/Reflex/Vty.hs view
@@ -14,15 +14,21 @@ ( module Reflex , module Reflex.Vty.Host , module Reflex.Vty.Widget+ , module Reflex.Vty.Widget.Box , module Reflex.Vty.Widget.Input , module Reflex.Vty.Widget.Layout+ , module Reflex.Vty.Widget.Split+ , module Reflex.Vty.Widget.Text , module Control.Monad.NodeId ) where import Reflex import Reflex.Vty.Host import Reflex.Vty.Widget+import Reflex.Vty.Widget.Box import Reflex.Vty.Widget.Input import Reflex.Vty.Widget.Layout+import Reflex.Vty.Widget.Split+import Reflex.Vty.Widget.Text import Control.Monad.NodeId
src/Reflex/Vty/Host.hs view
@@ -2,12 +2,6 @@ Module: Reflex.Vty.Host Description: Scaffolding for running a reflex-vty application -}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}- module Reflex.Vty.Host ( VtyApp , VtyResult(..)@@ -202,7 +196,6 @@ updateVty loop where- -- TODO Some part of this is probably general enough to belong in reflex -- | Use the given 'FireCommand' to fire events that have subscribers -- and call the callback for the 'TriggerInvocation' of each. fireEventTriggerRefs
src/Reflex/Vty/Widget.hs view
@@ -2,739 +2,560 @@ Module: Reflex.Vty.Widget Description: Basic set of widgets and building blocks for reflex-vty applications -}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Reflex.Vty.Widget- ( VtyWidgetCtx(..)- , VtyWidget(..)- , VtyWidgetOut(..)- , ImageWriter(..)- , runVtyWidget- , mainWidget- , mainWidgetWithHandle- , HasDisplaySize(..)- , HasFocus(..)- , HasVtyInput(..)- , DynRegion(..)- , currentRegion- , Region(..)- , regionSize- , regionBlankImage- , Drag(..)- , drag- , MouseDown(..)- , MouseUp(..)- , mouseDown- , mouseUp- , ScrollDirection(..)- , mouseScroll- , pane- , splitV- , splitH- , splitVDrag- , boxTitle- , box- , boxStatic- , RichTextConfig(..)- , richText- , text- , scrollableText- , display- , BoxStyle(..)- , hyphenBoxStyle- , singleBoxStyle- , roundedBoxStyle- , thickBoxStyle- , doubleBoxStyle- , fill- , hRule- , KeyCombo- , key- , keys- , keyCombo- , keyCombos- , blank- ) where--import Control.Applicative (liftA2)-import Control.Monad.Fix (MonadFix)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Reader (ReaderT, ask, asks, runReaderT)-import Control.Monad.Trans (MonadTrans, lift)-import Data.Default (Default(..))-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Zipper as TZ-import Graphics.Vty (Image)-import qualified Graphics.Vty as V-import Reflex-import Reflex.Class ()-import Reflex.Host.Class (MonadReflexCreateTrigger)--import Reflex.Vty.Host--import Control.Monad.NodeId---- | The context within which a 'VtyWidget' runs-data VtyWidgetCtx t = VtyWidgetCtx- { _vtyWidgetCtx_width :: Dynamic t Int- -- ^ The width of the region allocated to the widget.- , _vtyWidgetCtx_height :: Dynamic t Int- -- ^ The height of the region allocated to the widget.- , _vtyWidgetCtx_focus :: Dynamic t Bool- -- ^ Whether the widget should behave as if it has focus for keyboard input.- , _vtyWidgetCtx_input :: Event t VtyEvent- -- ^ User input events that the widget's parent chooses to share. These will generally- -- be filtered for relevance:- -- * Keyboard inputs are restricted to focused widgets- -- * Mouse inputs are restricted to the region in which the widget resides and are- -- translated into its internal coordinates.- }---- | The output of a 'VtyWidget'-data VtyWidgetOut t = VtyWidgetOut- { _vtyWidgetOut_shutdown :: Event t ()- }--instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (VtyWidget t m) where- runWithReplace a0 a' = VtyWidget $ runWithReplace (unVtyWidget a0) $ fmap unVtyWidget a'- traverseIntMapWithKeyWithAdjust f dm0 dm' = VtyWidget $- traverseIntMapWithKeyWithAdjust (\k v -> unVtyWidget (f k v)) dm0 dm'- traverseDMapWithKeyWithAdjust f dm0 dm' = VtyWidget $ do- traverseDMapWithKeyWithAdjust (\k v -> unVtyWidget (f k v)) dm0 dm'- traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = VtyWidget $ do- traverseDMapWithKeyWithAdjustWithMove (\k v -> unVtyWidget (f k v)) dm0 dm'---- | A widget that can read its context and produce image output-newtype VtyWidget t m a = VtyWidget- { unVtyWidget :: BehaviorWriterT t [Image] (ReaderT (VtyWidgetCtx t) m) a- } deriving- ( Functor- , Applicative- , Monad- , MonadSample t- , MonadHold t- , MonadFix- , NotReady t- , ImageWriter t- , PostBuild t- , TriggerEvent t- , MonadReflexCreateTrigger t- , MonadIO- )--deriving instance PerformEvent t m => PerformEvent t (VtyWidget t m)-instance MonadTrans (VtyWidget t) where- lift f = VtyWidget $ lift $ lift f--instance MonadNodeId m => MonadNodeId (VtyWidget t m) where- getNextNodeId = VtyWidget $ do- lift $ lift getNextNodeId---- | Runs a 'VtyWidget' with a given context-runVtyWidget- :: (Reflex t, MonadNodeId m)- => VtyWidgetCtx t- -> VtyWidget t m a- -> m (a, Behavior t [Image])-runVtyWidget ctx w = runReaderT (runBehaviorWriterT (unVtyWidget w)) ctx---- | Sets up the top-level context for a 'VtyWidget' and runs it with that context-mainWidgetWithHandle- :: V.Vty- -> (forall t m. (MonadVtyApp t m, MonadNodeId m) => VtyWidget t m (Event t ()))- -> IO ()-mainWidgetWithHandle vty child =- runVtyAppWithHandle vty $ \dr0 inp -> do- size <- holdDyn dr0 $ fforMaybe inp $ \case- V.EvResize w h -> Just (w, h)- _ -> Nothing- let inp' = fforMaybe inp $ \case- V.EvResize {} -> Nothing- x -> Just x- let ctx = VtyWidgetCtx- { _vtyWidgetCtx_width = fmap fst size- , _vtyWidgetCtx_height = fmap snd size- , _vtyWidgetCtx_input = inp'- , _vtyWidgetCtx_focus = constDyn True- }- (shutdown, images) <- runNodeIdT $ runVtyWidget ctx $ do- tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]- child- return $ VtyResult- { _vtyResult_picture = fmap (V.picForLayers . reverse) images- , _vtyResult_shutdown = shutdown- }---- | Like 'mainWidgetWithHandle', but uses a default vty configuration-mainWidget- :: (forall t m. (MonadVtyApp t m, MonadNodeId m) => VtyWidget t m (Event t ()))- -> IO ()-mainWidget child = do- vty <- getDefaultVty- mainWidgetWithHandle vty child---- | A class for things that know their own display size dimensions-class (Reflex t, Monad m) => HasDisplaySize t m | m -> t where- -- | Retrieve the display width (columns)- displayWidth :: m (Dynamic t Int)- default displayWidth :: (f m' ~ m, MonadTrans f, HasDisplaySize t m') => m (Dynamic t Int)- displayWidth = lift displayWidth- -- | Retrieve the display height (rows)- displayHeight :: m (Dynamic t Int)- default displayHeight :: (f m' ~ m, MonadTrans f, HasDisplaySize t m') => m (Dynamic t Int)- displayHeight = lift displayHeight--instance (Reflex t, Monad m) => HasDisplaySize t (VtyWidget t m) where- displayWidth = VtyWidget . lift $ asks _vtyWidgetCtx_width- displayHeight = VtyWidget . lift $ asks _vtyWidgetCtx_height--instance HasDisplaySize t m => HasDisplaySize t (ReaderT x m)-instance HasDisplaySize t m => HasDisplaySize t (BehaviorWriterT t x m)-instance HasDisplaySize t m => HasDisplaySize t (DynamicWriterT t x m)-instance HasDisplaySize t m => HasDisplaySize t (EventWriterT t x m)--instance HasDisplaySize t m => HasDisplaySize t (NodeIdT m)---- | A class for things that can receive vty events as input-class HasVtyInput t m | m -> t where- input :: m (Event t VtyEvent)--instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where- input = VtyWidget . lift $ asks _vtyWidgetCtx_input---- | A class for things that can dynamically gain and lose focus-class HasFocus t m | m -> t where- focus :: m (Dynamic t Bool)--instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where- focus = VtyWidget . lift $ asks _vtyWidgetCtx_focus---- | A class for widgets that can produce images to draw to the display-class (Reflex t, Monad m) => ImageWriter t m | m -> t where- -- | Send images upstream for rendering- tellImages :: Behavior t [Image] -> m ()--instance (Monad m, Reflex t) => ImageWriter t (BehaviorWriterT t [Image] m) where- tellImages = tellBehavior---- | A chunk of the display area-data Region = Region- { _region_left :: Int- , _region_top :: Int- , _region_width :: Int- , _region_height :: Int- }- deriving (Show, Read, Eq, Ord)---- | A dynamic chunk of the display area-data DynRegion t = DynRegion- { _dynRegion_left :: Dynamic t Int- , _dynRegion_top :: Dynamic t Int- , _dynRegion_width :: Dynamic t Int- , _dynRegion_height :: Dynamic t Int- }---- | The width and height of a 'Region'-regionSize :: Region -> (Int, Int)-regionSize (Region _ _ w h) = (w, h)---- | Produces an 'Image' that fills a region with space characters-regionBlankImage :: Region -> Image-regionBlankImage r@(Region _ _ width height) =- withinImage r $ V.charFill V.defAttr ' ' width height---- | A behavior of the current display area represented by a 'DynRegion'-currentRegion :: Reflex t => DynRegion t -> Behavior t Region-currentRegion (DynRegion l t w h) = Region <$> current l <*> current t <*> current w <*> current h---- | Translates and crops an 'Image' so that it is contained by--- the given 'Region'.-withinImage- :: Region- -> Image- -> Image-withinImage (Region left top width height)- | width < 0 || height < 0 = withinImage (Region left top 0 0)- | otherwise = V.translate left top . V.crop width height---- | Low-level widget combinator that runs a child 'VtyWidget' within--- a given region and context. This widget filters and modifies the input--- that the child widget receives such that:--- * unfocused widgets receive no key events--- * mouse inputs outside the region are ignored--- * mouse inputs inside the region have their coordinates translated such--- that (0,0) is the top-left corner of the region-pane- :: (Reflex t, Monad m, MonadNodeId m)- => DynRegion t- -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.- -> VtyWidget t m a- -> VtyWidget t m a-pane dr foc child = VtyWidget $ do- ctx <- lift ask- let reg = currentRegion dr- let ctx' = VtyWidgetCtx- { _vtyWidgetCtx_input = leftmost -- TODO: think about this leftmost more.- [ fmapMaybe id $- attachWith (\(r,f) e -> filterInput r f e)- (liftA2 (,) reg (current foc))- (_vtyWidgetCtx_input ctx)- ]- , _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc- , _vtyWidgetCtx_width = _dynRegion_width dr- , _vtyWidgetCtx_height = _dynRegion_height dr- }- (result, images) <- lift . lift $ runVtyWidget ctx' child- let images' = liftA2 (\r is -> map (withinImage r) is) reg images- tellImages images'- return result- where- filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent- filterInput (Region l t w h) focused e = case e of- V.EvKey _ _ | not focused -> Nothing- V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y- V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y- _ -> Just e- where- mouse con x y- | or [ x < l- , y < t- , x >= l + w- , y >= t + h ] = Nothing- | otherwise =- Just (con (x - l) (y - t))---- | Information about a drag operation-data Drag = Drag- { _drag_from :: (Int, Int) -- ^ Where the drag began- , _drag_to :: (Int, Int) -- ^ Where the mouse currently is- , _drag_button :: V.Button -- ^ Which mouse button is dragging- , _drag_modifiers :: [V.Modifier] -- ^ What modifiers are held- , _drag_end :: Bool -- ^ Whether the drag ended (the mouse button was released)- }- deriving (Eq, Ord, Show)---- | Converts raw vty mouse drag events into an event stream of 'Drag's-drag- :: (Reflex t, MonadFix m, MonadHold t m)- => V.Button- -> VtyWidget t m (Event t Drag)-drag btn = do- inp <- input- let f :: Maybe Drag -> V.Event -> Maybe Drag- f Nothing = \case- V.EvMouseDown x y btn' mods- | btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods False- | otherwise -> Nothing- _ -> Nothing- f (Just (Drag from _ _ mods end)) = \case- V.EvMouseDown x y btn' mods'- | end && btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods' False- | btn == btn' -> Just $ Drag from (x,y) btn mods' False- | otherwise -> Nothing -- Ignore other buttons.- V.EvMouseUp x y (Just btn')- | end -> Nothing- | btn == btn' -> Just $ Drag from (x,y) btn mods True- | otherwise -> Nothing- V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button,- -- assume it's the right one.- | end -> Nothing- | otherwise -> Just $ Drag from (x,y) btn mods True- _ -> Nothing- rec let newDrag = attachWithMaybe f (current dragD) inp- dragD <- holdDyn Nothing $ Just <$> newDrag- return (fmapMaybe id $ updated dragD)---- | Mouse down events for a particular mouse button-mouseDown- :: (Reflex t, Monad m)- => V.Button- -> VtyWidget t m (Event t MouseDown)-mouseDown btn = do- i <- input- return $ fforMaybe i $ \case- V.EvMouseDown x y btn' mods -> if btn == btn'- then Just $ MouseDown btn' (x, y) mods- else Nothing- _ -> Nothing---- | Mouse up events for a particular mouse button-mouseUp- :: (Reflex t, Monad m)- => VtyWidget t m (Event t MouseUp)-mouseUp = do- i <- input- return $ fforMaybe i $ \case- V.EvMouseUp x y btn' -> Just $ MouseUp btn' (x, y)- _ -> Nothing---- | Information about a mouse down event-data MouseDown = MouseDown- { _mouseDown_button :: V.Button- , _mouseDown_coordinates :: (Int, Int)- , _mouseDown_modifiers :: [V.Modifier]- }- deriving (Eq, Ord, Show)---- | Information about a mouse up event-data MouseUp = MouseUp- { _mouseUp_button :: Maybe V.Button- , _mouseUp_coordinates :: (Int, Int)- }- deriving (Eq, Ord, Show)---- | Mouse scroll direction-data ScrollDirection = ScrollDirection_Up | ScrollDirection_Down- deriving (Eq, Ord, Show)---- | Produce an event that fires when the mouse wheel is scrolled-mouseScroll- :: (Reflex t, Monad m)- => VtyWidget t m (Event t ScrollDirection)-mouseScroll = do- up <- mouseDown V.BScrollUp- down <- mouseDown V.BScrollDown- return $ leftmost- [ ScrollDirection_Up <$ up- , ScrollDirection_Down <$ down- ]---- | Type synonym for a key and modifier combination-type KeyCombo = (V.Key, [V.Modifier])---- | Emits an event that fires on a particular key press (without modifiers)-key :: (Monad m, Reflex t) => V.Key -> VtyWidget t m (Event t KeyCombo)-key = keyCombos . Set.singleton . (,[])---- | Emits an event that fires on particular key presses (without modifiers)-keys :: (Monad m, Reflex t) => [V.Key] -> VtyWidget t m (Event t KeyCombo)-keys = keyCombos . Set.fromList . fmap (,[])---- | Emit an event that fires whenever the provided key combination occurs-keyCombo- :: (Reflex t, Monad m)- => KeyCombo- -> VtyWidget t m (Event t KeyCombo)-keyCombo = keyCombos . Set.singleton---- | Emit an event that fires whenever any of the provided key combinations occur-keyCombos- :: (Reflex t, Monad m)- => Set KeyCombo- -> VtyWidget t m (Event t KeyCombo)-keyCombos ks = do- i <- input- return $ fforMaybe i $ \case- V.EvKey k m -> if Set.member (k, m) ks- then Just (k, m)- else Nothing- _ -> Nothing---- | A plain split of the available space into vertically stacked panes.--- No visual separator is built in here.-splitV :: (Reflex t, Monad m, MonadNodeId m)- => Dynamic t (Int -> Int)- -- ^ Function used to determine size of first pane based on available size- -> Dynamic t (Bool, Bool)- -- ^ How to focus the two sub-panes, given that we are focused.- -> VtyWidget t m a- -- ^ Widget for first pane- -> VtyWidget t m b- -- ^ Widget for second pane- -> VtyWidget t m (a,b)-splitV sizeFunD focD wA wB = do- dw <- displayWidth- dh <- displayHeight- let regA = DynRegion- { _dynRegion_left = pure 0- , _dynRegion_top = pure 0- , _dynRegion_width = dw- , _dynRegion_height = sizeFunD <*> dh- }- regB = DynRegion- { _dynRegion_left = pure 0- , _dynRegion_top = _dynRegion_height regA- , _dynRegion_width = dw- , _dynRegion_height = liftA2 (-) dh (_dynRegion_height regA)- }- ra <- pane regA (fst <$> focD) wA- rb <- pane regB (snd <$> focD) wB- return (ra,rb)---- | A plain split of the available space into horizontally stacked panes.--- No visual separator is built in here.-splitH :: (Reflex t, Monad m, MonadNodeId m)- => Dynamic t (Int -> Int)- -- ^ Function used to determine size of first pane based on available size- -> Dynamic t (Bool, Bool)- -- ^ How to focus the two sub-panes, given that we are focused.- -> VtyWidget t m a- -- ^ Widget for first pane- -> VtyWidget t m b- -- ^ Widget for second pane- -> VtyWidget t m (a,b)-splitH sizeFunD focD wA wB = do- dw <- displayWidth- dh <- displayHeight- let regA = DynRegion- { _dynRegion_left = pure 0- , _dynRegion_top = pure 0- , _dynRegion_width = sizeFunD <*> dw- , _dynRegion_height = dh- }- regB = DynRegion- { _dynRegion_left = _dynRegion_width regA- , _dynRegion_top = pure 0- , _dynRegion_width = liftA2 (-) dw (_dynRegion_width regA)- , _dynRegion_height = dh- }- liftA2 (,) (pane regA (fmap fst focD) wA) (pane regB (fmap snd focD) wB)---- | A split of the available space into two parts with a draggable separator.--- Starts with half the space allocated to each, and the first pane has focus.--- Clicking in a pane switches focus.-splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m)- => VtyWidget t m ()- -> VtyWidget t m a- -> VtyWidget t m b- -> VtyWidget t m (a,b)-splitVDrag wS wA wB = do- dh <- displayHeight- dw <- displayWidth- h0 <- sample $ current dh -- TODO- dragE <- drag V.BLeft- let splitter0 = h0 `div` 2- rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter]- splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter]- splitterFrac <- holdDyn ((1::Double) / 2) $ ffor (attach (current dh) (fst <$> dragSplitter)) $ \(h, x) ->- fromIntegral x / max 1 (fromIntegral h)- let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $- \(splitterY, Drag (_, fromY) (_, toY) _ _ end) ->- if splitterY == fromY then Just (toY, end) else Nothing- regA = DynRegion 0 0 dw splitterPos- regS = DynRegion 0 splitterPos dw 1- regB = DynRegion 0 (splitterPos + 1) dw (dh - splitterPos - 1)- resizeSplitter = ffor (attach (current splitterFrac) (updated dh)) $- \(frac, h) -> round (frac * fromIntegral h)- focA <- holdDyn True $ leftmost- [ True <$ mA- , False <$ mB- ]- (mA, rA) <- pane regA focA $ withMouseDown wA- pane regS (pure False) wS- (mB, rB) <- pane regB (not <$> focA) $ withMouseDown wB- return (rA, rB)- where- withMouseDown x = do- m <- mouseDown V.BLeft- x' <- x- return (m, x')---- | Fill the background with a particular character.-fill :: (Reflex t, Monad m) => Char -> VtyWidget t m ()-fill c = do- dw <- displayWidth- dh <- displayHeight- let fillImg = current $ liftA2 (\w h -> [V.charFill V.defAttr c w h]) dw dh- tellImages fillImg---- | Fill the background with the bottom-hRule :: (Reflex t, Monad m) => BoxStyle -> VtyWidget t m ()-hRule boxStyle = fill (_boxStyle_s boxStyle)---- | Defines a set of symbols to use to draw the outlines of boxes--- C.f. https://en.wikipedia.org/wiki/Box-drawing_character-data BoxStyle = BoxStyle- { _boxStyle_nw :: Char- , _boxStyle_n :: Char- , _boxStyle_ne :: Char- , _boxStyle_e :: Char- , _boxStyle_se :: Char- , _boxStyle_s :: Char- , _boxStyle_sw :: Char- , _boxStyle_w :: Char- }--instance Default BoxStyle where- def = singleBoxStyle---- | A box style that uses hyphens and pipe characters. Doesn't handle--- corners very well.-hyphenBoxStyle :: BoxStyle-hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'---- | A single line box style-singleBoxStyle :: BoxStyle-singleBoxStyle = BoxStyle '┌' '─' '┐' '│' '┘' '─' '└' '│'---- | A thick single line box style-thickBoxStyle :: BoxStyle-thickBoxStyle = BoxStyle '┏' '━' '┓' '┃' '┛' '━' '┗' '┃'---- | A double line box style-doubleBoxStyle :: BoxStyle-doubleBoxStyle = BoxStyle '╔' '═' '╗' '║' '╝' '═' '╚' '║'---- | A single line box style with rounded corners-roundedBoxStyle :: BoxStyle-roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'---- | Draws a titled box in the provided style and a child widget inside of that box-boxTitle :: (Monad m, Reflex t, MonadNodeId m)- => Behavior t BoxStyle- -> Text- -> VtyWidget t m a- -> VtyWidget t m a-boxTitle boxStyle title child = do- dh <- displayHeight- dw <- displayWidth- let boxReg = DynRegion (pure 0) (pure 0) dw dh- innerReg = DynRegion (pure 1) (pure 1) (subtract 2 <$> dw) (subtract 2 <$> dh)- tellImages (boxImages <$> boxStyle <*> currentRegion boxReg)- tellImages (fmap (\r -> [regionBlankImage r]) (currentRegion innerReg))- pane innerReg (pure True) child- where- boxImages :: BoxStyle -> Region -> [Image]- boxImages style (Region left top width height) =- let right = left + width - 1- bottom = top + height - 1- sides =- [ withinImage (Region (left + 1) top (width - 2) 1) $- V.text' V.defAttr $- hPadText title (_boxStyle_n style) (width - 2)- , withinImage (Region right (top + 1) 1 (height - 2)) $- V.charFill V.defAttr (_boxStyle_e style) 1 (height - 2)- , withinImage (Region (left + 1) bottom (width - 2) 1) $- V.charFill V.defAttr (_boxStyle_s style) (width - 2) 1- , withinImage (Region left (top + 1) 1 (height - 2)) $- V.charFill V.defAttr (_boxStyle_w style) 1 (height - 2)- ]- corners =- [ withinImage (Region left top 1 1) $- V.char V.defAttr (_boxStyle_nw style)- , withinImage (Region right top 1 1) $- V.char V.defAttr (_boxStyle_ne style)- , withinImage (Region right bottom 1 1) $- V.char V.defAttr (_boxStyle_se style)- , withinImage (Region left bottom 1 1) $- V.char V.defAttr (_boxStyle_sw style)- ]- in sides ++ if width > 1 && height > 1 then corners else []- hPadText :: T.Text -> Char -> Int -> T.Text- hPadText t c l = if lt >= l- then t- else left <> t <> right- where- lt = T.length t- delta = l - lt- mkHalf n = T.replicate (n `div` 2) (T.singleton c)- left = mkHalf $ delta + 1- right = mkHalf delta---- | A box without a title-box :: (Monad m, Reflex t, MonadNodeId m)- => Behavior t BoxStyle- -> VtyWidget t m a- -> VtyWidget t m a-box boxStyle = boxTitle boxStyle mempty---- | A box whose style is static-boxStatic- :: (Reflex t, Monad m, MonadNodeId m)- => BoxStyle- -> VtyWidget t m a- -> VtyWidget t m a-boxStatic = box . pure---- | Configuration options for displaying "rich" text-data RichTextConfig t = RichTextConfig- { _richTextConfig_attributes :: Behavior t V.Attr- }--instance Reflex t => Default (RichTextConfig t) where- def = RichTextConfig $ pure V.defAttr---- | A widget that displays text with custom time-varying attributes-richText- :: (Reflex t, Monad m)- => RichTextConfig t- -> Behavior t Text- -> VtyWidget t m ()-richText cfg t = do- dw <- displayWidth- let img = (\w a s -> [wrapText w a s])- <$> current dw- <*> _richTextConfig_attributes cfg- <*> t- tellImages img- where- wrapText maxWidth attrs = V.vertCat- . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0)- . T.split (=='\n')---- | Renders text, wrapped to the container width-text- :: (Reflex t, Monad m)- => Behavior t Text- -> VtyWidget t m ()-text = richText def---- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those--- that are hidden)-scrollableText- :: forall t m. (Reflex t, MonadHold t m, MonadFix m)- => Event t Int- -- ^ Number of lines to scroll by- -> Behavior t Text- -> VtyWidget t m (Behavior t (Int, Int))- -- ^ (Current scroll position, total number of lines)-scrollableText scrollBy t = do- dw <- displayWidth- let imgs = wrap <$> current dw <*> t- kup <- key V.KUp- kdown <- key V.KDown- m <- mouseScroll- let requestedScroll :: Event t Int- requestedScroll = leftmost- [ 1 <$ kdown- , (-1) <$ kup- , ffor m $ \case- ScrollDirection_Up -> (-1)- ScrollDirection_Down -> 1- , scrollBy- ]- updateLine maxN delta ix = min (max 0 (ix + delta)) maxN- lineIndex :: Dynamic t Int <- foldDyn (\(maxN, delta) ix -> updateLine (maxN - 1) delta ix) 0 $- attach (length <$> imgs) requestedScroll- tellImages $ fmap ((:[]) . V.vertCat) $ drop <$> current lineIndex <*> imgs- return $ (,) <$> ((+) <$> current lineIndex <*> pure 1) <*> (length <$> imgs)- where- wrap maxWidth = concatMap (fmap (V.string V.defAttr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')---- | Renders any behavior whose value can be converted to--- 'String' as text-display- :: (Reflex t, Monad m, Show a)- => Behavior t a- -> VtyWidget t m ()-display a = text $ T.pack . show <$> a---- | A widget that draws nothing-blank :: Monad m => VtyWidget t m ()+{-# Language UndecidableInstances #-}++module Reflex.Vty.Widget where++import Control.Applicative (liftA2)+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Morph+import Control.Monad.NodeId+import Control.Monad.Reader (ReaderT, ask, local, runReaderT)+import Control.Monad.Ref+import Control.Monad.Trans (MonadTrans, lift)+import Data.Set (Set)+import qualified Data.Set as Set+import Graphics.Vty (Image)+import qualified Graphics.Vty as V+import Reflex+import Reflex.Class ()+import Reflex.Host.Class (MonadReflexCreateTrigger)+import Reflex.Vty.Host++-- * Running a vty application++-- | Sets up the top-level context for a vty widget and runs it with that context+mainWidgetWithHandle+ :: V.Vty+ -> (forall t m.+ ( MonadVtyApp t m+ , HasImageWriter t m+ , MonadNodeId m+ , HasDisplayRegion t m+ , HasFocusReader t m+ , HasInput t m+ , HasTheme t m+ ) => m (Event t ()))+ -> IO ()+mainWidgetWithHandle vty child =+ runVtyAppWithHandle vty $ \dr0 inp -> do+ size <- holdDyn dr0 $ fforMaybe inp $ \case+ V.EvResize w h -> Just (w, h)+ _ -> Nothing+ let inp' = fforMaybe inp $ \case+ V.EvResize {} -> Nothing+ x -> Just x+ (shutdown, images) <- runThemeReader (constant V.defAttr) $+ runFocusReader (pure True) $+ runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $+ runImageWriter $+ runNodeIdT $+ runInput inp' $ do+ tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]+ child+ return $ VtyResult+ { _vtyResult_picture = fmap (V.picForLayers . reverse) images+ , _vtyResult_shutdown = shutdown+ }++-- | The output of a vty widget+data VtyWidgetOut t = VtyWidgetOut+ { _vtyWidgetOut_shutdown :: Event t ()+ }++-- | Like 'mainWidgetWithHandle', but uses a default vty configuration+mainWidget+ :: (forall t m.+ ( MonadVtyApp t m+ , HasImageWriter t m+ , MonadNodeId m+ , HasDisplayRegion t m+ , HasFocusReader t m+ , HasTheme t m+ , HasInput t m+ ) => m (Event t ()))+ -> IO ()+mainWidget child = do+ vty <- getDefaultVty+ mainWidgetWithHandle vty child++-- * Input Events++-- | A class for things that can receive vty events as input+class HasInput t m | m -> t where+ input :: m (Event t VtyEvent)+ default input :: (f m' ~ m, Monad m', MonadTrans f, HasInput t m') => m (Event t VtyEvent)+ input = lift input+ -- | User input events that the widget's parent chooses to share. These will generally+ -- be filtered for relevance.+ localInput :: (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a+ default localInput :: (f m' ~ m, Monad m', MFunctor f, HasInput t m') => (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a+ localInput f = hoist (localInput f)++instance (Reflex t, Monad m) => HasInput t (Input t m) where+ input = Input ask+ localInput f (Input m) = Input $ local f m++-- | A widget that can receive input events. See 'Graphics.Vty.Event'+newtype Input t m a = Input+ { unInput :: ReaderT (Event t VtyEvent) m a+ } deriving+ ( Functor+ , Applicative+ , Monad+ , MonadSample t+ , MonadHold t+ , MonadFix+ , MonadIO+ , MonadRef+ )++instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (Input t m) where+ runWithReplace a0 a' = Input $ runWithReplace (unInput a0) $ fmap unInput a'+ traverseIntMapWithKeyWithAdjust f dm0 dm' = Input $+ traverseIntMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm'+ traverseDMapWithKeyWithAdjust f dm0 dm' = Input $ do+ traverseDMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm'+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = Input $ do+ traverseDMapWithKeyWithAdjustWithMove (\k v -> unInput (f k v)) dm0 dm'++deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Input t m)+deriving instance NotReady t m => NotReady t (Input t m)+deriving instance PerformEvent t m => PerformEvent t (Input t m)+deriving instance PostBuild t m => PostBuild t (Input t m)+deriving instance TriggerEvent t m => TriggerEvent t (Input t m)+instance HasImageWriter t m => HasImageWriter t (Input t m)+instance HasDisplayRegion t m => HasDisplayRegion t (Input t m)+instance HasFocusReader t m => HasFocusReader t (Input t m)++instance MonadTrans (Input t) where+ lift f = Input $ lift f++instance MFunctor (Input t) where+ hoist f = Input . hoist f . unInput++instance MonadNodeId m => MonadNodeId (Input t m)++-- | Runs an 'Input' with a given context+runInput+ :: Reflex t+ => Event t VtyEvent+ -> Input t m a+ -> m a+runInput e w = runReaderT (unInput w) e++-- ** Filtering input++-- | Type synonym for a key and modifier combination+type KeyCombo = (V.Key, [V.Modifier])++-- | Emits an event that fires on a particular key press (without modifiers)+key :: (Monad m, Reflex t, HasInput t m) => V.Key -> m (Event t KeyCombo)+key = keyCombos . Set.singleton . (,[])++-- | Emits an event that fires on particular key presses (without modifiers)+keys :: (Monad m, Reflex t, HasInput t m) => [V.Key] -> m (Event t KeyCombo)+keys = keyCombos . Set.fromList . fmap (,[])++-- | Emit an event that fires whenever the provided key combination occurs+keyCombo+ :: (Reflex t, Monad m, HasInput t m)+ => KeyCombo+ -> m (Event t KeyCombo)+keyCombo = keyCombos . Set.singleton++-- | Emit an event that fires whenever any of the provided key combinations occur+keyCombos+ :: (Reflex t, Monad m, HasInput t m)+ => Set KeyCombo+ -> m (Event t KeyCombo)+keyCombos ks = do+ i <- input+ return $ fforMaybe i $ \case+ V.EvKey k m -> if Set.member (k, m) ks+ then Just (k, m)+ else Nothing+ _ -> Nothing++-- | Filter the keyboard input that a child widget may receive+filterKeys :: (Reflex t, HasInput t m) => (KeyCombo -> Bool) -> m a -> m a+filterKeys f x = localInput (ffilter (\case+ V.EvKey k mods -> f (k, mods)+ _ -> True)) x++-- | Filter mouse input events based on whether they target a particular region+-- and translate them to the internal coordinate system of that region.+--+-- NB: Non-mouse events are passed through unfiltered and unchanged+mouseInRegion :: Region -> VtyEvent -> Maybe VtyEvent+mouseInRegion (Region l t w h) e = case e of+ V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y+ V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y+ _ -> Just e+ where+ mouse con x y+ | or [ x < l+ , y < t+ , x >= l + w+ , y >= t + h ] = Nothing+ | otherwise =+ Just (con (x - l) (y - t))++-- | Filter mouse input outside the current display region and+-- all input if the region is not focused+inputInFocusedRegion+ :: (HasDisplayRegion t m, HasFocusReader t m, HasInput t m)+ => m (Event t VtyEvent)+inputInFocusedRegion = do+ inp <- input+ reg <- current <$> askRegion+ foc <- current <$> focus+ pure $ fmapMaybe id $ attachWith filterInput ((,) <$> reg <*> foc) inp+ where+ filterInput (r, f) = \case+ V.EvKey {} | not f -> Nothing+ x -> mouseInRegion r x++-- * Getting and setting the display region++-- | A chunk of the display area+data Region = Region+ { _region_left :: Int+ , _region_top :: Int+ , _region_width :: Int+ , _region_height :: Int+ }+ deriving (Show, Read, Eq, Ord)++-- | A region that occupies no space.+nilRegion :: Region+nilRegion = Region 0 0 0 0++-- | The width and height of a 'Region'+regionSize :: Region -> (Int, Int)+regionSize (Region _ _ w h) = (w, h)++-- | Produces an 'Image' that fills a region with space characters+regionBlankImage :: V.Attr -> Region -> Image+regionBlankImage attr r@(Region _ _ width height) =+ withinImage r $ V.charFill attr ' ' width height++-- | A class for things that know their own display size dimensions+class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where+ -- | Retrieve the display region+ askRegion :: m (Dynamic t Region)+ default askRegion :: (f m' ~ m, MonadTrans f, HasDisplayRegion t m') => m (Dynamic t Region)+ askRegion = lift askRegion+ -- | Run an action in a local region, by applying a transformation to the region+ localRegion :: (Dynamic t Region -> Dynamic t Region) -> m a -> m a+ default localRegion :: (f m' ~ m, Monad m', MFunctor f, HasDisplayRegion t m') => (Dynamic t Region -> Dynamic t Region) -> m a -> m a+ localRegion f = hoist (localRegion f)++-- | Retrieve the display width+displayWidth :: HasDisplayRegion t m => m (Dynamic t Int)+displayWidth = fmap _region_width <$> askRegion++-- | Retrieve the display height+displayHeight :: HasDisplayRegion t m => m (Dynamic t Int)+displayHeight = fmap _region_height <$> askRegion++instance HasDisplayRegion t m => HasDisplayRegion t (ReaderT x m)+instance HasDisplayRegion t m => HasDisplayRegion t (BehaviorWriterT t x m)+instance HasDisplayRegion t m => HasDisplayRegion t (DynamicWriterT t x m)+instance HasDisplayRegion t m => HasDisplayRegion t (EventWriterT t x m)+instance HasDisplayRegion t m => HasDisplayRegion t (NodeIdT m)++-- | A widget that has access to a particular region of the vty display+newtype DisplayRegion t m a = DisplayRegion+ { unDisplayRegion :: ReaderT (Dynamic t Region) m a }+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadFix+ , MonadHold t+ , MonadIO+ , MonadRef+ , MonadSample t+ )++instance (Monad m, Reflex t) => HasDisplayRegion t (DisplayRegion t m) where+ askRegion = DisplayRegion ask+ localRegion f = DisplayRegion . local f . unDisplayRegion++deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DisplayRegion t m)+deriving instance NotReady t m => NotReady t (DisplayRegion t m)+deriving instance PerformEvent t m => PerformEvent t (DisplayRegion t m)+deriving instance PostBuild t m => PostBuild t (DisplayRegion t m)+deriving instance TriggerEvent t m => TriggerEvent t (DisplayRegion t m)+instance HasImageWriter t m => HasImageWriter t (DisplayRegion t m)+instance HasFocusReader t m => HasFocusReader t (DisplayRegion t m)++instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (DisplayRegion t m) where+ runWithReplace (DisplayRegion a) e = DisplayRegion $ runWithReplace a $ fmap unDisplayRegion e+ traverseIntMapWithKeyWithAdjust f m e = DisplayRegion $ traverseIntMapWithKeyWithAdjust (\k v -> unDisplayRegion $ f k v) m e+ traverseDMapWithKeyWithAdjust f m e = DisplayRegion $ traverseDMapWithKeyWithAdjust (\k v -> unDisplayRegion $ f k v) m e+ traverseDMapWithKeyWithAdjustWithMove f m e = DisplayRegion $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unDisplayRegion $ f k v) m e++instance MonadTrans (DisplayRegion t) where+ lift = DisplayRegion . lift++instance MFunctor (DisplayRegion t) where+ hoist f = DisplayRegion . hoist f . unDisplayRegion++instance MonadNodeId m => MonadNodeId (DisplayRegion t m)++-- | Run a 'DisplayRegion' action with a given 'Region'+runDisplayRegion+ :: (Reflex t, Monad m)+ => Dynamic t Region+ -> DisplayRegion t m a+ -> m a+runDisplayRegion r = flip runReaderT r . unDisplayRegion++-- * Getting focus state++-- | A class for things that can dynamically gain and lose focus+class (Reflex t, Monad m) => HasFocusReader t m | m -> t where+ focus :: m (Dynamic t Bool)+ default focus :: (f m' ~ m, Monad m', MonadTrans f, HasFocusReader t m') => m (Dynamic t Bool)+ focus = lift focus+ localFocus :: (Dynamic t Bool -> Dynamic t Bool) -> m a -> m a+ default localFocus :: (f m' ~ m, Monad m', MFunctor f, HasFocusReader t m') => (Dynamic t Bool -> Dynamic t Bool) -> m a -> m a+ localFocus f = hoist (localFocus f)++instance HasFocusReader t m => HasFocusReader t (ReaderT x m)+instance HasFocusReader t m => HasFocusReader t (BehaviorWriterT t x m)+instance HasFocusReader t m => HasFocusReader t (DynamicWriterT t x m)+instance HasFocusReader t m => HasFocusReader t (EventWriterT t x m)+instance HasFocusReader t m => HasFocusReader t (NodeIdT m)++-- | A widget that has access to information about whether it is focused+newtype FocusReader t m a = FocusReader+ { unFocusReader :: ReaderT (Dynamic t Bool) m a }+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadFix+ , MonadHold t+ , MonadIO+ , MonadRef+ , MonadSample t+ )++instance (Monad m, Reflex t) => HasFocusReader t (FocusReader t m) where+ focus = FocusReader ask+ localFocus f = FocusReader . local f . unFocusReader++deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (FocusReader t m)+deriving instance NotReady t m => NotReady t (FocusReader t m)+deriving instance PerformEvent t m => PerformEvent t (FocusReader t m)+deriving instance PostBuild t m => PostBuild t (FocusReader t m)+deriving instance TriggerEvent t m => TriggerEvent t (FocusReader t m)+instance HasImageWriter t m => HasImageWriter t (FocusReader t m)++instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (FocusReader t m) where+ runWithReplace (FocusReader a) e = FocusReader $ runWithReplace a $ fmap unFocusReader e+ traverseIntMapWithKeyWithAdjust f m e = FocusReader $ traverseIntMapWithKeyWithAdjust (\k v -> unFocusReader $ f k v) m e+ traverseDMapWithKeyWithAdjust f m e = FocusReader $ traverseDMapWithKeyWithAdjust (\k v -> unFocusReader $ f k v) m e+ traverseDMapWithKeyWithAdjustWithMove f m e = FocusReader $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocusReader $ f k v) m e++instance MonadTrans (FocusReader t) where+ lift = FocusReader . lift++instance MFunctor (FocusReader t) where+ hoist f = FocusReader . hoist f . unFocusReader++instance MonadNodeId m => MonadNodeId (FocusReader t m)++-- | Run a 'FocusReader' action with the given focus value+runFocusReader+ :: (Reflex t, Monad m)+ => Dynamic t Bool+ -> FocusReader t m a+ -> m a+runFocusReader b = flip runReaderT b . unFocusReader++-- * "Image" output++-- | A class for widgets that can produce images to draw to the display+class (Reflex t, Monad m) => HasImageWriter t m | m -> t where+ -- | Send images upstream for rendering+ tellImages :: Behavior t [Image] -> m ()+ default tellImages :: (f m' ~ m, Monad m', MonadTrans f, HasImageWriter t m') => Behavior t [Image] -> m ()+ tellImages = lift . tellImages+ -- | Apply a transformation to the images produced by the child actions+ mapImages :: (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a+ default mapImages :: (f m' ~ m, Monad m', MFunctor f, HasImageWriter t m') => (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a+ mapImages f = hoist (mapImages f)++-- | A widget that can produce images to draw onto the display+newtype ImageWriter t m a = ImageWriter+ { unImageWriter :: BehaviorWriterT t [Image] m a }+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadFix+ , MonadHold t+ , MonadIO+ , MonadRef+ , MonadReflexCreateTrigger t+ , MonadSample t+ , NotReady t+ , PerformEvent t+ , PostBuild t+ , TriggerEvent t+ )++instance MonadTrans (ImageWriter t) where+ lift = ImageWriter . lift++instance MFunctor (ImageWriter t) where+ hoist f = ImageWriter . (hoist f) . unImageWriter++instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ImageWriter t m) where+ runWithReplace (ImageWriter a) e = ImageWriter $ runWithReplace a $ fmap unImageWriter e+ traverseIntMapWithKeyWithAdjust f m e = ImageWriter $ traverseIntMapWithKeyWithAdjust (\k v -> unImageWriter $ f k v) m e+ traverseDMapWithKeyWithAdjust f m e = ImageWriter $ traverseDMapWithKeyWithAdjust (\k v -> unImageWriter $ f k v) m e+ traverseDMapWithKeyWithAdjustWithMove f m e = ImageWriter $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unImageWriter $ f k v) m e++instance HasImageWriter t m => HasImageWriter t (ReaderT x m)+instance HasImageWriter t m => HasImageWriter t (BehaviorWriterT t x m)+instance HasImageWriter t m => HasImageWriter t (DynamicWriterT t x m)+instance HasImageWriter t m => HasImageWriter t (EventWriterT t x m)+instance HasImageWriter t m => HasImageWriter t (NodeIdT m)++instance (Monad m, Reflex t) => HasImageWriter t (ImageWriter t m) where+ tellImages = ImageWriter . tellBehavior+ mapImages f (ImageWriter x) = ImageWriter $ do+ (a, images) <- lift $ runBehaviorWriterT x+ tellBehavior $ f images+ pure a++instance HasDisplayRegion t m => HasDisplayRegion t (ImageWriter t m)+instance HasFocusReader t m => HasFocusReader t (ImageWriter t m)++-- | Run a widget that can produce images+runImageWriter+ :: (Reflex t, Monad m)+ => ImageWriter t m a+ -> m (a, Behavior t [Image])+runImageWriter = runBehaviorWriterT . unImageWriter++-- * Theming++-- | A class for things that can be visually styled+class (Reflex t, Monad m) => HasTheme t m | m -> t where+ theme :: m (Behavior t V.Attr)+ default theme :: (f m' ~ m, Monad m', MonadTrans f, HasTheme t m') => m (Behavior t V.Attr)+ theme = lift theme+ localTheme :: (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a+ default localTheme :: (f m' ~ m, Monad m', MFunctor f, HasTheme t m') => (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a+ localTheme f = hoist (localTheme f)++instance HasTheme t m => HasTheme t (ReaderT x m)+instance HasTheme t m => HasTheme t (BehaviorWriterT t x m)+instance HasTheme t m => HasTheme t (DynamicWriterT t x m)+instance HasTheme t m => HasTheme t (EventWriterT t x m)+instance HasTheme t m => HasTheme t (NodeIdT m)+instance HasTheme t m => HasTheme t (Input t m)+instance HasTheme t m => HasTheme t (ImageWriter t m)+instance HasTheme t m => HasTheme t (DisplayRegion t m)+instance HasTheme t m => HasTheme t (FocusReader t m)++-- | A widget that has access to theme information+newtype ThemeReader t m a = ThemeReader+ { unThemeReader :: ReaderT (Behavior t V.Attr) m a }+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadFix+ , MonadHold t+ , MonadIO+ , MonadRef+ , MonadSample t+ )++instance (Monad m, Reflex t) => HasTheme t (ThemeReader t m) where+ theme = ThemeReader ask+ localTheme f = ThemeReader . local f . unThemeReader++deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ThemeReader t m)+deriving instance NotReady t m => NotReady t (ThemeReader t m)+deriving instance PerformEvent t m => PerformEvent t (ThemeReader t m)+deriving instance PostBuild t m => PostBuild t (ThemeReader t m)+deriving instance TriggerEvent t m => TriggerEvent t (ThemeReader t m)+instance HasImageWriter t m => HasImageWriter t (ThemeReader t m)++instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ThemeReader t m) where+ runWithReplace (ThemeReader a) e = ThemeReader $ runWithReplace a $ fmap unThemeReader e+ traverseIntMapWithKeyWithAdjust f m e = ThemeReader $ traverseIntMapWithKeyWithAdjust (\k v -> unThemeReader $ f k v) m e+ traverseDMapWithKeyWithAdjust f m e = ThemeReader $ traverseDMapWithKeyWithAdjust (\k v -> unThemeReader $ f k v) m e+ traverseDMapWithKeyWithAdjustWithMove f m e = ThemeReader $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unThemeReader $ f k v) m e++instance MonadTrans (ThemeReader t) where+ lift = ThemeReader . lift++instance MFunctor (ThemeReader t) where+ hoist f = ThemeReader . hoist f . unThemeReader++instance MonadNodeId m => MonadNodeId (ThemeReader t m)++-- | Run a 'ThemeReader' action with the given focus value+runThemeReader+ :: (Reflex t, Monad m)+ => Behavior t V.Attr+ -> ThemeReader t m a+ -> m a+runThemeReader b = flip runReaderT b . unThemeReader+++-- ** Manipulating images++-- | Translates and crops an 'Image' so that it is contained by+-- the given 'Region'.+withinImage+ :: Region+ -> Image+ -> Image+withinImage (Region left top width height)+ | width < 0 || height < 0 = withinImage (Region left top 0 0)+ | otherwise = V.translate left top . V.crop width height++-- | Crop a behavior of images to a behavior of regions. See 'withinImage'.+imagesInRegion+ :: Reflex t+ => Behavior t Region+ -> Behavior t [Image]+ -> Behavior t [Image]+imagesInRegion reg = liftA2 (\r is -> map (withinImage r) is) reg++-- * Running sub-widgets++-- | Low-level widget combinator that runs a child widget within+-- a given region and context. This widget filters and modifies the input+-- that the child widget receives such that:+-- * unfocused widgets receive no key events+-- * mouse inputs outside the region are ignored+-- * mouse inputs inside the region have their coordinates translated such+-- that (0,0) is the top-left corner of the region+pane+ :: (Reflex t, Monad m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)+ => Dynamic t Region+ -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.+ -> m a+ -> m a+pane dr foc child = localRegion (const dr) $+ mapImages (imagesInRegion $ current dr) $+ localFocus (const foc) $+ inputInFocusedRegion >>= \e -> localInput (const e) child++-- * Misc++-- | A widget that draws nothing+blank :: Monad m => m () blank = return ()
+ src/Reflex/Vty/Widget/Box.hs view
@@ -0,0 +1,124 @@+{-|+ Description: Drawing boxes in various styles+-}+module Reflex.Vty.Widget.Box where++import Data.Default+import Data.Text (Text)+import qualified Data.Text as T+import Graphics.Vty (Image)+import qualified Graphics.Vty as V+import Reflex+import Reflex.Vty.Widget+import Reflex.Vty.Widget.Text++-- | Fill the background with the bottom box style+hRule :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => BoxStyle -> m ()+hRule boxStyle = fill $ pure (_boxStyle_s boxStyle)++-- | Defines a set of symbols to use to draw the outlines of boxes+-- C.f. https://en.wikipedia.org/wiki/Box-drawing_character+data BoxStyle = BoxStyle+ { _boxStyle_nw :: Char+ , _boxStyle_n :: Char+ , _boxStyle_ne :: Char+ , _boxStyle_e :: Char+ , _boxStyle_se :: Char+ , _boxStyle_s :: Char+ , _boxStyle_sw :: Char+ , _boxStyle_w :: Char+ }++instance Default BoxStyle where+ def = singleBoxStyle++-- | A box style that uses hyphens and pipe characters. Doesn't handle+-- corners very well.+hyphenBoxStyle :: BoxStyle+hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'++-- | A single line box style+singleBoxStyle :: BoxStyle+singleBoxStyle = BoxStyle '┌' '─' '┐' '│' '┘' '─' '└' '│'++-- | A thick single line box style+thickBoxStyle :: BoxStyle+thickBoxStyle = BoxStyle '┏' '━' '┓' '┃' '┛' '━' '┗' '┃'++-- | A double line box style+doubleBoxStyle :: BoxStyle+doubleBoxStyle = BoxStyle '╔' '═' '╗' '║' '╝' '═' '╚' '║'++-- | A single line box style with rounded corners+roundedBoxStyle :: BoxStyle+roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'++-- | Draws a titled box in the provided style and a child widget inside of that box+boxTitle :: (Monad m, Reflex t ,HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)+ => Behavior t BoxStyle+ -> Behavior t Text+ -> m a+ -> m a+boxTitle boxStyle title child = do+ dh <- displayHeight+ dw <- displayWidth+ bt <- theme+ let boxReg = Region 0 0 <$> dw <*> dh+ innerReg = Region 1 1 <$> (subtract 2 <$> dw) <*> (subtract 2 <$> dh)++ tellImages (boxImages <$> bt <*> title <*> boxStyle <*> current boxReg)+ tellImages (ffor2 (current innerReg) bt (\r attr -> [regionBlankImage attr r]))++ pane innerReg (pure True) child+ where+ boxImages :: V.Attr -> Text -> BoxStyle -> Region -> [Image]+ boxImages attr title' style (Region left top width height) =+ let right = left + width - 1+ bottom = top + height - 1+ sides =+ [ withinImage (Region (left + 1) top (width - 2) 1) $+ V.text' attr $+ hPadText title' (_boxStyle_n style) (width - 2)+ , withinImage (Region right (top + 1) 1 (height - 2)) $+ V.charFill attr (_boxStyle_e style) 1 (height - 2)+ , withinImage (Region (left + 1) bottom (width - 2) 1) $+ V.charFill attr (_boxStyle_s style) (width - 2) 1+ , withinImage (Region left (top + 1) 1 (height - 2)) $+ V.charFill attr (_boxStyle_w style) 1 (height - 2)+ ]+ corners =+ [ withinImage (Region left top 1 1) $+ V.char attr (_boxStyle_nw style)+ , withinImage (Region right top 1 1) $+ V.char attr (_boxStyle_ne style)+ , withinImage (Region right bottom 1 1) $+ V.char attr (_boxStyle_se style)+ , withinImage (Region left bottom 1 1) $+ V.char attr (_boxStyle_sw style)+ ]+ in sides ++ if width > 1 && height > 1 then corners else []+ hPadText :: T.Text -> Char -> Int -> T.Text+ hPadText t c l = if lt >= l+ then t+ else left <> t <> right+ where+ lt = T.length t+ delta = l - lt+ mkHalf n = T.replicate (n `div` 2) (T.singleton c)+ left = mkHalf $ delta + 1+ right = mkHalf delta++-- | A box without a title+box :: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)+ => Behavior t BoxStyle+ -> m a+ -> m a+box boxStyle = boxTitle boxStyle mempty++-- | A box whose style is static+boxStatic+ :: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)+ => BoxStyle+ -> m a+ -> m a+boxStatic = box . pure
src/Reflex/Vty/Widget/Input.hs view
@@ -2,25 +2,27 @@ Module: Reflex.Vty.Widget.Input Description: User input widgets for reflex-vty -}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-} module Reflex.Vty.Widget.Input ( module Export , module Reflex.Vty.Widget.Input ) where +import Reflex.Vty.Widget.Input.Mouse as Export import Reflex.Vty.Widget.Input.Text as Export import Control.Monad (join) import Control.Monad.Fix (MonadFix)-import Control.Monad.NodeId (MonadNodeId) import Data.Default (Default(..)) import Data.Text (Text) import qualified Graphics.Vty as V import Reflex import Reflex.Vty.Widget+import Reflex.Vty.Widget.Box+import Reflex.Vty.Widget.Text +-- * Buttons+ -- | Configuration options for the 'button' widget data ButtonConfig t = ButtonConfig { _buttonConfig_boxStyle :: Behavior t BoxStyle@@ -32,10 +34,10 @@ -- | A button widget that contains a sub-widget button- :: (Reflex t, Monad m, MonadNodeId m)+ :: (Reflex t, Monad m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m) => ButtonConfig t- -> VtyWidget t m ()- -> VtyWidget t m (Event t ())+ -> m ()+ -> m (Event t ()) button cfg child = do f <- focus let style = do@@ -50,39 +52,44 @@ -- | A button widget that displays text that can change textButton- :: (Reflex t, Monad m, MonadNodeId m)+ :: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m) => ButtonConfig t -> Behavior t Text- -> VtyWidget t m (Event t ())+ -> m (Event t ()) textButton cfg = button cfg . text -- TODO Centering etc. -- | A button widget that displays a static bit of text textButtonStatic- :: (Reflex t, Monad m, MonadNodeId m)+ :: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m) => ButtonConfig t -> Text- -> VtyWidget t m (Event t ())+ -> m (Event t ()) textButtonStatic cfg = textButton cfg . pure +-- * Links+ -- | A clickable link widget link- :: (Reflex t, Monad m)+ :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasTheme t m) => Behavior t Text- -> VtyWidget t m (Event t MouseUp)+ -> m (Event t MouseUp) link t = do+ bt <- theme let cfg = RichTextConfig- { _richTextConfig_attributes = pure $ V.withStyle V.defAttr V.underline+ { _richTextConfig_attributes = fmap (\attr -> V.withStyle attr V.underline) bt } richText cfg t mouseUp -- | A clickable link widget with a static label linkStatic- :: (Reflex t, Monad m)+ :: (Reflex t, Monad m, HasImageWriter t m, HasDisplayRegion t m, HasInput t m, HasTheme t m) => Text- -> VtyWidget t m (Event t MouseUp)+ -> m (Event t MouseUp) linkStatic = link . pure +-- * Checkboxes+ -- | Characters used to render checked and unchecked textboxes data CheckboxStyle = CheckboxStyle { _checkboxStyle_unchecked :: Text@@ -109,32 +116,43 @@ -- | Configuration options for a checkbox data CheckboxConfig t = CheckboxConfig { _checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle+ -- TODO DELETE and use HasTheme instead , _checkboxConfig_attributes :: Behavior t V.Attr+ , _checkboxConfig_setValue :: Event t Bool } instance (Reflex t) => Default (CheckboxConfig t) where def = CheckboxConfig { _checkboxConfig_checkboxStyle = pure def , _checkboxConfig_attributes = pure V.defAttr+ , _checkboxConfig_setValue = never } -- | A checkbox widget checkbox- :: (MonadHold t m, MonadFix m, Reflex t)+ :: (MonadHold t m, MonadFix m, Reflex t, HasInput t m, HasDisplayRegion t m, HasImageWriter t m, HasFocusReader t m, HasTheme t m) => CheckboxConfig t -> Bool- -> VtyWidget t m (Dynamic t Bool)+ -> m (Dynamic t Bool) checkbox cfg v0 = do md <- mouseDown V.BLeft mu <- mouseUp- v <- toggle v0 $ () <$ mu+ space <- key (V.KChar ' ')+ f <- focus+ v <- foldDyn ($) v0 $ leftmost+ [ not <$ mu+ , not <$ space+ , const <$> _checkboxConfig_setValue cfg+ ]+ let bold = V.withStyle mempty V.bold depressed <- hold mempty $ leftmost- [ V.withStyle mempty V.bold <$ md+ [ bold <$ md , mempty <$ mu ]- let attrs = (<>) <$> (_checkboxConfig_attributes cfg) <*> depressed+ let focused = ffor (current f) $ \x -> if x then bold else mempty+ let attrs = mconcat <$> sequence [_checkboxConfig_attributes cfg, depressed, focused] richText (RichTextConfig attrs) $ join . current $ ffor v $ \checked -> if checked- then fmap _checkboxStyle_checked $ _checkboxConfig_checkboxStyle cfg- else fmap _checkboxStyle_unchecked $ _checkboxConfig_checkboxStyle cfg+ then _checkboxStyle_checked <$> _checkboxConfig_checkboxStyle cfg+ else _checkboxStyle_unchecked <$> _checkboxConfig_checkboxStyle cfg return v
+ src/Reflex/Vty/Widget/Input/Mouse.hs view
@@ -0,0 +1,106 @@+{-|+ Description: Mouse clicks, drags, and scrolls+-}+module Reflex.Vty.Widget.Input.Mouse where++import Control.Monad.Fix+import qualified Graphics.Vty as V+import Reflex+import Reflex.Vty.Widget++-- | Information about a drag operation+data Drag = Drag+ { _drag_from :: (Int, Int) -- ^ Where the drag began+ , _drag_to :: (Int, Int) -- ^ Where the mouse currently is+ , _drag_button :: V.Button -- ^ Which mouse button is dragging+ , _drag_modifiers :: [V.Modifier] -- ^ What modifiers are held+ , _drag_end :: Bool -- ^ Whether the drag ended (the mouse button was released)+ }+ deriving (Eq, Ord, Show)++-- | Converts raw vty mouse drag events into an event stream of 'Drag's+drag+ :: (Reflex t, MonadFix m, MonadHold t m, HasInput t m)+ => V.Button+ -> m (Event t Drag)+drag btn = do+ inp <- input+ let f :: Maybe Drag -> V.Event -> Maybe Drag+ f Nothing = \case+ V.EvMouseDown x y btn' mods+ | btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods False+ | otherwise -> Nothing+ _ -> Nothing+ f (Just (Drag from _ _ mods end)) = \case+ V.EvMouseDown x y btn' mods'+ | end && btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods' False+ | btn == btn' -> Just $ Drag from (x,y) btn mods' False+ | otherwise -> Nothing -- Ignore other buttons.+ V.EvMouseUp x y (Just btn')+ | end -> Nothing+ | btn == btn' -> Just $ Drag from (x,y) btn mods True+ | otherwise -> Nothing+ V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button,+ -- assume it's the right one.+ | end -> Nothing+ | otherwise -> Just $ Drag from (x,y) btn mods True+ _ -> Nothing+ rec let newDrag = attachWithMaybe f (current dragD) inp+ dragD <- holdDyn Nothing $ Just <$> newDrag+ return (fmapMaybe id $ updated dragD)++-- | Mouse down events for a particular mouse button+mouseDown+ :: (Reflex t, Monad m, HasInput t m)+ => V.Button+ -> m (Event t MouseDown)+mouseDown btn = do+ i <- input+ return $ fforMaybe i $ \case+ V.EvMouseDown x y btn' mods -> if btn == btn'+ then Just $ MouseDown btn' (x, y) mods+ else Nothing+ _ -> Nothing++-- | Mouse up events for a particular mouse button+mouseUp+ :: (Reflex t, Monad m, HasInput t m)+ => m (Event t MouseUp)+mouseUp = do+ i <- input+ return $ fforMaybe i $ \case+ V.EvMouseUp x y btn' -> Just $ MouseUp btn' (x, y)+ _ -> Nothing++-- | Information about a mouse down event+data MouseDown = MouseDown+ { _mouseDown_button :: V.Button+ , _mouseDown_coordinates :: (Int, Int)+ , _mouseDown_modifiers :: [V.Modifier]+ }+ deriving (Eq, Ord, Show)++-- | Information about a mouse up event+data MouseUp = MouseUp+ { _mouseUp_button :: Maybe V.Button+ , _mouseUp_coordinates :: (Int, Int)+ }+ deriving (Eq, Ord, Show)++-- | Mouse scroll direction+data ScrollDirection = ScrollDirection_Up | ScrollDirection_Down+ deriving (Eq, Ord, Show)++-- | Produce an event that fires when the mouse wheel is scrolled+mouseScroll+ :: (Reflex t, Monad m, HasInput t m)+ => m (Event t ScrollDirection)+mouseScroll = do+ up <- mouseDown V.BScrollUp+ down <- mouseDown V.BScrollDown+ return $ leftmost+ [ ScrollDirection_Up <$ up+ , ScrollDirection_Down <$ down+ ]++
src/Reflex/Vty/Widget/Input/Text.hs view
@@ -2,11 +2,6 @@ Module: Reflex.Vty.Widget.Input.Text Description: Widgets for accepting text input from users and manipulating text within those inputs -}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE ScopedTypeVariables #-} module Reflex.Vty.Widget.Input.Text ( module Reflex.Vty.Widget.Input.Text , def@@ -14,7 +9,6 @@ import Control.Monad (join) import Control.Monad.Fix (MonadFix)-import Control.Monad.NodeId (MonadNodeId) import Data.Default (Default(..)) import Data.Text (Text) import Data.Text.Zipper@@ -23,6 +17,7 @@ import Reflex.Vty.Widget import Reflex.Vty.Widget.Layout+import Reflex.Vty.Widget.Input.Mouse -- | Configuration options for a 'textInput'. For more information on -- 'TextZipper', see 'Data.Text.Zipper'.@@ -48,14 +43,16 @@ -- | A widget that allows text input textInput- :: (Reflex t, MonadHold t m, MonadFix m)+ :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m, HasDisplayRegion t m) => TextInputConfig t- -> VtyWidget t m (TextInput t)+ -> m (TextInput t) textInput cfg = do i <- input f <- focus dh <- displayHeight dw <- displayWidth+ bt <- theme+ attr0 <- sample bt rec v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.) [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i , _textInputConfig_modify cfg@@ -64,13 +61,20 @@ goToDisplayLinePosition mx (st + my) dl ] click <- mouseDown V.BLeft- let cursorAttrs = ffor f $ \x -> if x then cursorAttributes else V.defAttr- let rows = (\w s c -> displayLines w V.defAttr c s)++ -- TODO reverseVideo is prob not what we want. Does not work with `darkTheme` in example.hs (cursor is dark rather than light bg)+ let toCursorAttrs attr = V.withStyle attr V.reverseVideo+ rowInputDyn = (,,) <$> dw <*> (mapZipper <$> _textInputConfig_display cfg <*> v)- <*> cursorAttrs+ <*> f+ toDisplayLines attr (w, s, x) =+ let c = if x then toCursorAttrs attr else attr+ in displayLines w attr c s+ attrDyn <- holdDyn attr0 $ pushAlways (\_ -> sample bt) (updated rowInputDyn)+ let rows = ffor2 attrDyn rowInputDyn toDisplayLines img = images . _displayLines_spans <$> rows- y <- holdUniqDyn $ _displayLines_cursorY <$> rows+ y <- holdUniqDyn $ fmap snd _displayLines_cursorPos <$> rows let newScrollTop :: Int -> (Int, Int) -> Int newScrollTop st (h, cursorY) | cursorY < st = cursorY@@ -86,9 +90,9 @@ -- | A widget that allows multiline text input multilineTextInput- :: (Reflex t, MonadHold t m, MonadFix m)+ :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m) => TextInputConfig t- -> VtyWidget t m (TextInput t)+ -> m (TextInput t) multilineTextInput cfg = do i <- input textInput $ cfg@@ -104,21 +108,17 @@ -- the computed line count to greedily size the tile when vertically -- oriented, and uses the fallback width when horizontally oriented. textInputTile- :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId m)- => VtyWidget t m (TextInput t)+ :: (Monad m, Reflex t, MonadFix m, HasLayout t m, HasInput t m, HasFocus t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m)+ => m (TextInput t) -> Dynamic t Int- -> Layout t m (TextInput t)+ -> m (TextInput t) textInputTile txt width = do o <- askOrientation- rec t <- fixed sz txt+ rec t <- tile (Constraint_Fixed <$> sz) txt let sz = join $ ffor o $ \case Orientation_Column -> _textInput_lines t Orientation_Row -> width return t---- | Default attributes for the text cursor-cursorAttributes :: V.Attr-cursorAttributes = V.withStyle V.defAttr V.reverseVideo -- | Turn a set of display line rows into a list of images (one per line) images :: [[Span V.Attr]] -> [V.Image]
src/Reflex/Vty/Widget/Layout.hs view
@@ -2,70 +2,100 @@ Module: Reflex.Vty.Widget.Layout Description: Monad transformer and tools for arranging widgets and building screen layouts -}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE UndecidableInstances #-}+{-# Language UndecidableInstances #-} -module Reflex.Vty.Widget.Layout- ( Orientation(..)- , Constraint(..)- , Layout- , runLayout- , TileConfig(..)- , tile- , fixed- , stretch- , col- , row- , tabNavigation- , askOrientation- ) where+module Reflex.Vty.Widget.Layout where -import Control.Monad.NodeId (NodeId, MonadNodeId(..))+import Control.Applicative (liftA2)+import Control.Monad.Morph+import Control.Monad.NodeId (MonadNodeId(..), NodeId) import Control.Monad.Reader-import Data.Bimap (Bimap)-import qualified Data.Bimap as Bimap-import Data.Default (Default(..))-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (fromMaybe)-import Data.Monoid hiding (First(..))+import Data.List (mapAccumL)+import Data.Map.Ordered (OMap)+import qualified Data.Map.Ordered as OMap+import Data.Maybe (fromMaybe, isNothing) import Data.Ratio ((%)) import Data.Semigroup (First(..))+import Data.Set.Ordered (OSet)+import qualified Data.Set.Ordered as OSet import qualified Graphics.Vty as V import Reflex import Reflex.Host.Class (MonadReflexCreateTrigger) import Reflex.Vty.Widget+import Reflex.Vty.Widget.Input.Mouse --- | The main-axis orientation of a 'Layout' widget-data Orientation = Orientation_Column- | Orientation_Row- deriving (Show, Read, Eq, Ord)+-- * Focus+--+-- $focus+--+-- The focus monad tracks which element is currently focused and processes+-- requests to change focus. Focusable elements are assigned a 'FocusId' and+-- can manually request focus or receive focus due to some other action (e.g.,+-- a tab press in a sibling element, a click event).+--+-- Focusable elements will usually be created via 'tile', but can also be+-- constructed via 'makeFocus' in 'HasFocus'. The latter option allows for+-- more find-grained control of focus behavior. -data LayoutSegment = LayoutSegment- { _layoutSegment_offset :: Int- , _layoutSegment_size :: Int- }+-- ** Storing focus state -data LayoutCtx t = LayoutCtx- { _layoutCtx_regions :: Dynamic t (Map NodeId LayoutSegment)- , _layoutCtx_focusDemux :: Demux t (Maybe NodeId)- , _layoutCtx_orientation :: Dynamic t Orientation- }+-- | Identifies an element that is focusable. Can be created using 'makeFocus'.+newtype FocusId = FocusId NodeId+ deriving (Eq, Ord) --- | The Layout monad transformer keeps track of the configuration (e.g., 'Orientation') and--- 'Constraint's of its child widgets, apportions vty real estate to each, and acts as a--- switchboard for focus requests. See 'tile' and 'runLayout'.-newtype Layout t m a = Layout- { unLayout :: EventWriterT t (First NodeId)- (DynamicWriterT t (Endo [(NodeId, (Bool, Constraint))])- (ReaderT (LayoutCtx t)- (VtyWidget t m))) a- } deriving+-- | An ordered set of focus identifiers. The order here determines the order+-- in which focus cycles between focusable elements.+newtype FocusSet = FocusSet { unFocusSet :: OSet FocusId }++instance Semigroup FocusSet where+ FocusSet a <> FocusSet b = FocusSet $ a OSet.|<> b++instance Monoid FocusSet where+ mempty = FocusSet OSet.empty++-- | Produces a 'FocusSet' with a single element+singletonFS :: FocusId -> FocusSet+singletonFS = FocusSet . OSet.singleton++-- ** Changing focus state++-- | Operations that change the currently focused element.+data Refocus = Refocus_Shift Int -- ^ Shift the focus by a certain number of positions (see 'shiftFS')+ | Refocus_Id FocusId -- ^ Focus a particular element+ | Refocus_Clear -- ^ Remove focus from all elements++-- | Given a 'FocusSet', a currently focused element, and a number of positions+-- to move by, determine the newly focused element.+shiftFS :: FocusSet -> Maybe FocusId -> Int -> Maybe FocusId+shiftFS (FocusSet s) fid n = case OSet.findIndex <$> fid <*> pure s of+ Nothing -> OSet.elemAt s 0+ Just Nothing -> OSet.elemAt s 0+ Just (Just ix) -> OSet.elemAt s $ mod (ix + n) (OSet.size s)++-- ** The focus management monad++-- | A class for things that can produce focusable elements.+class (Monad m, Reflex t) => HasFocus t m | m -> t where+ -- | Create a focusable element.+ makeFocus :: m FocusId+ -- | Emit an 'Event' of requests to change the focus.+ requestFocus :: Event t Refocus -> m ()+ -- | Produce a 'Dynamic' that indicates whether the given 'FocusId' is focused.+ isFocused :: FocusId -> m (Dynamic t Bool)+ -- | Run an action, additionally returning the focusable elements it produced.+ subFoci :: m a -> m (a, Dynamic t FocusSet)+ -- | Get a 'Dynamic' of the currently focused element identifier.+ focusedId :: m (Dynamic t (Maybe FocusId))++-- | A monad transformer that keeps track of the set of focusable elements and+-- which, if any, are currently focused, and allows focus requests.+newtype Focus t m a = Focus+ { unFocus :: DynamicWriterT t FocusSet+ (ReaderT (Dynamic t (Maybe FocusId))+ (EventWriterT t (First Refocus) m)) a+ }+ deriving ( Functor , Applicative , Monad@@ -76,210 +106,444 @@ , PerformEvent t , NotReady t , MonadReflexCreateTrigger t- , HasDisplaySize t- , MonadNodeId+ , HasDisplayRegion t , PostBuild t+ , MonadNodeId+ , MonadIO ) -instance MonadTrans (Layout t) where- lift x = Layout $ lift $ lift $ lift $ lift x -instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m) where- runWithReplace (Layout a) e = Layout $ runWithReplace a $ fmap unLayout e- traverseIntMapWithKeyWithAdjust f m e = Layout $ traverseIntMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e- traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e- traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e+instance MonadTrans (Focus t) where+ lift = Focus . lift . lift . lift --- | Run a 'Layout' action-runLayout- :: (MonadFix m, MonadHold t m, PostBuild t m, Monad m, MonadNodeId m)- => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout'- -> Int -- ^ The positional index of the initially focused tile- -> Event t Int -- ^ An event that shifts focus by a given number of tiles- -> Layout t m a -- ^ The 'Layout' widget- -> VtyWidget t m a-runLayout ddir focus0 focusShift (Layout child) = do- dw <- displayWidth- dh <- displayHeight- let main = ffor3 ddir dw dh $ \d w h -> case d of- Orientation_Column -> h- Orientation_Row -> w- pb <- getPostBuild- rec ((a, focusReq), queriesEndo) <- runReaderT (runDynamicWriterT $ runEventWriterT child) $ LayoutCtx solutionMap focusDemux ddir- let queries = flip appEndo [] <$> queriesEndo- solution = ffor2 main queries $ \sz qs -> Map.fromList- . Map.elems- . computeEdges- . computeSizes sz- . fmap (fmap snd)- . Map.fromList- . zip [0::Integer ..]- $ qs- solutionMap = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment- { _layoutSegment_offset = offset- , _layoutSegment_size = sz- }- focusable = fmap (Bimap.fromList . zip [0..]) $- ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) ->- if f then Just nodeId else Nothing- adjustFocus- :: (Bimap Int NodeId, (Int, Maybe NodeId))- -> Either Int NodeId- -> (Int, Maybe NodeId)- adjustFocus (fm, (cur, _)) (Left shift) =- let ix = (cur + shift) `mod` (max 1 $ Bimap.size fm)- in (ix, Bimap.lookup ix fm)- adjustFocus (fm, (cur, _)) (Right goto) =- let ix = fromMaybe cur $ Bimap.lookupR goto fm- in (ix, Just goto)- focusChange = attachWith- adjustFocus- (current $ (,) <$> focusable <*> focussed)- $ leftmost [Left <$> focusShift, Left 0 <$ pb, Right . getFirst <$> focusReq]- -- A pair (Int, Maybe NodeId) which represents the index- -- that we're trying to focus, and the node that actually gets- -- focused (at that index) if it exists- focussed <- holdDyn (focus0, Nothing) focusChange- let focusDemux = demux $ snd <$> focussed- return a+instance MFunctor (Focus t) where+ hoist f = Focus . hoist (hoist (hoist f)) . unFocus --- | Tiles are the basic building blocks of 'Layout' widgets. Each tile has a constraint--- on its size and ability to grow and on whether it can be focused. It also allows its child--- widget to request focus.-tile- :: (Reflex t, Monad m, MonadNodeId m)- => TileConfig t -- ^ The tile's configuration- -> VtyWidget t m (Event t x, a) -- ^ A child widget. The 'Event' that it returns is used to request that it be focused.- -> Layout t m a-tile (TileConfig con focusable) child = do- nodeId <- getNextNodeId- Layout $ tellDyn $ ffor2 con focusable $ \c f -> Endo ((nodeId, (f, c)):)- seg <- Layout $ asks $- fmap (Map.findWithDefault (LayoutSegment 0 0) nodeId) . _layoutCtx_regions- dw <- displayWidth- dh <- displayHeight- o <- askOrientation- let cross = join $ ffor o $ \case- Orientation_Column -> dw- Orientation_Row -> dh- let reg = DynRegion- { _dynRegion_top = ffor2 seg o $ \s -> \case- Orientation_Column -> _layoutSegment_offset s- Orientation_Row -> 0- , _dynRegion_left = ffor2 seg o $ \s -> \case- Orientation_Column -> 0- Orientation_Row -> _layoutSegment_offset s- , _dynRegion_width = ffor3 seg cross o $ \s c -> \case- Orientation_Column -> c- Orientation_Row -> _layoutSegment_size s- , _dynRegion_height = ffor3 seg cross o $ \s c -> \case- Orientation_Column -> _layoutSegment_size s- Orientation_Row -> c- }- focussed <- Layout $ asks _layoutCtx_focusDemux- (focusReq, a) <- Layout $ lift $ lift $ lift $- pane reg (demuxed focussed $ Just nodeId) $ child- Layout $ tellEvent $ First nodeId <$ focusReq- return a+instance (Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (Focus t m) where+ runWithReplace (Focus a) e = Focus $ runWithReplace a $ fmap unFocus e+ traverseIntMapWithKeyWithAdjust f m e = Focus $ traverseIntMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e+ traverseDMapWithKeyWithAdjust f m e = Focus $ traverseDMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e+ traverseDMapWithKeyWithAdjustWithMove f m e = Focus $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocus $ f k v) m e --- | Configuration options for and constraints on 'tile'-data TileConfig t = TileConfig- { _tileConfig_constraint :: Dynamic t Constraint- -- ^ 'Constraint' on the tile's size- , _tileConfig_focusable :: Dynamic t Bool- -- ^ Whether the tile is focusable- }+instance (Reflex t, MonadFix m, HasInput t m) => HasInput t (Focus t m) where+ localInput f = hoist (localInput f) -instance Reflex t => Default (TileConfig t) where- def = TileConfig (pure $ Constraint_Min 0) (pure True)+instance (HasImageWriter t m, MonadFix m) => HasImageWriter t (Focus t m) where+ mapImages f = hoist (mapImages f) --- | A 'tile' of a fixed size that is focusable and gains focus on click-fixed- :: (Reflex t, Monad m, MonadNodeId m)- => Dynamic t Int- -> VtyWidget t m a- -> Layout t m a-fixed sz = tile (def { _tileConfig_constraint = Constraint_Fixed <$> sz }) . clickable+instance (HasFocusReader t m, Monad m) => HasFocusReader t (Focus t m) --- | A 'tile' that can stretch (i.e., has no fixed size) and has a minimum size of 0.--- This tile is focusable and gains focus on click.-stretch- :: (Reflex t, Monad m, MonadNodeId m)- => VtyWidget t m a- -> Layout t m a-stretch = tile def . clickable+instance (HasTheme t m, Monad m) => HasTheme t (Focus t m) --- | A version of 'runLayout' that arranges tiles in a column and uses 'tabNavigation' to--- change tile focus.-col- :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)- => Layout t m a- -> VtyWidget t m a-col child = do- nav <- tabNavigation- runLayout (pure Orientation_Column) 0 nav child+instance (Reflex t, MonadFix m, MonadNodeId m) => HasFocus t (Focus t m) where+ makeFocus = do+ fid <- FocusId <$> lift getNextNodeId+ Focus $ tellDyn $ pure $ singletonFS fid+ pure fid+ requestFocus = Focus . tellEvent . fmap First+ isFocused fid = do+ sel <- Focus ask+ pure $ (== Just fid) <$> sel+ subFoci (Focus child) = Focus $ do+ (a, fs) <- lift $ runDynamicWriterT child+ tellDyn fs+ return (a, fs)+ focusedId = Focus ask --- | A version of 'runLayout' that arranges tiles in a row and uses 'tabNavigation' to--- change tile focus.-row- :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)- => Layout t m a- -> VtyWidget t m a-row child = do- nav <- tabNavigation- runLayout (pure Orientation_Row) 0 nav child+-- | Runs a 'Focus' action, maintaining the selection state internally.+runFocus+ :: (MonadFix m, MonadHold t m, Reflex t)+ => Focus t m a+ -> m (a, Dynamic t FocusSet)+runFocus (Focus x) = do+ rec ((a, focusIds), focusRequests) <- runEventWriterT $ flip runReaderT sel $ runDynamicWriterT x+ sel <- foldDyn f Nothing $ attach (current focusIds) focusRequests+ pure (a, focusIds)+ where+ f :: (FocusSet, First Refocus) -> Maybe FocusId -> Maybe FocusId+ f (fs, rf) mf = case getFirst rf of+ Refocus_Clear -> Nothing+ Refocus_Id fid -> Just fid+ Refocus_Shift n -> if n < 0 && isNothing mf+ then shiftFS fs (OSet.elemAt (unFocusSet fs) 0) n+ else shiftFS fs mf n --- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed--- and backward one tile when Shift+Tab is pressed.-tabNavigation :: (Reflex t, Monad m) => VtyWidget t m (Event t Int)+-- | Runs an action in the focus monad, providing it with information about+-- whether any of the foci created within it are focused.+anyChildFocused+ :: (HasFocus t m, MonadFix m)+ => (Dynamic t Bool -> m a)+ -> m a+anyChildFocused f = do+ fid <- focusedId+ rec (a, fs) <- subFoci (f b)+ let b = liftA2 (\foc s -> case foc of+ Nothing -> False+ Just f' -> OSet.member f' $ unFocusSet s) fid fs+ pure a++-- ** Focus controls++-- | Request focus be shifted backward and forward based on tab presses. <Tab>+-- shifts focus forward and <Shift+Tab> shifts focus backward.+tabNavigation :: (Reflex t, HasInput t m, HasFocus t m) => m () tabNavigation = do fwd <- fmap (const 1) <$> key (V.KChar '\t') back <- fmap (const (-1)) <$> key V.KBackTab- return $ leftmost [fwd, back]+ requestFocus $ Refocus_Shift <$> leftmost [fwd, back] --- | Captures the click event in a 'VtyWidget' context and returns it. Useful for--- requesting focus when using 'tile'.-clickable- :: (Reflex t, Monad m)- => VtyWidget t m a- -> VtyWidget t m (Event t (), a)-clickable child = do- click <- mouseDown V.BLeft- a <- child- return (() <$ click, a)+-- * Layout+--+-- $layout+-- The layout monad keeps track of a tree of elements, each having its own+-- layout constraints and orientation. Given the available rendering space, it+-- computes a layout solution and provides child elements with their particular+-- layout solution (the width and height of their rendering space).+--+-- Complex layouts are built up though some combination of:+--+-- - 'axis', which lays out its children in a particular orientation, and+-- - 'region', which "claims" some part of the screen according to its constraints+-- --- | Retrieve the current orientation of a 'Layout'-askOrientation :: Monad m => Layout t m (Dynamic t Orientation)-askOrientation = Layout $ asks _layoutCtx_orientation+-- ** Layout restrictions +-- *** Constraints+ -- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation') data Constraint = Constraint_Fixed Int | Constraint_Min Int deriving (Show, Read, Eq, Ord) --- | Compute the size of each widget "@k@" based on the total set of 'Constraint's-computeSizes- :: Ord k- => Int- -> Map k (a, Constraint)- -> Map k (a, Int)-computeSizes available constraints =- let minTotal = sum $ ffor (Map.elems constraints) $ \case- (_, Constraint_Fixed n) -> n- (_, Constraint_Min n) -> n- leftover = max 0 (available - minTotal)- numStretch = Map.size $ Map.filter (isMin . snd) constraints- szStretch = floor $ leftover % (max numStretch 1)- adjustment = max 0 $ available - minTotal - szStretch * numStretch- in snd $ Map.mapAccum (\adj (a, c) -> case c of- Constraint_Fixed n -> (adj, (a, n))- Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints+-- | Shorthand for constructing a fixed constraint+fixed+ :: Reflex t+ => Dynamic t Int+ -> Dynamic t Constraint+fixed = fmap Constraint_Fixed++-- | Shorthand for constructing a minimum size constraint+stretch+ :: Reflex t+ => Dynamic t Int+ -> Dynamic t Constraint+stretch = fmap Constraint_Min++-- | Shorthand for constructing a constraint of no minimum size+flex+ :: Reflex t+ => Dynamic t Constraint+flex = pure $ Constraint_Min 0++-- *** Orientation++-- | The main-axis orientation of a 'Layout' widget+data Orientation = Orientation_Column+ | Orientation_Row+ deriving (Show, Read, Eq, Ord)++-- | Create a row-oriented 'axis'+row+ :: (Reflex t, MonadFix m, HasLayout t m)+ => m a+ -> m a+row = axis (pure Orientation_Row) flex++-- | Create a column-oriented 'axis'+col+ :: (Reflex t, MonadFix m, HasLayout t m)+ => m a+ -> m a+col = axis (pure Orientation_Column) flex++-- ** Layout management data++-- | A collection of information related to the layout of the screen. The root+-- node is a "parent" widget, and the contents of the 'LayoutForest' are its+-- children.+data LayoutTree a = LayoutTree a (LayoutForest a)+ deriving (Show)++-- | An ordered, indexed collection of 'LayoutTree's representing information+-- about the children of some widget.+newtype LayoutForest a = LayoutForest { unLayoutForest :: OMap NodeId (LayoutTree a) }+ deriving (Show)++instance Semigroup (LayoutForest a) where+ LayoutForest a <> LayoutForest b = LayoutForest $ a OMap.|<> b++instance Monoid (LayoutForest a) where+ mempty = LayoutForest OMap.empty++-- | Perform a lookup by 'NodeId' in a 'LayoutForest'+lookupLF :: NodeId -> LayoutForest a -> Maybe (LayoutTree a)+lookupLF n (LayoutForest a) = OMap.lookup n a++-- | Create a 'LayoutForest' with one element+singletonLF :: NodeId -> LayoutTree a -> LayoutForest a+singletonLF n t = LayoutForest $ OMap.singleton (n, t)++-- | Produce a 'LayoutForest' from a list. The order of the list is preserved.+fromListLF :: [(NodeId, LayoutTree a)] -> LayoutForest a+fromListLF = LayoutForest . OMap.fromList++-- | Extract the information at the root of a 'LayoutTree'+rootLT :: LayoutTree a -> a+rootLT (LayoutTree a _) = a++-- | Extract the child nodes of a 'LayoutTree'+childrenLT :: LayoutTree a -> LayoutForest a+childrenLT (LayoutTree _ a) = a++-- | Produce a layout solution given a starting orientation, the overall screen+-- size, and a set of constraints.+solve+ :: Orientation+ -> Region+ -> LayoutForest (Constraint, Orientation)+ -> LayoutTree (Region, Orientation)+solve o0 r0 (LayoutForest cs) =+ let a = map (\(x, t@(LayoutTree (c, _) _)) -> ((x, t), c)) $ OMap.assocs cs+ extent = case o0 of+ Orientation_Row -> _region_width r0+ Orientation_Column -> _region_height r0+ sizes = computeEdges $ computeSizes extent a+ chunks = [ (nodeId, solve o1 r1 f)+ | ((nodeId, LayoutTree (_, o1) f), sz) <- sizes+ , let r1 = chunk o0 r0 sz+ ]+ in LayoutTree (r0, o0) $ fromListLF chunks where+ computeEdges :: [(a, Int)] -> [(a, (Int, Int))]+ computeEdges = ($ []) . fst . foldl (\(m, offset) (a, sz) ->+ (((a, (offset, sz)) :) . m, sz + offset)) (id, 0)+ computeSizes+ :: Int+ -> [(a, Constraint)]+ -> [(a, Int)]+ computeSizes available constraints =+ -- The minimum amount of space we need. Calculated by adding up all of+ -- the fixed size items and all the minimum sizes of stretchable items+ let minTotal = sum $ ffor constraints $ \case+ (_, Constraint_Fixed n) -> n+ (_, Constraint_Min n) -> n+ -- The leftover space is the area we can allow stretchable items to+ -- expand into+ leftover = max 0 (available - minTotal)+ -- The number of stretchable items that will try to share some of the+ -- leftover space+ numStretch = length $ filter (isMin . snd) constraints+ -- Space to allocate to the stretchable items (this is the same for all+ -- items and there may still be additional leftover space that will have+ -- to be unevenly distributed)+ szStretch = floor $ leftover % max numStretch 1+ -- Remainder of available space after even distribution. This extra space+ -- will be distributed to as many stretchable widgets as possible.+ adjustment = max 0 $ available - minTotal - szStretch * numStretch+ in snd $ mapAccumL (\adj (a, c) -> case c of+ Constraint_Fixed n -> (adj, (a, n))+ Constraint_Min n -> (max 0 (adj-1), (a, n + szStretch + signum adj))) adjustment constraints isMin (Constraint_Min _) = True isMin _ = False -computeEdges :: (Ord k) => Map k (a, Int) -> Map k (a, (Int, Int))-computeEdges = fst . Map.foldlWithKey' (\(m, offset) k (a, sz) ->- (Map.insert k (a, (offset, sz)) m, sz + offset)) (Map.empty, 0)+-- | Produce a 'Region' given a starting orientation and region, and the offset+-- and main-axis size of the chunk.+chunk :: Orientation -> Region -> (Int, Int) -> Region+chunk o r (offset, sz) = case o of+ Orientation_Column -> r+ { _region_top = _region_top r + offset+ , _region_height = sz+ }+ Orientation_Row -> r+ { _region_left = _region_left r + offset+ , _region_width = sz+ } +-- ** The layout monad +-- | A class of operations for creating screen layouts.+class Monad m => HasLayout t m | m -> t where+ -- | Starts a parent element in the current layout with the given size+ -- constraint, which lays out its children according to the provided+ -- orientation.+ axis :: Dynamic t Orientation -> Dynamic t Constraint -> m a -> m a+ -- | Creates a child element in the current layout with the given size+ -- constraint, returning the 'Region' that the child element is allocated.+ region :: Dynamic t Constraint -> m (Dynamic t Region)+ -- | Returns the orientation of the containing 'axis'.+ askOrientation :: m (Dynamic t Orientation)++-- | A monad transformer that collects layout constraints and provides a layout+-- solution that satisfies those constraints.+newtype Layout t m a = Layout+ { unLayout :: DynamicWriterT t (LayoutForest (Constraint, Orientation))+ (ReaderT (Dynamic t (LayoutTree (Region, Orientation))) m) a+ }+ deriving+ ( Functor+ , Applicative+ , HasDisplayRegion t+ , Monad+ , MonadFix+ , MonadHold t+ , MonadIO+ , MonadNodeId+ , MonadReflexCreateTrigger t+ , MonadSample t+ , NotReady t+ , PerformEvent t+ , PostBuild t+ , TriggerEvent t+ )++instance MonadTrans (Layout t) where+ lift = Layout . lift . lift++instance MFunctor (Layout t) where+ hoist f = Layout . hoist (hoist f) . unLayout++instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m) where+ runWithReplace (Layout a) e = Layout $ runWithReplace a $ fmap unLayout e+ traverseIntMapWithKeyWithAdjust f m e = Layout $ traverseIntMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e+ traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e+ traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e++-- | Apply a transformation to the context of a child 'Layout' action and run+-- that action+hoistRunLayout+ :: (HasDisplayRegion t m, MonadFix m, Monad n)+ => (m a -> n b)+ -> Layout t m a+ -> Layout t n b+hoistRunLayout f x = do+ solution <- Layout ask+ let orientation = snd . rootLT <$> solution+ lift $ f $ do+ dw <- displayWidth+ dh <- displayHeight+ let reg = Region 0 0 <$> dw <*> dh+ runLayout orientation reg x++instance (HasInput t m, HasDisplayRegion t m, MonadFix m, Reflex t) => HasInput t (Layout t m) where+ localInput = hoistRunLayout . localInput++instance (HasDisplayRegion t m, HasImageWriter t m, MonadFix m) => HasImageWriter t (Layout t m) where+ mapImages f = hoistRunLayout (mapImages f)++instance (HasFocusReader t m, Monad m) => HasFocusReader t (Layout t m)++instance (HasTheme t m, Monad m) => HasTheme t (Layout t m)++instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => HasLayout t (Layout t m) where+ axis o c (Layout x) = Layout $ do+ nodeId <- getNextNodeId+ let dummyParentLayout = LayoutTree (nilRegion, Orientation_Column) mempty+ (result, forest) <- lift $ local (\t -> fromMaybe dummyParentLayout . lookupLF nodeId . childrenLT <$> t) $ runDynamicWriterT x+ tellDyn $ singletonLF nodeId <$> (LayoutTree <$> ((,) <$> c <*> o) <*> forest)+ pure result+ region c = do+ nodeId <- lift getNextNodeId+ Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LayoutTree (c', Orientation_Row) mempty+ solutions <- Layout ask+ pure $ maybe nilRegion (fst . rootLT) . lookupLF nodeId . childrenLT <$> solutions+ askOrientation = Layout $ asks $ fmap (snd . rootLT)++instance (MonadFix m, HasFocus t m) => HasFocus t (Layout t m) where+ makeFocus = lift makeFocus+ requestFocus = lift . requestFocus+ isFocused = lift . isFocused+ focusedId = lift focusedId+ subFoci (Layout x) = Layout $ do+ y <- ask+ ((a, w), sf) <- lift $ lift $ subFoci $ flip runReaderT y $ runDynamicWriterT x+ tellDyn w+ pure (a, sf)++-- | Runs a 'Layout' action, using the given orientation and region to+-- calculate layout solutions.+runLayout+ :: (MonadFix m, Reflex t)+ => Dynamic t Orientation+ -> Dynamic t Region+ -> Layout t m a+ -> m a+runLayout o r (Layout x) = do+ rec (result, w) <- runReaderT (runDynamicWriterT x) solutions+ let solutions = solve <$> o <*> r <*> w+ return result++-- | Initialize and run the layout monad, using all of the available screen space.+initLayout :: (HasDisplayRegion t m, MonadFix m) => Layout t m a -> m a+initLayout f = do+ dw <- displayWidth+ dh <- displayHeight+ let r = Region 0 0 <$> dw <*> dh+ runLayout (pure Orientation_Column) r f++-- * The tile "window manager"+--+-- $tiling+-- Generally HasLayout and HasFocus are used together to build a user+-- interface. These functions check the available screen size and initialize+-- the layout monad with that information, and also initialize the focus monad.++-- | Initialize a 'Layout' and 'Focus' management context, returning the produced 'FocusSet'.+initManager+ :: (HasDisplayRegion t m, Reflex t, MonadHold t m, MonadFix m)+ => Layout t (Focus t m) a+ -> m (a, Dynamic t FocusSet)+initManager =+ runFocus . initLayout++-- | Initialize a 'Layout' and 'Focus' management context.+initManager_+ :: (HasDisplayRegion t m, Reflex t, MonadHold t m, MonadFix m)+ => Layout t (Focus t m) a+ -> m a+initManager_ = fmap fst . initManager++-- ** Layout tiles++-- *** Focusable++-- | A widget that is focusable and occupies a layout region based on the+-- provided constraint. Returns the 'FocusId' allowing for manual focus+-- management.+tile'+ :: (MonadFix m, Reflex t, HasInput t m, HasFocus t m, HasLayout t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)+ => Dynamic t Constraint+ -> m a+ -> m (FocusId, a)+tile' c w = do+ fid <- makeFocus+ r <- region c+ parentFocused <- isFocused fid+ rec (click, result, childFocused) <- pane r focused $ anyChildFocused $ \childFoc -> do+ m <- mouseDown V.BLeft+ x <- w+ pure (m, x, childFoc)+ let focused = (||) <$> parentFocused <*> childFocused+ requestFocus $ Refocus_Id fid <$ click+ pure (fid, result)++-- | A widget that is focusable and occupies a layout region based on the+-- provided constraint.+tile+ :: (MonadFix m, Reflex t, HasInput t m, HasFocus t m, HasLayout t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)+ => Dynamic t Constraint+ -> m a+ -> m a+tile c = fmap snd . tile' c++-- *** Unfocusable++-- | A widget that is not focusable and occupies a layout region based on the+-- provided constraint.+grout+ :: (Reflex t, HasLayout t m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)+ => Dynamic t Constraint+ -> m a+ -> m a+grout c w = do+ r <- region c+ pane r (pure True) w
+ src/Reflex/Vty/Widget/Split.hs view
@@ -0,0 +1,92 @@+{-|+ Description: Widgets that split the display vertically or horizontally.+-}+module Reflex.Vty.Widget.Split where++import Control.Applicative+import Control.Monad.Fix+import Graphics.Vty as V+import Reflex+import Reflex.Vty.Widget+import Reflex.Vty.Widget.Input.Mouse++-- | A split of the available space into two parts with a draggable separator.+-- Starts with half the space allocated to each, and the first pane has focus.+-- Clicking in a pane switches focus.+splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)+ => m ()+ -> m a+ -> m b+ -> m (a,b)+splitVDrag wS wA wB = do+ dh <- displayHeight+ dw <- displayWidth+ h0 <- sample $ current dh -- TODO+ dragE <- drag V.BLeft+ let splitter0 = h0 `div` 2+ rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter]+ splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter]+ splitterFrac <- holdDyn ((1::Double) / 2) $ ffor (attach (current dh) (fst <$> dragSplitter)) $ \(h, x) ->+ fromIntegral x / max 1 (fromIntegral h)+ let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $+ \(splitterY, Drag (_, fromY) (_, toY) _ _ end) ->+ if splitterY == fromY then Just (toY, end) else Nothing+ regA = Region 0 0 <$> dw <*> splitterPos+ regS = Region 0 <$> splitterPos <*> dw <*> 1+ regB = Region 0 <$> (splitterPos + 1) <*> dw <*> (dh - splitterPos - 1)+ resizeSplitter = ffor (attach (current splitterFrac) (updated dh)) $+ \(frac, h) -> round (frac * fromIntegral h)+ focA <- holdDyn True $ leftmost+ [ True <$ mA+ , False <$ mB+ ]+ (mA, rA) <- pane regA focA $ withMouseDown wA+ pane regS (pure False) wS+ (mB, rB) <- pane regB (not <$> focA) $ withMouseDown wB+ return (rA, rB)+ where+ withMouseDown x = do+ m <- mouseDown V.BLeft+ x' <- x+ return (m, x')++-- | A plain split of the available space into vertically stacked panes.+-- No visual separator is built in here.+splitV :: (Reflex t, Monad m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)+ => Dynamic t (Int -> Int)+ -- ^ Function used to determine size of first pane based on available size+ -> Dynamic t (Bool, Bool)+ -- ^ How to focus the two sub-panes, given that we are focused.+ -> m a+ -- ^ Widget for first pane+ -> m b+ -- ^ Widget for second pane+ -> m (a,b)+splitV sizeFunD focD wA wB = do+ dw <- displayWidth+ dh <- displayHeight+ let regA = Region 0 0 <$> dw <*> (sizeFunD <*> dh)+ regB = Region 0 <$> (_region_height <$> regA) <*> dw <*> liftA2 (-) dh (_region_height <$> regA)+ ra <- pane regA (fst <$> focD) wA+ rb <- pane regB (snd <$> focD) wB+ return (ra,rb)++-- | A plain split of the available space into horizontally stacked panes.+-- No visual separator is built in here.+splitH :: (Reflex t, Monad m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)+ => Dynamic t (Int -> Int)+ -- ^ Function used to determine size of first pane based on available size+ -> Dynamic t (Bool, Bool)+ -- ^ How to focus the two sub-panes, given that we are focused.+ -> m a+ -- ^ Widget for first pane+ -> m b+ -- ^ Widget for second pane+ -> m (a,b)+splitH sizeFunD focD wA wB = do+ dw <- displayWidth+ dh <- displayHeight+ let regA = Region 0 0 <$> (sizeFunD <*> dw) <*> dh+ regB = Region <$> (_region_width <$> regA) <*> 0 <*> liftA2 (-) dw (_region_width <$> regA) <*> dh+ liftA2 (,) (pane regA (fmap fst focD) wA) (pane regB (fmap snd focD) wB)+
+ src/Reflex/Vty/Widget/Text.hs view
@@ -0,0 +1,106 @@+{-|+ Description: Text- and character-rendering widgets+-}+module Reflex.Vty.Widget.Text where++import Control.Monad.Fix+import Data.Default+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Zipper as TZ+import qualified Graphics.Vty as V+import Reflex+import Reflex.Vty.Widget+import Reflex.Vty.Widget.Input.Mouse++-- | Fill the background with a particular character.+fill :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => Behavior t Char -> m ()+fill bc = do+ dw <- displayWidth+ dh <- displayHeight+ bt <- theme+ let fillImg =+ (\attr w h c -> [V.charFill attr c w h])+ <$> bt+ <*> current dw+ <*> current dh+ <*> bc+ tellImages fillImg++-- | Configuration options for displaying "rich" text+data RichTextConfig t = RichTextConfig+ { _richTextConfig_attributes :: Behavior t V.Attr+ }++instance Reflex t => Default (RichTextConfig t) where+ def = RichTextConfig $ pure V.defAttr+++-- TODO delete this and use new local theming+-- | A widget that displays text with custom time-varying attributes+richText+ :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)+ => RichTextConfig t+ -> Behavior t Text+ -> m ()+richText cfg t = do+ dw <- displayWidth+ let img = (\w a s -> [wrapText w a s])+ <$> current dw+ <*> _richTextConfig_attributes cfg+ <*> t+ tellImages img+ where+ wrapText maxWidth attrs = V.vertCat+ . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0)+ . T.split (=='\n')++-- | Renders text, wrapped to the container width+text+ :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)+ => Behavior t Text+ -> m ()+text t = do+ bt <- theme+ richText (RichTextConfig bt) t++-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those+-- that are hidden)+scrollableText+ :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m)+ => Event t Int+ -- ^ Number of lines to scroll by+ -> Behavior t Text+ -> m (Behavior t (Int, Int))+ -- ^ (Current scroll position, total number of lines)+scrollableText scrollBy t = do+ dw <- displayWidth+ bt <- theme+ let imgs = wrap <$> bt <*> current dw <*> t+ kup <- key V.KUp+ kdown <- key V.KDown+ m <- mouseScroll+ let requestedScroll :: Event t Int+ requestedScroll = leftmost+ [ 1 <$ kdown+ , (-1) <$ kup+ , ffor m $ \case+ ScrollDirection_Up -> (-1)+ ScrollDirection_Down -> 1+ , scrollBy+ ]+ updateLine maxN delta ix = min (max 0 (ix + delta)) maxN+ lineIndex :: Dynamic t Int <- foldDyn (\(maxN, delta) ix -> updateLine (maxN - 1) delta ix) 0 $+ attach (length <$> imgs) requestedScroll+ tellImages $ fmap ((:[]) . V.vertCat) $ drop <$> current lineIndex <*> imgs+ return $ (,) <$> ((+) <$> current lineIndex <*> pure 1) <*> (length <$> imgs)+ where+ wrap attr maxWidth = concatMap (fmap (V.string attr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')++-- | Renders any behavior whose value can be converted to+-- 'String' as text+display+ :: (Reflex t, Monad m, Show a, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)+ => Behavior t a+ -> m ()+display a = text $ T.pack . show <$> a
+ test/Data/Text/ZipperSpec.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Text.ZipperSpec(+ spec+) where++import Prelude++import Test.Hspec++import qualified Data.Map as Map+import qualified Data.Text as T+import Control.Monad++import Data.Text.Zipper+++someSentence = "12345 1234 12"++splitSentenceAtDisplayWidth :: Int -> T.Text -> [(T.Text, Bool)]+splitSentenceAtDisplayWidth w t = splitWordsAtDisplayWidth w (wordsWithWhitespace t)++spec :: Spec+spec =+ describe "Zipper" $ do+ it "wordsWithWhitespace" $ do+ wordsWithWhitespace "" `shouldBe` []+ wordsWithWhitespace "😱😱😱" `shouldBe` ["😱😱😱"]+ wordsWithWhitespace "abcd efgf f" `shouldBe` ["abcd ","efgf ", "f"]+ wordsWithWhitespace "aoeu " `shouldBe` ["aoeu "]+ it "splitWordsAtDisplayWidth" $ do+ fmap fst (splitSentenceAtDisplayWidth 5 "123456") `shouldBe` ["12345","6"]+ fmap fst (splitSentenceAtDisplayWidth 5 "12345 6") `shouldBe` ["12345","6"]+ fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234","56"]+ fmap fst (splitSentenceAtDisplayWidth 5 "12345678912345") `shouldBe` ["12345","67891","2345"]+ fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234 "," 56"]+ fmap fst (splitSentenceAtDisplayWidth 8 "1 2 3 4 5 6 7 8 9 1") `shouldBe` ["1 2 3 4","5 6 7 8", "9 1"]+ it "wrapWithOffsetAndAlignment" $ do+ wrapWithOffsetAndAlignment TextAlignment_Left 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]+ wrapWithOffsetAndAlignment TextAlignment_Right 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 1), (WrappedLine "12" False 3)]+ wrapWithOffsetAndAlignment TextAlignment_Center 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 1)]+ wrapWithOffsetAndAlignment TextAlignment_Left 5 1 someSentence `shouldBe` [(WrappedLine "1234" False 0), (WrappedLine "5" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]++ -- leading spaces and offset case+ wrapWithOffsetAndAlignment TextAlignment_Left 5 1 (" " <> someSentence) `shouldBe` [(WrappedLine " " True 0), (WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]+ it "eolSpacesToLogicalLines" $ do+ eolSpacesToLogicalLines+ [+ [ (WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3) ]+ , [ (WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3) ]+ ]+ `shouldBe`+ [+ [ ("😱",1) ]+ , [ ("😱",2), ("😱",3) ]+ , [ ("aa",1) ]+ , [ ("aa",2) ]+ , [ ("aa",3) ]+ ]+ it "offsetMapWithAlignmentInternal" $ do+ offsetMapWithAlignmentInternal+ [+ [ (WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3) ]+ , [ (WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3) ]+ ]+ `shouldBe`+ Map.fromList+ [ (0, (1,0))+ , (1, (2,2)) -- jump by 1 for char and 1 for space+ , (2, (3,3)) -- jump by 1 for char+ , (3, (1,5)) -- jump by 1 for char and 1 for newline+ , (4, (2,8)) -- jump by 2 for char and 1 for space+ , (5, (3,11)) -- jump by 2 for char and 1 for space+ ]+ it "displayLines - cursorPos" $ do+ let+ dl0 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "")+ dl1 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu")+ dl2 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n")+ dl3 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "0123456789")+ dl4 = displayLinesWithAlignment TextAlignment_Right 10 () () (insertChar 'a' $ fromText "aoeu")+ dl5 = displayLinesWithAlignment TextAlignment_Right 10 () () (left $ insertChar 'a' $ fromText "aoeu")+ dl6 = displayLinesWithAlignment TextAlignment_Right 10 () () (deleteLeft $ insertChar 'a' $ fromText "aoeu")+ _displayLines_cursorPos dl0 `shouldBe` (0,0)+ _displayLines_cursorPos dl1 `shouldBe` (4,0)+ _displayLines_cursorPos dl2 `shouldBe` (0,1)+ _displayLines_cursorPos dl3 `shouldBe` (0,1)+ _displayLines_cursorPos dl4 `shouldBe` (5,0)+ _displayLines_cursorPos dl5 `shouldBe` (4,0)+ _displayLines_cursorPos dl6 `shouldBe` (4,0)+ it "displayLines - offsetMap" $ do+ let+ dl0 = displayLinesWithAlignment TextAlignment_Left 5 () () (end $ fromText "aoeku")+ _displayLines_cursorPos dl0 `shouldBe` (0,1)+ Map.size (_displayLines_offsetMap dl0) `shouldBe` 2 -- cursor character is on second line+ it "displayLinesWithAlignment - spans" $ do+ let+ someText = top $ fromText "0123456789abcdefgh"+ -- outer span length should be invariant when changing TextAlignment and CursorPosition+ forM_ [0..4] $ \x -> do+ forM_ [TextAlignment_Left, TextAlignment_Center, TextAlignment_Right] $ \ta -> do+ let t = rightN x $ someText+ length (_displayLines_spans $ (displayLinesWithAlignment ta 5 () () t)) `shouldBe` 4+ length (_displayLines_spans $ (displayLinesWithAlignment ta 10 () () t)) `shouldBe` 2
+ test/Spec.hs view
@@ -0,0 +1,15 @@+-- hspec auto-discovery stuff+-- does not work with current CircleCI image so instead we do it manually for now+-- {-# OPTIONS_GHC -F -pgmF hspec-discover #-}+++import Test.Hspec++import qualified Data.Text.ZipperSpec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "Data.Text.ZipperSpec" Data.Text.ZipperSpec.spec