{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -threaded #-}
module Potato.Reflex.Vty.Helpers (
MonadWidget
, MonadLayoutWidget
, debugFocus
, debugInput
, debugSize
, dragTest
, richTextConfig_simpleForeColorAttr
, debugStreamBeh
, debugStream
, fmapLabelShow
, countEv
, vLayoutPad
, drag2AttachOnStart
) where
import Relude
import Potato.Reflex.Vty.Widget
import Reflex.Potato.Helpers (simultaneous)
import Control.Monad.Fix
import Control.Monad.NodeId
import qualified Data.Text as T
import qualified Graphics.Vty as V
import Reflex
import Reflex.Vty
type MonadWidget t m = (Reflex t, MonadHold t m, MonadFix m, NotReady t m, Adjustable t m, PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadNodeId m, MonadIO (Performable m), MonadSample t m, MonadIO m
, HasImageWriter t m
, MonadNodeId m
, HasDisplayRegion t m
, HasFocusReader t m
, HasInput t m
, HasTheme t m)
type MonadLayoutWidget t m = (MonadWidget t m, HasFocus t m, HasLayout t m)
debugFocus :: (HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => m ()
debugFocus :: forall t (m :: * -> *).
(HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m,
HasTheme t m) =>
m ()
debugFocus = do
Dynamic t Bool
f <- forall {k} (t :: k) (m :: * -> *).
HasFocusReader t m =>
m (Dynamic t Bool)
focus
forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
HasTheme t m) =>
Behavior t Text -> m ()
text forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (Show a, IsString b) => a -> b
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Bool
f
debugInput :: (MonadHold t m, HasInput t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => m ()
debugInput :: forall t (m :: * -> *).
(MonadHold t m, HasInput t m, HasDisplayRegion t m,
HasImageWriter t m, HasTheme t m) =>
m ()
debugInput = do
Behavior t String
lastEvent <- forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Behavior t a)
hold String
"No event yet" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b a. (Show a, IsString b) => a -> b
show forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {k} (t :: k) (m :: * -> *).
HasInput t m =>
m (Event t VtyEvent)
input
forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
HasTheme t m) =>
Behavior t Text -> m ()
text forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t String
lastEvent
debugSize :: (MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => m ()
debugSize :: forall t (m :: * -> *).
(MonadHold t m, HasDisplayRegion t m, HasImageWriter t m,
HasTheme t m) =>
m ()
debugSize = do
Dynamic t Int
ldw <- forall {k} (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayWidth
Dynamic t Int
ldh <- forall {k} (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayHeight
let combine :: a -> a -> a
combine a
w a
h = a
"w: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show a
w forall a. Semigroup a => a -> a -> a
<> a
" h: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show a
h
forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
HasTheme t m) =>
Behavior t Text -> m ()
text forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Int -> Int -> Text
combine (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
ldw) (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
ldh)
dragTest :: (MonadHold t m, MonadFix m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasTheme t m) => m ()
dragTest :: forall t (m :: * -> *).
(MonadHold t m, MonadFix m, HasDisplayRegion t m,
HasImageWriter t m, HasInput t m, HasTheme t m) =>
m ()
dragTest = do
Behavior t String
lastEvent <- forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Behavior t a)
hold String
"No event yet" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b a. (Show a, IsString b) => a -> b
show forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {k} (t :: k) (m :: * -> *).
(Reflex t, MonadFix m, MonadHold t m, HasInput t m) =>
Button -> m (Event t Drag)
drag Button
V.BLeft
forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
HasTheme t m) =>
Behavior t Text -> m ()
text forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t String
lastEvent
richTextConfig_simpleForeColorAttr :: (Reflex t) => RichTextConfig t
richTextConfig_simpleForeColorAttr :: forall t. Reflex t => RichTextConfig t
richTextConfig_simpleForeColorAttr = forall {k} (t :: k). Behavior t Attr -> RichTextConfig t
RichTextConfig forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) a. Reflex t => a -> Behavior t a
constant (Attr
V.defAttr { attrForeColor :: MaybeDefault Color
V.attrForeColor = forall v. v -> MaybeDefault v
V.SetTo Color
V.yellow})
fmapLabelShow :: (Functor f, Show a) => Text -> f a -> f Text
fmapLabelShow :: forall (f :: * -> *) a.
(Functor f, Show a) =>
Text -> f a -> f Text
fmapLabelShow Text
t = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
x -> Text
t forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show a
x)
debugStream :: (MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => [Event t Text] -> m ()
debugStream :: forall t (m :: * -> *).
(MonadHold t m, HasDisplayRegion t m, HasImageWriter t m,
HasTheme t m) =>
[Event t Text] -> m ()
debugStream [Event t Text]
evs = do
Dynamic t Text
t <- forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
holdDyn Text
"" forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith (\Text
a Text
b -> Text
a forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
b) [Event t Text]
evs
forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
HasTheme t m) =>
RichTextConfig t -> Behavior t Text -> m ()
richText forall t. Reflex t => RichTextConfig t
richTextConfig_simpleForeColorAttr (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Text
t)
debugStreamBeh :: (MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => [Behavior t Text] -> m ()
debugStreamBeh :: forall t (m :: * -> *).
(MonadHold t m, HasDisplayRegion t m, HasImageWriter t m,
HasTheme t m) =>
[Behavior t Text] -> m ()
debugStreamBeh [Behavior t Text]
behs = forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
HasTheme t m) =>
Behavior t Text -> m ()
text forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\Text
t1 Text
t2 -> Text
t1 forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
t2)) Behavior t Text
"" [Behavior t Text]
behs
countEv :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Dynamic t Int)
countEv :: forall t (m :: * -> *) a.
(Reflex t, MonadHold t m, MonadFix m) =>
Event t a -> m (Dynamic t Int)
countEv Event t a
ev = forall {k} (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn (\a
_ Int
b -> Int
bforall a. Num a => a -> a -> a
+Int
1) Int
0 Event t a
ev
vLayoutPad :: (PostBuild t m, MonadHold t m, MonadFix m, MonadNodeId m, HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m) => Int -> m a -> m a
vLayoutPad :: forall t (m :: * -> *) a.
(PostBuild t m, MonadHold t m, MonadFix m, MonadNodeId m,
HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m,
HasInput t m) =>
Int -> m a -> m a
vLayoutPad Int
n m a
w = forall t (m :: * -> *) a.
(HasDisplayRegion t m, MonadFix m) =>
Layout t m a -> m a
initLayout forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) (m :: * -> *) a.
(Reflex t, MonadFix m, HasLayout t m) =>
m a -> m a
col forall a b. (a -> b) -> a -> b
$ do
(forall {k} (m :: * -> *) (t :: k) a.
(MonadFix m, MonadHold t m, HasLayout t m, HasInput t m,
HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m) =>
Dynamic t Constraint -> m a -> m a
grout forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (t :: k).
Reflex t =>
Dynamic t Int -> Dynamic t Constraint
fixed) (forall {k} (t :: k) a. Reflex t => a -> Dynamic t a
constDyn Int
n) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
(forall {k} (m :: * -> *) (t :: k) a.
(MonadFix m, MonadHold t m, HasLayout t m, HasInput t m,
HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m) =>
Dynamic t Constraint -> m a -> m a
grout forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (t :: k).
Reflex t =>
Dynamic t Int -> Dynamic t Constraint
stretch) Dynamic t Int
0 (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
w)
drag2AttachOnStart
:: forall t m a. (Reflex t, MonadFix m, MonadHold t m, HasInput t m)
=> V.Button
-> Behavior t a
-> m (Event t (a, Drag2))
drag2AttachOnStart :: forall t (m :: * -> *) a.
(Reflex t, MonadFix m, MonadHold t m, HasInput t m) =>
Button -> Behavior t a -> m (Event t (a, Drag2))
drag2AttachOnStart Button
btn Behavior t a
beh = do
Event t Drag2
dragEv <- forall t (m :: * -> *).
(Reflex t, MonadFix m, MonadHold t m, HasInput t m) =>
Button -> m (Event t Drag2)
drag2 Button
V.BLeft
let
foldfn :: Drag2 -> Maybe (a, Drag2) -> PushM t (Maybe (a, Drag2))
foldfn Drag2
d Maybe (a, Drag2)
ma = do
a
anew <- case Maybe (a, Drag2)
ma of
Maybe (a, Drag2)
Nothing -> forall {k} (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample Behavior t a
beh
Just (a
a, Drag2
_) | Drag2 -> DragState
_drag2_state Drag2
d forall a. Eq a => a -> a -> Bool
== DragState
DragStart -> forall {k} (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample Behavior t a
beh
Just (a
a, Drag2
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
return $ forall a. a -> Maybe a
Just (a
anew, Drag2
d)
Dynamic t (Maybe (a, Drag2))
dragBeh <- forall {k} (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
foldDynM Drag2 -> Maybe (a, Drag2) -> PushM t (Maybe (a, Drag2))
foldfn forall a. Maybe a
Nothing Event t Drag2
dragEv
return $ forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
fmapMaybe forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t (Maybe (a, Drag2))
dragBeh