diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,28 +1,33 @@ # Revision history for reflex-vty +## 0.1.4.0 +* ([#15](https://github.com/reflex-frp/reflex-vty/pull/15)) Add `PostBuild` instance for `Layout`. +* ([#17](https://github.com/reflex-frp/reflex-vty/pull/17)) Add `splitH` to implement horizontal functionality of `splitV`. +* ([#19](https://github.com/reflex-frp/reflex-vty/pull/19)) Add `boxTitle`: a box with a title. +* ([#19](https://github.com/reflex-frp/reflex-vty/pull/19)) Update the text editing example to use `boxTitle`. +* ([#21](https://github.com/reflex-frp/reflex-vty/pull/21)) Fix bug in `drag` that caused dragging with different mouse button to trigger the click event. +* ([#22](https://github.com/reflex-frp/reflex-vty/pull/22)) Add support for GHC 8.8. + ## 0.1.3.0 -* Add `mouseScroll` to capture scroll wheel events -* Add `scrollableText`: a text display widget that can be scrolled using the mouse or keyboard -* Add widget to the example executable that displays scrollable text +* Add `mouseScroll` to capture scroll wheel events. +* Add `scrollableText`: a text display widget that can be scrolled using the mouse or keyboard. +* Add widget to the example executable that displays scrollable text. ## 0.1.2.1 -* Add `keyCombo` function (single-key-combination version of `keyCombos`) -* Use upstream `NotReady` instances instead of orphans defined in this package if reflex-0.6.3 is available +* Add `keyCombo` function (single-key-combination version of `keyCombos`). +* Use upstream `NotReady` instances instead of orphans defined in this package if reflex-0.6.3 is available. ## 0.1.2.0 -* Allow TextZipper contents to be tranformed before being displayed -* Fix bug in `row` orientation -* Handle wrapping of lines containing fullwidth unicode characters in `textInput` +* Allow `TextZipper` contents to be transformed before being displayed. +* Fix bug in `row` orientation. +* Handle wrapping of lines containing full-width unicode characters in `textInput`. ## 0.1.1.1 - -* Bump minimum version of reflex +* Bump minimum version of reflex. ## 0.1.1.0 - -* Set version bounds in cabal file -* Add travis CI config +* Set version bounds in cabal file. +* Add travis CI config. ## 0.1.0.0 - * Initial release diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -33,10 +33,9 @@ From the reflex-vty project directory: ```bash +# nix-shell -p cabal-install binutils icu # for nix users cabal new-configure cabal new-build # to build the library and example cabal new-repl # to enter a repl for the library cabal new-repl example # to enter a repl for the example executable ``` - - diff --git a/reflex-vty.cabal b/reflex-vty.cabal --- a/reflex-vty.cabal +++ b/reflex-vty.cabal @@ -1,5 +1,5 @@ name: reflex-vty -version: 0.1.3.0 +version: 0.1.4.0 synopsis: Reflex FRP host and widgets for vty applications description: Host and widget library for Reflex-based FRP applications @@ -18,7 +18,7 @@ ChangeLog.md extra-doc-files: doc/welcome.gif , doc/tasks.png -tested-with: GHC ==8.6.5 || ==8.4.4 +tested-with: GHC ==8.8.3 || ==8.6.5 || ==8.4.4 library exposed-modules: Reflex.Vty @@ -32,7 +32,7 @@ , Reflex.Spider.Orphans , Control.Monad.NodeId build-depends: - base >= 4.10.0 && < 4.13, + base >= 4.10.0 && < 4.14, bimap >= 0.3.3 && < 0.4, containers >= 0.5.0 && < 0.7, mtl >= 2.2.2 && < 2.3, @@ -44,11 +44,11 @@ text-icu >= 0.7 && < 0.8, dependent-sum >= 0.3 && < 0.7, exception-transformers >= 0.4.0 && < 0.5, - primitive >= 0.6.3 && < 0.7, + primitive >= 0.6.3 && < 0.8, ref-tf >= 0.4.0 && < 0.5, - reflex >= 0.6.2 && < 0.7, - time >= 1.8.0 && < 1.9, - vty >= 5.21 && < 5.26 + reflex >= 0.6.2 && < 0.8, + time >= 1.8.0 && < 1.10, + vty >= 5.21 && < 5.29 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/src-bin/example.hs b/src-bin/example.hs --- a/src-bin/example.hs +++ b/src-bin/example.hs @@ -97,7 +97,8 @@ { _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 = boxStatic roundedBoxStyle $ multilineTextInput cfg + textBox = boxTitle (pure roundedBoxStyle) "Text Edit" $ + multilineTextInput cfg dragBox = boxStatic roundedBoxStyle dragTest in splitVDrag (hRule doubleBoxStyle) textBox dragBox return () diff --git a/src/Reflex/Class/Switchable.hs b/src/Reflex/Class/Switchable.hs --- a/src/Reflex/Class/Switchable.hs +++ b/src/Reflex/Class/Switchable.hs @@ -4,7 +4,6 @@ -} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} module Reflex.Class.Switchable where @@ -26,5 +25,5 @@ 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) + <$> switching a (fmap fst e) + <*> switching b (fmap snd e) diff --git a/src/Reflex/Vty/Host.hs b/src/Reflex/Vty/Host.hs --- a/src/Reflex/Vty/Host.hs +++ b/src/Reflex/Vty/Host.hs @@ -28,8 +28,7 @@ import Control.Monad.Primitive (PrimMonad) import Control.Monad.Ref (MonadRef, Ref, readRef) import Data.Dependent.Sum (DSum ((:=>))) -import Data.IORef (IORef) -import Data.IORef (readIORef) +import Data.IORef (IORef, readIORef) import Data.Maybe (catMaybes) import Reflex @@ -76,7 +75,7 @@ type VtyApp t m = MonadVtyApp t m => DisplayRegion -- ^ The initial display size (updates to this come as events) - -> Event t (V.Event) + -> Event t V.Event -- ^ Vty input events. -> m (VtyResult t) -- ^ The output of the 'VtyApp'. The application runs in a context that, @@ -115,7 +114,7 @@ -- processed. events <- liftIO newChan - displayRegion0 <- V.displayBounds $ V.outputIface vty + displayRegion0 <- liftIO $ V.displayBounds $ V.outputIface vty -- Run the vty "guest" application, providing the appropriate context. The -- result is a 'VtyResult', and a 'FireCommand' that will be used to @@ -179,7 +178,7 @@ triggerInvocation = TriggerInvocation ne $ return () -- Write our input event's 'EventTrigger' with the newly created -- 'TriggerInvocation' value to the queue of events. - writeChan events $ [triggerRef :=> triggerInvocation] + writeChan events [triggerRef :=> triggerInvocation] -- The main application loop. We wait for new events, fire those that -- have subscribers, and update the display. If we detect a shutdown diff --git a/src/Reflex/Vty/Widget.hs b/src/Reflex/Vty/Widget.hs --- a/src/Reflex/Vty/Widget.hs +++ b/src/Reflex/Vty/Widget.hs @@ -43,7 +43,9 @@ , mouseScroll , pane , splitV + , splitH , splitVDrag + , boxTitle , box , boxStatic , RichTextConfig(..) @@ -69,8 +71,9 @@ import Control.Applicative (liftA2) import Control.Monad.Fix (MonadFix) -import Control.Monad.Reader -import Control.Monad.Trans (lift) +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 @@ -141,7 +144,7 @@ instance MonadNodeId m => MonadNodeId (VtyWidget t m) where getNextNodeId = VtyWidget $ do - lift $ lift $ getNextNodeId + lift $ lift getNextNodeId -- | Runs a 'VtyWidget' with a given context runVtyWidget @@ -338,13 +341,13 @@ f Nothing = \case V.EvMouseDown x y btn' mods | btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods False - | otherwise -> Nothing + | otherwise -> Nothing _ -> Nothing f (Just (Drag from _ _ mods end)) = \case V.EvMouseDown x y btn' mods' - | end -> Just $ Drag (x,y) (x,y) btn' mods' False - | btn == btn' -> Just $ Drag from (x,y) btn mods' False - | otherwise -> Nothing -- Ignore other buttons. + | 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 @@ -474,6 +477,35 @@ 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. @@ -491,7 +523,7 @@ 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)) + 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 @@ -563,12 +595,13 @@ roundedBoxStyle :: BoxStyle roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│' --- | Draws a box in the provided style and a child widget inside of that box -box :: (Monad m, Reflex t, MonadNodeId m) +-- | 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 -box boxStyle child = do +boxTitle boxStyle title child = do dh <- displayHeight dw <- displayWidth let boxReg = DynRegion (pure 0) (pure 0) dw dh @@ -583,7 +616,8 @@ bottom = top + height - 1 sides = [ withinImage (Region (left + 1) top (width - 2) 1) $ - V.charFill V.defAttr (_boxStyle_n style) (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) $ @@ -602,6 +636,23 @@ 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 diff --git a/src/Reflex/Vty/Widget/Layout.hs b/src/Reflex/Vty/Widget/Layout.hs --- a/src/Reflex/Vty/Widget/Layout.hs +++ b/src/Reflex/Vty/Widget/Layout.hs @@ -78,6 +78,7 @@ , MonadReflexCreateTrigger t , HasDisplaySize t , MonadNodeId + , PostBuild t ) instance MonadTrans (Layout t) where