diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for reflex-vty + +## 0.1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,27 @@ +# reflex-vty + +## A library for building functional reactive terminal applications + +![reflex-vty example animation](doc/welcome.gif) + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/doc/tasks.png b/doc/tasks.png new file mode 100644 Binary files /dev/null and b/doc/tasks.png differ diff --git a/doc/welcome.gif b/doc/welcome.gif new file mode 100644 Binary files /dev/null and b/doc/welcome.gif differ diff --git a/reflex-vty.cabal b/reflex-vty.cabal new file mode 100644 --- /dev/null +++ b/reflex-vty.cabal @@ -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 diff --git a/src-bin/example.hs b/src-bin/example.hs new file mode 100644 --- /dev/null +++ b/src-bin/example.hs @@ -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 diff --git a/src/Control/Monad/NodeId.hs b/src/Control/Monad/NodeId.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/NodeId.hs @@ -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) diff --git a/src/Data/Text/Zipper.hs b/src/Data/Text/Zipper.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Zipper.hs @@ -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) diff --git a/src/Reflex/Class/Switchable.hs b/src/Reflex/Class/Switchable.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Class/Switchable.hs @@ -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) diff --git a/src/Reflex/Spider/Orphans.hs b/src/Reflex/Spider/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Spider/Orphans.hs @@ -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 () diff --git a/src/Reflex/Vty.hs b/src/Reflex/Vty.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty.hs @@ -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 diff --git a/src/Reflex/Vty/Host.hs b/src/Reflex/Vty/Host.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty/Host.hs @@ -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 } diff --git a/src/Reflex/Vty/Widget.hs b/src/Reflex/Vty/Widget.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty/Widget.hs @@ -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 () diff --git a/src/Reflex/Vty/Widget/Input.hs b/src/Reflex/Vty/Widget/Input.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty/Widget/Input.hs @@ -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 diff --git a/src/Reflex/Vty/Widget/Input/Text.hs b/src/Reflex/Vty/Widget/Input/Text.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty/Widget/Input/Text.hs @@ -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 diff --git a/src/Reflex/Vty/Widget/Layout.hs b/src/Reflex/Vty/Widget/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty/Widget/Layout.hs @@ -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) + +