reflex-vty (empty) → 0.1.0.0
raw patch · 18 files changed
+2265/−0 lines, 18 filesdep +basedep +bimapdep +containerssetup-changedbinary-added
Dependencies added: base, bimap, containers, data-default, dependent-map, dependent-sum, exception-transformers, mtl, primitive, ref-tf, reflex, reflex-vty, stm, text, time, transformers, vty
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +27/−0
- Setup.hs +2/−0
- doc/tasks.png binary
- doc/welcome.gif binary
- reflex-vty.cabal +65/−0
- src-bin/example.hs +210/−0
- src/Control/Monad/NodeId.hs +81/−0
- src/Data/Text/Zipper.hs +321/−0
- src/Reflex/Class/Switchable.hs +30/−0
- src/Reflex/Spider/Orphans.hs +20/−0
- src/Reflex/Vty.hs +28/−0
- src/Reflex/Vty/Host.hs +236/−0
- src/Reflex/Vty/Widget.hs +630/−0
- src/Reflex/Vty/Widget/Input.hs +140/−0
- src/Reflex/Vty/Widget/Input/Text.hs +156/−0
- src/Reflex/Vty/Widget/Layout.hs +284/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for reflex-vty++## 0.1.0.0++* Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Obsidian Systems LLC++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Obsidian Systems LLC nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,27 @@+# reflex-vty++## A library for building functional reactive terminal applications++++Feature requests, pull requests, and other feedback are welcome and appreciated. This library+is still experimental, so big changes are possible!+### How to Build++#### With reflex-platform++Enter a nix-shell for the project:+```bash+git clone git@github.com:reflex-frp/reflex-platform+git clone git@gitlab.com:obsidian.systems/reflex-vty+cd reflex-vty+../reflex-platform/scripts/work-on ghc ./.+```++From within the nix-shell you can:+* Run the example: `cabal repl example`+* Load the library in the repl: `cabal repl reflex-vty`+* Build the example executable: `cabal build example`+* Build the docs: `cabal haddock`+* Run ghcid for immediate compiler feedback when you save a .hs file: `ghcid -c "cabal repl reflex-vty --ghc-options=-Wall"`+* etc.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ doc/tasks.png view
binary file changed (absent → 12265 bytes)
+ doc/welcome.gif view
binary file changed (absent → 467168 bytes)
+ reflex-vty.cabal view
@@ -0,0 +1,65 @@+name: reflex-vty+version: 0.1.0.0+synopsis: Reflex FRP host and widgets for vty applications+description:+ Host and widget library for Reflex-based FRP applications+ .+ <<./doc/welcome.gif>>+license: BSD3+license-file: LICENSE+author: Obsidian Systems LLC+maintainer: maintainer@obsidian.systems+category: FRP+build-type: Simple+cabal-version: >=1.18+extra-source-files: README.md+ ChangeLog.md+extra-doc-files: doc/welcome.gif+ , doc/tasks.png++library+ exposed-modules: Reflex.Vty+ , Reflex.Vty.Host+ , Reflex.Vty.Widget+ , Reflex.Vty.Widget.Input+ , Reflex.Vty.Widget.Input.Text+ , Reflex.Vty.Widget.Layout+ , Data.Text.Zipper+ , Reflex.Class.Switchable+ , Reflex.Spider.Orphans+ , Control.Monad.NodeId+ build-depends:+ base <= 4.13,+ bimap,+ containers,+ data-default,+ dependent-map,+ dependent-sum,+ exception-transformers,+ mtl,+ primitive,+ ref-tf,+ reflex >= 0.6.1,+ stm,+ text,+ time,+ transformers,+ vty+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++executable example+ hs-source-dirs: src-bin+ main-is: example.hs+ ghc-options: -threaded+ build-depends:+ base,+ containers,+ reflex,+ reflex-vty,+ text,+ time,+ transformers,+ vty+ default-language: Haskell2010
+ src-bin/example.hs view
@@ -0,0 +1,210 @@+{-# 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.Misc+import Data.Map (Map)+import Data.Maybe+import qualified Data.Map as Map+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++data Example = Example_TextEditor+ | Example_Todo+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++main :: IO ()+main = mainWidget $ do+ 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"+ return $ leftmost+ [ Left Example_Todo <$ a+ , Left Example_TextEditor <$ b+ ]+ 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+ Right () -> buttons+ return $ fforMaybe inp $ \case+ V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()+ _ -> Nothing++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+ 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)+ 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 = boxStatic roundedBoxStyle $ 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+ }+ deriving (Show, Read, Eq, Ord)++data TodoOutput t = TodoOutput+ { _todoOutput_todo :: Dynamic t Todo+ , _todoOutput_delete :: Event t ()+ , _todoOutput_height :: Dynamic t Int+ }++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)+ => 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+ }+ where+ backspaceOnEmpty v = \case+ V.EvKey V.KBS _ | T.null v -> Just ()+ _ -> Nothing++todos+ :: forall t m.+ ( MonadHold t m+ , MonadFix m+ , Reflex t+ , Adjustable t m+ , NotReady t m+ , PostBuild t m+ , MonadNodeId m+ )+ => [Todo]+ -> Event t ()+ -> VtyWidget 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+ 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
+ src/Control/Monad/NodeId.hs view
@@ -0,0 +1,81 @@+{-|+Module: Control.Monad.NodeId+Description: Monad providing a supply of unique identifiers+-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+module Control.Monad.NodeId+ ( NodeId+ , MonadNodeId (..)+ , NodeIdT+ , runNodeIdT+ ) where++import Control.Monad.Reader+import Control.Monad.Ref+import Data.IORef++import Reflex+import Reflex.Host.Class++-- | A unique identifier with respect to the 'runNodeIdT' in which it was generated+newtype NodeId = NodeId Integer+ deriving (Eq, Ord, Show)++-- | Members of this class can request new identifiers that are unique in the action+-- in which they are obtained (i.e., all calls to 'getNextNodeId' in a given 'runNodeIdT'+-- will produce unique results)+class Monad m => MonadNodeId m where+ getNextNodeId :: m NodeId+ default getNextNodeId :: (MonadTrans t, MonadNodeId n, m ~ t n) => m NodeId+ getNextNodeId = lift getNextNodeId++-- | A monad transformer that internally keeps track of the next 'NodeId'+newtype NodeIdT m a = NodeIdT { unNodeIdT :: ReaderT (IORef NodeId) m a }+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadFix+ , MonadHold t+ , MonadIO+ , MonadReflexCreateTrigger t+ , MonadSample t+ , MonadTrans+ , NotReady t+ , PerformEvent t+ , PostBuild t+ , TriggerEvent t+ , MonadRef+ )++instance MonadNodeId m => MonadNodeId (ReaderT x m)+instance MonadNodeId m => MonadNodeId (BehaviorWriterT t x m)+instance MonadNodeId m => MonadNodeId (DynamicWriterT t x m)+instance MonadNodeId m => MonadNodeId (EventWriterT t x m)+instance MonadNodeId m => MonadNodeId (TriggerEventT t m)+instance MonadNodeId m => MonadNodeId (PostBuildT t m)++instance Adjustable t m => Adjustable t (NodeIdT m) where+ runWithReplace (NodeIdT a) e = NodeIdT $ runWithReplace a $ fmap unNodeIdT e+ traverseIntMapWithKeyWithAdjust f m e = NodeIdT $ traverseIntMapWithKeyWithAdjust (\k v -> unNodeIdT $ f k v) m e+ traverseDMapWithKeyWithAdjust f m e = NodeIdT $ traverseDMapWithKeyWithAdjust (\k v -> unNodeIdT $ f k v) m e+ traverseDMapWithKeyWithAdjustWithMove f m e = NodeIdT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unNodeIdT $ f k v) m e++-- | Runs a 'NodeIdT' action+runNodeIdT :: MonadIO m => NodeIdT m a -> m a+runNodeIdT a = do+ ref <- liftIO $ newIORef $ NodeId 0+ runReaderT (unNodeIdT a) ref++instance MonadIO m => MonadNodeId (NodeIdT m) where+ getNextNodeId = NodeIdT $ do+ ref <- ask+ liftIO $ newNodeId ref++newNodeId :: IORef NodeId -> IO NodeId+newNodeId ref = atomicModifyIORef' ref $ \(NodeId n) -> (NodeId $ succ n, NodeId n)
+ src/Data/Text/Zipper.hs view
@@ -0,0 +1,321 @@+{-|+Module: Data.Text.Zipper+Description: A zipper for text documents that allows convenient editing and navigation++'TextZipper' is designed to be help manipulate the contents of a text input field. It keeps track of the logical lines of text (i.e., lines separated by user-entered newlines) and the current cursor position. Several functions are defined in this module to navigate and edit the TextZipper from the cursor position.++'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 FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.Text.Zipper where++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++-- | 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.+-- A "logical" line of input is a line of input up until a user-entered newline+-- character (as compared to a "display" line, which is wrapped to fit within+-- a given viewport width).+data TextZipper = TextZipper+ { _textZipper_linesBefore :: [Text] -- reversed+ , _textZipper_before :: Text+ , _textZipper_after :: Text -- The cursor is on top of the first character of this text+ , _textZipper_linesAfter :: [Text]+ }+ deriving (Show)++instance IsString TextZipper where+ fromString = fromText . T.pack++-- | Move the cursor left one character, if possible+left :: TextZipper -> TextZipper+left = leftN 1++-- | Move the cursor left by the given number of characters, or, if the document+-- isn't long enough, to the beginning of the document+leftN :: Int -> TextZipper -> TextZipper+leftN n z@(TextZipper lb b a la) =+ if T.length b >= n+ then+ let n' = T.length b - n+ in TextZipper lb (T.take n' b) (T.drop n' b <> a) la+ else case lb of+ [] -> home z+ (l:ls) -> leftN (n - T.length b - 1) $ TextZipper ls l "" ((b <> a) : la)++-- | Move the cursor right one character, if possible+right :: TextZipper -> TextZipper+right = rightN 1++-- | Move the character right by the given number of characters, or, if the document+-- isn't long enough, to the end of the document+rightN :: Int -> TextZipper -> TextZipper+rightN n z@(TextZipper lb b a la) =+ if T.length a >= n+ then TextZipper lb (b <> T.take n a) (T.drop n a) la+ else case la of+ [] -> end z+ (l:ls) -> rightN (n - T.length a - 1) $ TextZipper ((b <> a) : lb) "" l ls++-- | Move the cursor up one logical line, if possible+up :: TextZipper -> TextZipper+up z@(TextZipper lb b a la) = case lb of+ [] -> z+ (l:ls) ->+ let (b', a') = T.splitAt (T.length b) l+ in TextZipper ls b' a' ((b <> a) : la)++-- | Move the cursor down one logical line, if possible+down :: TextZipper -> TextZipper+down z@(TextZipper lb b a la) = case la of+ [] -> z+ (l:ls) ->+ let (b', a') = T.splitAt (T.length b) l+ in TextZipper ((b <> a) : lb) b' a' ls++-- | Move the cursor up by the given number of lines+pageUp :: Int -> TextZipper -> TextZipper+pageUp pageSize z = if pageSize <= 0+ then z+ else pageUp (pageSize - 1) $ up z++-- | Move the cursor down by the given number of lines+pageDown :: Int -> TextZipper -> TextZipper+pageDown pageSize z = if pageSize <= 0+ then z+ else pageDown (pageSize - 1) $ down z++-- | Move the cursor to the beginning of the current logical line+home :: TextZipper -> TextZipper+home (TextZipper lb b a la) = TextZipper lb "" (b <> a) la++-- | Move the cursor to the end of the current logical line+end :: TextZipper -> TextZipper+end (TextZipper lb b a la) = TextZipper lb (b <> a) "" la++-- | Move the cursor to the top of the document+top :: TextZipper -> TextZipper+top (TextZipper lb b a la) = case reverse lb of+ [] -> TextZipper [] "" (b <> a) la+ (start:rest) -> TextZipper [] "" start (rest <> [b <> a] <> la)++-- | Insert a character at the current cursor position+insertChar :: Char -> TextZipper -> TextZipper+insertChar i = insert (T.singleton i)++-- | Insert text at the current cursor position+insert :: Text -> TextZipper -> TextZipper+insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of+ [] -> z+ (start:rest) -> case reverse rest of+ [] -> TextZipper lb (b <> start) a la+ (l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la++-- | Delete the character to the left of the cursor+deleteLeft :: TextZipper-> TextZipper+deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of+ Nothing -> case lb of+ [] -> z+ (l:ls) -> TextZipper ls l a la+ Just (b', _) -> TextZipper lb b' a la++-- | Delete the character under/to the right of the cursor+deleteRight :: TextZipper -> TextZipper+deleteRight z@(TextZipper lb b a la) = case T.uncons a of+ Nothing -> case la of+ [] -> z+ (l:ls) -> TextZipper lb b l ls+ Just (_, a') -> TextZipper lb b a' la++-- | Delete a word to the left of the cursor. Deletes all whitespace until it+-- finds a non-whitespace character, and then deletes contiguous non-whitespace+-- characters.+deleteLeftWord :: TextZipper -> TextZipper+deleteLeftWord (TextZipper lb b a la) =+ let b' = T.dropWhileEnd isSpace b+ in if T.null b'+ then case lb of+ [] -> TextZipper [] b' a la+ (l:ls) -> deleteLeftWord $ TextZipper ls l a la+ else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la++-- | 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++-- | The plain text contents of the zipper+value :: TextZipper -> Text+value (TextZipper lb b a la) = T.intercalate "\n" $ mconcat [ reverse lb+ , [b <> a]+ , la+ ]++-- | The empty zipper+empty :: TextZipper+empty = TextZipper [] "" "" []++-- | Constructs a zipper with the given contents. The cursor is placed after+-- the contents.+fromText :: Text -> TextZipper+fromText = flip insert empty++-- | A span of text tagged with some metadata that makes up part of a display+-- line.+data Span tag = Span tag Text+ deriving (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+ }+ deriving (Show)++-- | 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 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+ [ linesBefore+ , [wrapWithOffset width 0 $ b <> a]+ , linesAfter+ ]+ spansBefore = map ((:[]) . Span tag) $ concat linesBefore+ spansAfter = map ((:[]) . Span tag) $ concat 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)+ -- Calculate the number of columns on the cursor's display line before the cursor+ curLineOffset = spansLength 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+ -- 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 1 else curLineOffset + 1+ cursor = Span cursorTag (T.singleton c)+ in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of+ [] -> [[cursor]]+ (l:ls) -> (cursor : l) : ls+ in DisplayLines+ { _displayLines_spans = concat+ [ spansBefore+ , spansCurrentBefore+ , if cursorAfterEOL+ then [ spansCurLineBefore, spansCurLineAfter ]+ else [ spansCurLineBefore <> spansCurLineAfter ]+ , spansCurrentAfter+ , spansAfter+ ]+ , _displayLines_offsetMap = offsets+ , _displayLines_cursorY = sum+ [ length spansBefore+ , length spansCurrentBefore+ , if cursorAfterEOL then 1 else 0+ ]+ }+ where+ initLast :: [a] -> Maybe ([a], a)+ initLast = \case+ [] -> Nothing+ (x:xs) -> case initLast xs of+ 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 -> Int -> Text -> [Text]+wrapWithOffset maxWidth _ _ | maxWidth <= 0 = []+wrapWithOffset maxWidth n xs =+ let (firstLine, rest) = T.splitAt (maxWidth - n) xs+ in firstLine : (fmap (T.take maxWidth) . takeWhile (not . T.null) . iterate (T.drop maxWidth) $ rest)++-- | 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'+-- 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+goToDisplayLinePosition x y dl tz =+ 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:_) -> spansLength s+ in rightN (o + (min displayLineLength x)) $ top tz++-- | Get the length of the text in a set of 'Span's+spansLength :: [Span tag] -> Int+spansLength = sum . map (\(Span _ t) -> T.length t)
+ src/Reflex/Class/Switchable.hs view
@@ -0,0 +1,30 @@+{-|+Module: Reflex.Class.Switchable+Description: A class for things that can be switched on the firing of an event+-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# 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
@@ -0,0 +1,20 @@+{-|+Module: Reflex.Spider.Orphans+Description: Orphan instances for SpiderTimeline and SpiderHost+-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Reflex.Spider.Orphans where++import Reflex+import Reflex.Spider.Internal++-- TODO move this to reflex+instance NotReady (SpiderTimeline x) (SpiderHost x) where+ notReadyUntil _ = pure ()+ notReady = pure ()++instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where+ notReadyUntil _ = pure ()+ notReady = pure ()
+ src/Reflex/Vty.hs view
@@ -0,0 +1,28 @@+{-|+Module: Reflex.Vty+Description: A library for building vty apps with reflex+Copyright : (c) Obsidian Systems LLC+License : GPL-3+Maintainer : maintainer@obsidian.systems+Stability : experimental+Portability : POSIX++<<./doc/tasks.png>>++-}+module Reflex.Vty+ ( module Reflex+ , module Reflex.Vty.Host+ , module Reflex.Vty.Widget+ , module Reflex.Vty.Widget.Input+ , module Reflex.Vty.Widget.Layout+ , module Control.Monad.NodeId+ ) where++import Reflex+import Reflex.Vty.Host+import Reflex.Vty.Widget+import Reflex.Vty.Widget.Input+import Reflex.Vty.Widget.Layout++import Control.Monad.NodeId
+ src/Reflex/Vty/Host.hs view
@@ -0,0 +1,236 @@+{-|+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(..)+ , getDefaultVty+ , runVtyApp+ , runVtyAppWithHandle+ , MonadVtyApp+ , VtyEvent+ ) where++import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.Chan (newChan, readChan, writeChan)+import Control.Exception (onException)+import Control.Monad (forM, forM_, forever)+import Control.Monad.Fix (MonadFix, fix)+import Control.Monad.IO.Class (liftIO, MonadIO)+import Control.Monad.Identity (Identity(..))+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.Maybe (catMaybes)++import Reflex+import Reflex.Host.Class+import Reflex.Spider.Orphans ()+import qualified Graphics.Vty as V+import Graphics.Vty (DisplayRegion)++-- | A synonym for the underlying vty event type from 'Graphics.Vty'. This should+-- probably ultimately be replaced by something defined in this library.+type VtyEvent = V.Event++-- | The output of a 'VtyApp'.+data VtyResult t = VtyResult+ { _vtyResult_picture :: Behavior t V.Picture+ -- ^ The current vty output. 'runVtyAppWithHandle' samples this value every time an+ -- event fires and updates the display.+ , _vtyResult_shutdown :: Event t ()+ -- ^ An event that requests application termination.+ }++-- | The constraints necessary to run a 'VtyApp'. See 'runVtyAppWithHandle' for more+-- on why each of these are necessary and how they can be fulfilled.+type MonadVtyApp t m =+ ( Reflex t+ , MonadHold t m+ , MonadFix m+ , PrimMonad (HostFrame t)+ , ReflexHost t+ , MonadIO (HostFrame t)+ , Ref m ~ IORef+ , Ref (HostFrame t) ~ IORef+ , MonadRef (HostFrame t)+ , NotReady t m+ , TriggerEvent t m+ , PostBuild t m+ , PerformEvent t m+ , MonadIO m+ , MonadIO (Performable m)+ , Adjustable t m+ )++-- | A functional reactive vty application.+type VtyApp t m = MonadVtyApp t m+ => DisplayRegion+ -- ^ The initial display size (updates to this come as events)+ -> Event t (V.Event)+ -- ^ Vty input events.+ -> m (VtyResult t)+ -- ^ The output of the 'VtyApp'. The application runs in a context that,+ -- among other things, allows new events to be created and triggered+ -- ('TriggerEvent'), provides access to an event that fires immediately upon+ -- app instantiation ('PostBuild'), and allows actions to be run upon+ -- occurrences of events ('PerformEvent').++-- | Runs a 'VtyApp' in a given 'Graphics.Vty.Vty'.+runVtyAppWithHandle+ :: V.Vty+ -- ^ A 'Graphics.Vty.Vty' handle.+ -> (forall t m. VtyApp t m)+ -- ^ A functional reactive vty application.+ -> IO ()+runVtyAppWithHandle vty vtyGuest = flip onException (V.shutdown vty) $++ -- We are using the 'Spider' implementation of reflex. Running the host+ -- allows us to take actions on the FRP timeline. The scoped type signature+ -- specifies that our host runs on the Global timeline.+ -- For more information, see 'Reflex.Spider.Internal.runSpiderHost'.+ (runSpiderHost :: SpiderHost Global a -> IO a) $ do++ -- Create an 'Event' and a "trigger" reference for that event. The trigger+ -- reference can be used to determine whether anyone is "subscribed" to+ -- that 'Event' and, therefore, whether we need to bother performing any+ -- updates when the 'Event' fires.+ -- The 'Event' below will be used to convey vty input events.+ (vtyEvent, vtyEventTriggerRef) <- newEventWithTriggerRef++ -- Create the "post-build" event and associated trigger. This event fires+ -- once, when the application starts.+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef++ -- Create a queue to which we will write 'Event's that need to be+ -- processed.+ events <- liftIO newChan++ displayRegion0 <- 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+ -- trigger events.+ (vtyResult, fc@(FireCommand fire)) <- do+ hostPerformEventT $ -- Allows the guest app to run+ -- 'performEvent', so that actions+ -- (e.g., IO actions) can be run when+ -- 'Event's fire.++ flip runPostBuildT postBuild $ -- Allows the guest app to access to+ -- a "post-build" 'Event'++ flip runTriggerEventT events $ -- Allows the guest app to create new+ -- events and triggers and writes+ -- those triggers to a channel from+ -- which they will be read and+ -- processed.++ vtyGuest displayRegion0 vtyEvent+ -- The guest app is provided the+ -- initial display region and an+ -- 'Event' of vty inputs.++ -- Reads the current value of the 'Picture' behavior and updates the+ -- display with it. This will be called whenever we determine that a+ -- display update is necessary. In this implementation that is when various+ -- events occur.+ let updateVty =+ sample (_vtyResult_picture vtyResult) >>= liftIO . V.update vty++ -- Read the trigger reference for the post-build event. This will be+ -- 'Nothing' if the guest application hasn't subscribed to this event.+ mPostBuildTrigger <- readRef postBuildTriggerRef++ -- When there is a subscriber to the post-build event, fire the event.+ forM_ mPostBuildTrigger $ \postBuildTrigger ->+ fire [postBuildTrigger :=> Identity ()] $ return ()++ -- After firing the post-build event, sample the vty result and update+ -- the display.+ updateVty++ -- Subscribe to an 'Event' of that the guest application can use to+ -- request application shutdown. We'll check whether this 'Event' is firing+ -- to determine whether to terminate.+ shutdown <- subscribeEvent $ _vtyResult_shutdown vtyResult++ -- Fork a thread and continuously get the next vty input event, and then+ -- write the input event to our channel of FRP 'Event' triggers.+ -- The thread is forked here because 'nextEvent' blocks.+ nextEventThread <- liftIO $ forkIO $ forever $ do+ -- Retrieve the next input event.+ ne <- V.nextEvent vty+ let -- The reference to the vty input 'EventTrigger'. This is the trigger+ -- we'd like to associate the input event value with.+ triggerRef = EventTriggerRef vtyEventTriggerRef+ -- Create an event 'TriggerInvocation' with the value that we'd like+ -- the event to have if it is fired. It may not fire with this value+ -- if nobody is subscribed to the 'Event'.+ 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]++ -- The main application loop. We wait for new events, fire those that+ -- have subscribers, and update the display. If we detect a shutdown+ -- request, the application terminates.+ fix $ \loop -> do+ -- Read the next event (blocking).+ ers <- liftIO $ readChan events+ stop <- do+ -- Fire events that have subscribers.+ fireEventTriggerRefs fc ers $+ -- Check if the shutdown 'Event' is firing.+ readEvent shutdown >>= \case+ Nothing -> return False+ Just _ -> return True+ if or stop+ then liftIO $ do -- If we received a shutdown 'Event'+ killThread nextEventThread -- then stop reading input events and+ V.shutdown vty -- call the 'Graphics.Vty.Vty's shutdown command.++ else do -- Otherwise, update the display and loop.+ 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+ :: (Monad (ReadPhase m), MonadIO m)+ => FireCommand t m+ -> [DSum (EventTriggerRef t) TriggerInvocation]+ -> ReadPhase m a+ -> m [a]+ fireEventTriggerRefs (FireCommand fire) ers rcb = do+ mes <- liftIO $+ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do+ me <- readIORef er+ return $ fmap (\e -> e :=> Identity a) me+ a <- fire (catMaybes mes) rcb+ liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb+ return a++-- | Run a 'VtyApp' with a 'Graphics.Vty.Vty' handle with a standard configuration.+runVtyApp+ :: (forall t m. VtyApp t m)+ -> IO ()+runVtyApp app = do+ vty <- getDefaultVty+ runVtyAppWithHandle vty app++-- | Returns the standard vty configuration with mouse mode enabled.+getDefaultVty :: IO V.Vty+getDefaultVty = do+ cfg <- V.standardIOConfig+ V.mkVty $ cfg { V.mouseMode = Just True }
+ src/Reflex/Vty/Widget.hs view
@@ -0,0 +1,630 @@+{-|+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+ , pane+ , splitV+ , splitVDrag+ , box+ , boxStatic+ , RichTextConfig(..)+ , richText+ , text+ , display+ , BoxStyle(..)+ , hyphenBoxStyle+ , singleBoxStyle+ , roundedBoxStyle+ , thickBoxStyle+ , doubleBoxStyle+ , fill+ , hRule+ , KeyCombo+ , key+ , keys+ , keyCombos+ , blank+ ) where++import Control.Applicative (liftA2)+import Control.Monad.Fix (MonadFix)+import Control.Monad.Reader+import Control.Monad.Trans (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 -> 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)++-- | 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 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 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 box in the provided style and a child widget inside of that box+box :: (Monad m, Reflex t, MonadNodeId m)+ => Behavior t BoxStyle+ -> VtyWidget t m a+ -> VtyWidget t m a+box boxStyle 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.charFill V.defAttr (_boxStyle_n style) (width - 2) 1+ , 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 []++-- | 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++-- | 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 ()+blank = return ()
+ src/Reflex/Vty/Widget/Input.hs view
@@ -0,0 +1,140 @@+{-|+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.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++-- | Configuration options for the 'button' widget+data ButtonConfig t = ButtonConfig+ { _buttonConfig_boxStyle :: Behavior t BoxStyle+ , _buttonConfig_focusStyle :: Behavior t BoxStyle+ }++instance Reflex t => Default (ButtonConfig t) where+ def = ButtonConfig (pure singleBoxStyle) (pure thickBoxStyle)++-- | A button widget that contains a sub-widget+button+ :: (Reflex t, Monad m, MonadNodeId m)+ => ButtonConfig t+ -> VtyWidget t m ()+ -> VtyWidget t m (Event t ())+button cfg child = do+ f <- focus+ let style = do+ isFocused <- current f+ if isFocused+ then _buttonConfig_focusStyle cfg+ else _buttonConfig_boxStyle cfg+ box style child+ m <- mouseUp+ k <- key V.KEnter+ return $ leftmost [() <$ k, () <$ m]++-- | A button widget that displays text that can change+textButton+ :: (Reflex t, Monad m, MonadNodeId m)+ => ButtonConfig t+ -> Behavior t Text+ -> VtyWidget 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)+ => ButtonConfig t+ -> Text+ -> VtyWidget t m (Event t ())+textButtonStatic cfg = textButton cfg . pure++-- | A clickable link widget+link+ :: (Reflex t, Monad m)+ => Behavior t Text+ -> VtyWidget t m (Event t MouseUp)+link t = do+ let cfg = RichTextConfig+ { _richTextConfig_attributes = pure $ V.withStyle V.defAttr V.underline+ }+ richText cfg t+ mouseUp++-- | A clickable link widget with a static label+linkStatic+ :: (Reflex t, Monad m)+ => Text+ -> VtyWidget t m (Event t MouseUp)+linkStatic = link . pure++-- | Characters used to render checked and unchecked textboxes+data CheckboxStyle = CheckboxStyle+ { _checkboxStyle_unchecked :: Text+ , _checkboxStyle_checked :: Text+ }++instance Default CheckboxStyle where+ def = checkboxStyleTick++-- | This checkbox style uses an "x" to indicate the checked state+checkboxStyleX :: CheckboxStyle+checkboxStyleX = CheckboxStyle+ { _checkboxStyle_unchecked = "[ ]"+ , _checkboxStyle_checked = "[x]"+ }++-- | This checkbox style uses a unicode tick mark to indicate the checked state+checkboxStyleTick :: CheckboxStyle+checkboxStyleTick = CheckboxStyle+ { _checkboxStyle_unchecked = "[ ]"+ , _checkboxStyle_checked = "[✓]"+ }++-- | Configuration options for a checkbox+data CheckboxConfig t = CheckboxConfig+ { _checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle+ , _checkboxConfig_attributes :: Behavior t V.Attr+ }++instance (Reflex t) => Default (CheckboxConfig t) where+ def = CheckboxConfig+ { _checkboxConfig_checkboxStyle = pure def+ , _checkboxConfig_attributes = pure V.defAttr+ }++-- | A checkbox widget+checkbox+ :: (MonadHold t m, MonadFix m, Reflex t)+ => CheckboxConfig t+ -> Bool+ -> VtyWidget t m (Dynamic t Bool)+checkbox cfg v0 = do+ md <- mouseDown V.BLeft+ mu <- mouseUp+ v <- toggle v0 $ () <$ mu+ depressed <- hold mempty $ leftmost+ [ V.withStyle mempty V.bold <$ md+ , mempty <$ mu+ ]+ let attrs = (<>) <$> (_checkboxConfig_attributes cfg) <*> depressed+ richText (RichTextConfig attrs) $ join . current $ ffor v $ \checked ->+ if checked+ then fmap _checkboxStyle_checked $ _checkboxConfig_checkboxStyle cfg+ else fmap _checkboxStyle_unchecked $ _checkboxConfig_checkboxStyle cfg+ return v
+ src/Reflex/Vty/Widget/Input/Text.hs view
@@ -0,0 +1,156 @@+{-|+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+ ) where++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+import qualified Graphics.Vty as V+import Reflex++import Reflex.Vty.Widget+import Reflex.Vty.Widget.Layout++-- | Configuration options for a 'textInput'. For more information on+-- 'TextZipper', see 'Data.Text.Zipper'.+data TextInputConfig t = TextInputConfig+ { _textInputConfig_initialValue :: TextZipper+ , _textInputConfig_modify :: Event t (TextZipper -> TextZipper)+ , _textInputConfig_tabWidth :: Int+ }++instance Reflex t => Default (TextInputConfig t) where+ def = TextInputConfig empty never 4++-- | The output produced by text input widgets, including the text+-- value and the number of display lines (post-wrapping). Note that some+-- display lines may not be visible due to scrolling.+data TextInput t = TextInput+ { _textInput_value :: Dynamic t Text+ , _textInput_lines :: Dynamic t Int+ }++-- | A widget that allows text input+textInput+ :: (Reflex t, MonadHold t m, MonadFix m)+ => TextInputConfig t+ -> VtyWidget t m (TextInput t)+textInput cfg = do+ i <- input+ f <- focus+ dh <- displayHeight+ dw <- displayWidth+ rec v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)+ [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i+ , _textInputConfig_modify cfg+ , let displayInfo = (,) <$> current rows <*> scrollTop+ in ffor (attach displayInfo click) $ \((dl, st), MouseDown _ (mx, my) _) ->+ 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) <$> dw <*> v <*> cursorAttrs+ img = images . _displayLines_spans <$> rows+ y <- holdUniqDyn $ _displayLines_cursorY <$> rows+ let newScrollTop :: Int -> (Int, Int) -> Int+ newScrollTop st (h, cursorY)+ | cursorY < st = cursorY+ | cursorY >= st + h = cursorY - h + 1+ | otherwise = st+ let hy = attachWith newScrollTop scrollTop $ updated $ zipDyn dh y+ scrollTop <- hold 0 hy+ tellImages $ (\imgs st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> scrollTop+ return $ TextInput+ { _textInput_value = value <$> v+ , _textInput_lines = length . _displayLines_spans <$> rows+ }++-- | A widget that allows multiline text input+multilineTextInput+ :: (Reflex t, MonadHold t m, MonadFix m)+ => TextInputConfig t+ -> VtyWidget t m (TextInput t)+multilineTextInput cfg = do+ i <- input+ textInput $ cfg+ { _textInputConfig_modify = mergeWith (.)+ [ fforMaybe i $ \case+ V.EvKey V.KEnter [] -> Just $ insert "\n"+ _ -> Nothing+ , _textInputConfig_modify cfg+ ]+ }++-- | Wraps a 'textInput' or 'multilineTextInput' in a tile. Uses+-- 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)+ -> Dynamic t Int+ -> Layout t m (TextInput t)+textInputTile txt width = do+ o <- askOrientation+ rec t <- 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]+images = map (V.horizCat . map spanToImage)++-- | Turn a set of display line rows into a single image+image :: [[Span V.Attr]] -> V.Image+image = V.vertCat . images++-- | Turn a 'Span' into an 'Graphics.Vty.Image'+spanToImage :: Span V.Attr -> V.Image+spanToImage (Span attrs t) = V.text' attrs t++-- | Default vty event handler for text inputs+updateTextZipper+ :: Int -- ^ Tab width+ -> Int -- ^ Page size+ -> V.Event -- ^ The vty event to handle+ -> TextZipper -- ^ The zipper to modify+ -> TextZipper+updateTextZipper tabWidth pageSize ev = case ev of+ -- Special characters+ V.EvKey (V.KChar '\t') [] -> tab tabWidth+ -- Regular characters+ V.EvKey (V.KChar k) [] -> insertChar k+ -- Deletion buttons+ V.EvKey V.KBS [] -> deleteLeft+ V.EvKey V.KDel [] -> deleteRight+ -- Key combinations+ V.EvKey (V.KChar 'u') [V.MCtrl] -> const empty+ V.EvKey (V.KChar 'w') [V.MCtrl] -> deleteLeftWord+ -- Arrow keys+ V.EvKey V.KLeft [] -> left+ V.EvKey V.KRight [] -> right+ V.EvKey V.KUp [] -> up+ V.EvKey V.KDown [] -> down+ V.EvKey V.KHome [] -> home+ V.EvKey V.KEnd [] -> end+ V.EvKey V.KPageUp [] -> pageUp pageSize+ V.EvKey V.KPageDown [] -> pageDown pageSize+ _ -> id
+ src/Reflex/Vty/Widget/Layout.hs view
@@ -0,0 +1,284 @@+{-|+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 #-}++module Reflex.Vty.Widget.Layout+ ( Orientation(..)+ , Constraint(..)+ , Layout+ , runLayout+ , TileConfig(..)+ , tile+ , fixed+ , stretch+ , col+ , row+ , tabNavigation+ , askOrientation+ ) where++import Control.Monad.NodeId (NodeId, MonadNodeId(..))+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.Ratio ((%))+import Data.Semigroup (First(..))+import qualified Graphics.Vty as V++import Reflex+import Reflex.Host.Class (MonadReflexCreateTrigger)+import Reflex.Vty.Widget++-- | The main-axis orientation of a 'Layout' widget+data Orientation = Orientation_Column+ | Orientation_Row+ deriving (Show, Read, Eq, Ord)++data LayoutSegment = LayoutSegment+ { _layoutSegment_offset :: Int+ , _layoutSegment_size :: Int+ }++data LayoutCtx t = LayoutCtx+ { _layoutCtx_regions :: Dynamic t (Map NodeId LayoutSegment)+ , _layoutCtx_focusDemux :: Demux t (Maybe NodeId)+ , _layoutCtx_orientation :: Dynamic t Orientation+ }++-- | 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+ ( Functor+ , Applicative+ , Monad+ , MonadHold t+ , MonadSample t+ , MonadFix+ , TriggerEvent t+ , PerformEvent t+ , NotReady t+ , MonadReflexCreateTrigger t+ , HasDisplaySize t+ , MonadNodeId+ )++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++-- | 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++-- | 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++-- | 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 data TileConfig t = TileConfig+ }++instance Reflex t => Default (TileConfig t) where+ def = TileConfig (pure $ Constraint_Min 0) (pure True)++-- | 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++-- | 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++-- | 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++-- | 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_Column) 0 nav child++-- | 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)+tabNavigation = do+ fwd <- fmap (const 1) <$> key (V.KChar '\t')+ back <- fmap (const (-1)) <$> key V.KBackTab+ return $ 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)++-- | Retrieve the current orientation of a 'Layout'+askOrientation :: Monad m => Layout t m (Dynamic t Orientation)+askOrientation = Layout $ asks _layoutCtx_orientation++-- | 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+ where+ 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)++