mirror of
https://github.com/ilyakooo0/reflex-vty.git
synced 2024-10-04 04:57:41 +03:00
examples: Update task list example
This commit is contained in:
Ali Abrar
parent
f51b16582e
commit
b41724c88d
@ -17,13 +17,12 @@ import Control.Monad.NodeId
|
||||
import Data.Functor.Misc
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as Set
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Zipper as TZ
|
||||
import qualified Graphics.Vty as V
|
||||
import Reflex
|
||||
import Reflex.Class.Switchable
|
||||
import Reflex.Network
|
||||
import Reflex.Vty
|
||||
|
||||
@ -75,7 +74,7 @@ main = mainWidget $ do
|
||||
V.EvKey V.KEsc [] -> Just $ Right ()
|
||||
_ -> Nothing
|
||||
rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
|
||||
Left Example_Todo -> escapable blank -- taskList
|
||||
Left Example_Todo -> escapable taskList
|
||||
Left Example_TextEditor -> escapable testBoxes
|
||||
Left Example_ScrollableTextDisplay -> escapable scrolling
|
||||
Right () -> buttons
|
||||
@ -83,30 +82,120 @@ main = mainWidget $ do
|
||||
return $ fforMaybe inp $ \case
|
||||
V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
|
||||
_ -> Nothing
|
||||
|
||||
{-
|
||||
|
||||
-- * Task list example
|
||||
taskList
|
||||
:: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m)
|
||||
=> VtyWidget t m ()
|
||||
taskList = do
|
||||
let btn = textButtonStatic def "Add another task"
|
||||
inp <- input
|
||||
:: (VtyExample t m, Manager t m, MonadHold t m, Adjustable t m, PostBuild t m)
|
||||
=> m ()
|
||||
taskList = col $ do
|
||||
let todos0 =
|
||||
[ Todo "Find reflex-vty" True
|
||||
, Todo "Become functional reactive" False
|
||||
, Todo "Make vty apps" False
|
||||
]
|
||||
rec let todos' = todos todos0 $ leftmost
|
||||
[ () <$ e
|
||||
, fforMaybe inp $ \case
|
||||
V.EvKey V.KEnter [] -> Just ()
|
||||
_ -> Nothing
|
||||
]
|
||||
(m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $
|
||||
splitV (pure (subtract 3)) (pure (True, True)) btn (display $ Map.size <$> current m)
|
||||
btn = textButtonStatic def "Add another task"
|
||||
enter <- fmap (const ()) <$> key V.KEnter
|
||||
rec void $ grout flex $ todos todos0 $ enter <> click
|
||||
click <- tile (fixed 3) btn
|
||||
return ()
|
||||
-}
|
||||
|
||||
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
|
||||
, _todoOutput_focusId :: FocusId
|
||||
}
|
||||
|
||||
todo
|
||||
:: (VtyExample t m, Manager t m, MonadHold t m)
|
||||
=> Todo
|
||||
-> m (TodoOutput t)
|
||||
todo t0 = row $ do
|
||||
let getToggleEvent = keyCombos $ Set.fromList
|
||||
[ (V.KChar ' ', [V.MCtrl])
|
||||
, (V.KChar '@', [V.MCtrl])
|
||||
]
|
||||
rec let cfg = def
|
||||
{ _checkboxConfig_setValue = setVal
|
||||
}
|
||||
(toggleCB, value) <- tile (fixed 4) $ do
|
||||
e <- getToggleEvent
|
||||
v <- checkbox cfg $ _todo_done t0
|
||||
pure (e, v)
|
||||
let setVal = attachWith (\v _ -> not v) (current value) $ leftmost
|
||||
[ toggleCB
|
||||
, toggleTI
|
||||
]
|
||||
(fid, (ti, toggleTI, d)) <- tile' flex $ do
|
||||
i <- input
|
||||
e <- getToggleEvent
|
||||
v <- textInput $ def
|
||||
{ _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
|
||||
let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
|
||||
return (v, e, deleteSelf)
|
||||
return $ TodoOutput
|
||||
{ _todoOutput_todo = Todo <$> _textInput_value ti <*> value
|
||||
, _todoOutput_delete = d
|
||||
, _todoOutput_height = _textInput_lines ti
|
||||
, _todoOutput_focusId = fid
|
||||
}
|
||||
where
|
||||
backspaceOnEmpty v = \case
|
||||
V.EvKey V.KBS _ | T.null v -> Just ()
|
||||
_ -> Nothing
|
||||
|
||||
todos
|
||||
:: forall t m.
|
||||
( MonadHold t m
|
||||
, Manager t m
|
||||
, VtyExample t m
|
||||
, Adjustable t m
|
||||
, PostBuild t m
|
||||
)
|
||||
=> [Todo]
|
||||
-> Event t ()
|
||||
-> m (Dynamic t (Map Int (TodoOutput t)))
|
||||
todos todos0 newTodo = do
|
||||
let todosMap0 = Map.fromList $ zip [0..] todos0
|
||||
rec listOut <- listHoldWithKey todosMap0 updates $ \k t -> grout (fixed 1) $ do
|
||||
to <- todo t
|
||||
let sel = select selectOnDelete $ Const2 k
|
||||
pb <- getPostBuild
|
||||
requestFocus $ Refocus_Id (_todoOutput_focusId to) <$ leftmost [pb, sel]
|
||||
pure to
|
||||
let delete = flip Map.singleton Nothing <$> todoDelete
|
||||
todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut
|
||||
insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
|
||||
Nothing -> Map.singleton 0 $ Just $ Todo "" False
|
||||
Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False
|
||||
updates = leftmost [insert, delete]
|
||||
todoDelete = switch . current $
|
||||
leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut
|
||||
|
||||
selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe
|
||||
(\m k -> let (before, after) = Map.split k m
|
||||
in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
|
||||
(current todosMap)
|
||||
todoDelete
|
||||
return listOut
|
||||
|
||||
-- * Scrollable text example
|
||||
|
||||
scrolling :: (VtyExample t m, MonadHold t m, Manager t m, PostBuild t m) => m ()
|
||||
scrolling = col $ do
|
||||
grout (fixed 2) $ text "Use your mouse wheel or up and down arrows to scroll:"
|
||||
(fid, out) <- tile' (fixed 5) $ boxStatic def $ scrollableText never $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant."
|
||||
pb <- getPostBuild
|
||||
requestFocus $ Refocus_Id fid <$ pb
|
||||
grout (fixed 1) $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)
|
||||
|
||||
-- * Text editor example with resizable boxes
|
||||
|
||||
testBoxes
|
||||
:: (MonadHold t m, MonadNodeId m, VtyExample t m)
|
||||
@ -149,104 +238,3 @@ dragTest = do
|
||||
testStringBox :: VtyExample t m => 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
|
||||
-}
|
||||
|
||||
scrolling :: (VtyExample t m, MonadHold t m, Manager t m, PostBuild t m) => m ()
|
||||
scrolling = col $ do
|
||||
grout (fixed 2) $ text "Use your mouse wheel or up and down arrows to scroll:"
|
||||
(fid, out) <- tile' (fixed 5) $ boxStatic def $ scrollableText never $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant."
|
||||
pb <- getPostBuild
|
||||
requestFocus $ Refocus_Id fid <$ pb
|
||||
grout (fixed 1) $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)
|
||||
|
||||
{-
|
||||
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
|
||||
-}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user