mirror of
https://github.com/ilyakooo0/reflex-vty.git
synced 2024-11-25 18:11:31 +03:00
Start eliminating VtyWidget
* Replace HasDisplaySize with HasDisplayRegion * Add a DisplaySize monad transformer * Remove display size information from VtyWidgetCtx * Rename ImageWriter to HasImageWriter * Introduce an ImageWriter monad transformer * Remove the image writer from VtyWidget *
This commit is contained in:
Ali Abrar
parent
461721c313
commit
5f97c0f858
@ -10,6 +10,7 @@ module Control.Monad.NodeId
|
||||
, runNodeIdT
|
||||
) where
|
||||
|
||||
import Control.Monad.Morph
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Ref
|
||||
import Data.IORef
|
||||
@ -34,10 +35,12 @@ newtype NodeIdT m a = NodeIdT { unNodeIdT :: ReaderT (IORef NodeId) m a }
|
||||
deriving
|
||||
( Functor
|
||||
, Applicative
|
||||
, MFunctor
|
||||
, Monad
|
||||
, MonadFix
|
||||
, MonadHold t
|
||||
, MonadIO
|
||||
, MonadRef
|
||||
, MonadReflexCreateTrigger t
|
||||
, MonadSample t
|
||||
, MonadTrans
|
||||
@ -45,7 +48,6 @@ newtype NodeIdT m a = NodeIdT { unNodeIdT :: ReaderT (IORef NodeId) m a }
|
||||
, PerformEvent t
|
||||
, PostBuild t
|
||||
, TriggerEvent t
|
||||
, MonadRef
|
||||
)
|
||||
|
||||
instance MonadNodeId m => MonadNodeId (ReaderT x m)
|
||||
|
||||
@ -62,6 +62,7 @@ import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.Morph
|
||||
import Control.Monad.NodeId
|
||||
import Control.Monad.Reader (ReaderT, ask, asks, local, runReaderT)
|
||||
import Control.Monad.Ref
|
||||
import Control.Monad.Trans (MonadTrans, lift)
|
||||
import Data.Default (Default(..))
|
||||
import Data.Set (Set)
|
||||
@ -78,11 +79,7 @@ import Reflex.Vty.Host
|
||||
|
||||
-- | 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
|
||||
{ _vtyWidgetCtx_focus :: Dynamic t Bool
|
||||
-- ^ Whether the widget should behave as if it has focus for keyboard input.
|
||||
}
|
||||
|
||||
@ -102,9 +99,9 @@ instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (VtyWidget t
|
||||
|
||||
-- | A widget that can read its context and produce image output
|
||||
newtype VtyWidget t m a = VtyWidget
|
||||
{ unVtyWidget :: BehaviorWriterT t [Image]
|
||||
(ReaderT (VtyWidgetCtx t)
|
||||
(ReaderT (Event t VtyEvent) m)) a
|
||||
{ unVtyWidget ::
|
||||
ReaderT (VtyWidgetCtx t)
|
||||
(ReaderT (Event t VtyEvent) m) a
|
||||
} deriving
|
||||
( Functor
|
||||
, Applicative
|
||||
@ -112,25 +109,26 @@ newtype VtyWidget t m a = VtyWidget
|
||||
, MonadSample t
|
||||
, MonadHold t
|
||||
, MonadFix
|
||||
, NotReady t
|
||||
, ImageWriter t
|
||||
, PostBuild t
|
||||
, TriggerEvent t
|
||||
, MonadReflexCreateTrigger t
|
||||
, MonadIO
|
||||
, MonadRef
|
||||
)
|
||||
|
||||
deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (VtyWidget t m)
|
||||
deriving instance NotReady t m => NotReady t (VtyWidget t m)
|
||||
deriving instance PerformEvent t m => PerformEvent t (VtyWidget t m)
|
||||
deriving instance PostBuild t m => PostBuild t (VtyWidget t m)
|
||||
deriving instance TriggerEvent t m => TriggerEvent t (VtyWidget t m)
|
||||
instance HasImageWriter t m => HasImageWriter t (VtyWidget t m)
|
||||
instance HasDisplayRegion t m => HasDisplayRegion t (VtyWidget t m)
|
||||
|
||||
instance MonadTrans (VtyWidget t) where
|
||||
lift f = VtyWidget $ lift $ lift $ lift f
|
||||
lift f = VtyWidget $ lift $ lift f
|
||||
|
||||
instance MFunctor (VtyWidget t) where
|
||||
hoist f = VtyWidget . hoist (hoist (hoist f)) . unVtyWidget
|
||||
hoist f = VtyWidget . hoist (hoist f) . unVtyWidget
|
||||
|
||||
instance MonadNodeId m => MonadNodeId (VtyWidget t m)
|
||||
|
||||
instance MonadNodeId m => MonadNodeId (VtyWidget t m) where
|
||||
getNextNodeId = VtyWidget $ do
|
||||
lift $ lift getNextNodeId
|
||||
|
||||
-- | A reader-like class for the vty widget context. Allows actions to be run in a sub-context.
|
||||
class HasVtyWidgetCtx t m | m -> t where
|
||||
@ -140,7 +138,7 @@ class HasVtyWidgetCtx t m | m -> t where
|
||||
localCtx :: (VtyWidgetCtx t -> VtyWidgetCtx t) -> m a -> m a
|
||||
|
||||
instance (Monad m, Reflex t) => HasVtyWidgetCtx t (VtyWidget t m) where
|
||||
askCtx = VtyWidget $ lift ask
|
||||
askCtx = VtyWidget $ ask
|
||||
localCtx f (VtyWidget x) = VtyWidget $ local f x
|
||||
|
||||
-- | Runs a 'VtyWidget' with a given context
|
||||
@ -149,13 +147,18 @@ runVtyWidget
|
||||
=> Event t VtyEvent
|
||||
-> VtyWidgetCtx t
|
||||
-> VtyWidget t m a
|
||||
-> m (a, Behavior t [Image])
|
||||
runVtyWidget e ctx w = runReaderT (runReaderT (runBehaviorWriterT (unVtyWidget w)) ctx) e
|
||||
-> m a
|
||||
runVtyWidget e ctx w = runReaderT (runReaderT (unVtyWidget w) ctx) e
|
||||
|
||||
-- | 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 ()))
|
||||
-> (forall t m.
|
||||
( MonadVtyApp t m
|
||||
, HasImageWriter t m
|
||||
, MonadNodeId m
|
||||
, HasDisplayRegion t m
|
||||
) => VtyWidget t m (Event t ()))
|
||||
-> IO ()
|
||||
mainWidgetWithHandle vty child =
|
||||
runVtyAppWithHandle vty $ \dr0 inp -> do
|
||||
@ -166,13 +169,14 @@ mainWidgetWithHandle vty child =
|
||||
V.EvResize {} -> Nothing
|
||||
x -> Just x
|
||||
let ctx = VtyWidgetCtx
|
||||
{ _vtyWidgetCtx_width = fmap fst size
|
||||
, _vtyWidgetCtx_height = fmap snd size
|
||||
, _vtyWidgetCtx_focus = constDyn True
|
||||
{ _vtyWidgetCtx_focus = constDyn True
|
||||
}
|
||||
(shutdown, images) <- runNodeIdT $ runVtyWidget inp' ctx $ do
|
||||
tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
|
||||
child
|
||||
(shutdown, images) <- runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $
|
||||
runImageWriter $
|
||||
runNodeIdT $
|
||||
runVtyWidget inp' 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
|
||||
@ -187,25 +191,72 @@ mainWidget child = do
|
||||
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
|
||||
class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where
|
||||
-- | Retrieve the display region
|
||||
askRegion :: m (Dynamic t Region)
|
||||
default askRegion :: (f m' ~ m, MonadTrans f, HasDisplayRegion t m') => m (Dynamic t Region)
|
||||
askRegion = lift askRegion
|
||||
-- | Run an action in a local region, by applying a transformation to the region
|
||||
localRegion :: (Dynamic t Region -> Dynamic t Region) -> m a -> m a
|
||||
default localRegion :: (f m' ~ m, Monad m', MFunctor f, HasDisplayRegion t m') => (Dynamic t Region -> Dynamic t Region) -> m a -> m a
|
||||
localRegion f = hoist (localRegion f)
|
||||
|
||||
instance (Reflex t, Monad m) => HasDisplaySize t (VtyWidget t m) where
|
||||
displayWidth = VtyWidget . lift $ asks _vtyWidgetCtx_width
|
||||
displayHeight = VtyWidget . lift $ asks _vtyWidgetCtx_height
|
||||
displayWidth :: HasDisplayRegion t m => m (Dynamic t Int)
|
||||
displayWidth = fmap _region_width <$> askRegion
|
||||
|
||||
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)
|
||||
displayHeight :: HasDisplayRegion t m => m (Dynamic t Int)
|
||||
displayHeight = fmap _region_height <$> askRegion
|
||||
|
||||
instance HasDisplayRegion t m => HasDisplayRegion t (ReaderT x m)
|
||||
instance HasDisplayRegion t m => HasDisplayRegion t (BehaviorWriterT t x m)
|
||||
instance HasDisplayRegion t m => HasDisplayRegion t (DynamicWriterT t x m)
|
||||
instance HasDisplayRegion t m => HasDisplayRegion t (EventWriterT t x m)
|
||||
instance HasDisplayRegion t m => HasDisplayRegion t (NodeIdT m)
|
||||
|
||||
newtype DisplayRegion t m a = DisplayRegion { unDisplayRegion :: ReaderT (Dynamic t Region) m a }
|
||||
deriving
|
||||
( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadFix
|
||||
, MonadHold t
|
||||
, MonadIO
|
||||
, MonadRef
|
||||
, MonadSample t
|
||||
)
|
||||
|
||||
instance (Monad m, Reflex t) => HasDisplayRegion t (DisplayRegion t m) where
|
||||
askRegion = DisplayRegion ask
|
||||
localRegion f = DisplayRegion . local f . unDisplayRegion
|
||||
|
||||
deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DisplayRegion t m)
|
||||
deriving instance NotReady t m => NotReady t (DisplayRegion t m)
|
||||
deriving instance PerformEvent t m => PerformEvent t (DisplayRegion t m)
|
||||
deriving instance PostBuild t m => PostBuild t (DisplayRegion t m)
|
||||
deriving instance TriggerEvent t m => TriggerEvent t (DisplayRegion t m)
|
||||
instance HasImageWriter t m => HasImageWriter t (DisplayRegion t m)
|
||||
|
||||
instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (DisplayRegion t m) where
|
||||
runWithReplace (DisplayRegion a) e = DisplayRegion $ runWithReplace a $ fmap unDisplayRegion e
|
||||
traverseIntMapWithKeyWithAdjust f m e = DisplayRegion $ traverseIntMapWithKeyWithAdjust (\k v -> unDisplayRegion $ f k v) m e
|
||||
traverseDMapWithKeyWithAdjust f m e = DisplayRegion $ traverseDMapWithKeyWithAdjust (\k v -> unDisplayRegion $ f k v) m e
|
||||
traverseDMapWithKeyWithAdjustWithMove f m e = DisplayRegion $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unDisplayRegion $ f k v) m e
|
||||
|
||||
|
||||
instance MonadTrans (DisplayRegion t) where
|
||||
lift = DisplayRegion . lift
|
||||
|
||||
instance MFunctor (DisplayRegion t) where
|
||||
hoist f = DisplayRegion . hoist f . unDisplayRegion
|
||||
|
||||
instance MonadNodeId m => MonadNodeId (DisplayRegion t m)
|
||||
|
||||
runDisplayRegion
|
||||
:: (Reflex t, Monad m)
|
||||
=> Dynamic t Region
|
||||
-> DisplayRegion t m a
|
||||
-> m a
|
||||
runDisplayRegion r = flip runReaderT r . unDisplayRegion
|
||||
|
||||
-- | A class for things that can receive vty events as input
|
||||
class HasVtyInput t m | m -> t where
|
||||
@ -223,8 +274,8 @@ filterKeys f x = localInput (ffilter (\case
|
||||
_ -> True)) x
|
||||
|
||||
instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where
|
||||
input = VtyWidget . lift $ lift $ ask
|
||||
localInput f (VtyWidget m) = VtyWidget $ hoist (hoist (local f)) m
|
||||
input = VtyWidget . lift $ ask
|
||||
localInput f (VtyWidget m) = VtyWidget $ hoist (local f) m
|
||||
|
||||
-- | A class for things that can dynamically gain and lose focus
|
||||
class HasFocus t m | m -> t where
|
||||
@ -233,24 +284,69 @@ class HasFocus t m | m -> t where
|
||||
focus = lift focus
|
||||
|
||||
instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where
|
||||
focus = VtyWidget . lift $ asks _vtyWidgetCtx_focus
|
||||
focus = VtyWidget $ 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
|
||||
class (Reflex t, Monad m) => HasImageWriter t m | m -> t where
|
||||
-- | Send images upstream for rendering
|
||||
tellImages :: Behavior t [Image] -> m ()
|
||||
default tellImages :: (f m' ~ m, Monad m', MonadTrans f, ImageWriter t m') => Behavior t [Image] -> m ()
|
||||
default tellImages :: (f m' ~ m, Monad m', MonadTrans f, HasImageWriter t m') => Behavior t [Image] -> m ()
|
||||
tellImages = lift . tellImages
|
||||
-- | Apply a transformation to the images produced by the child actions
|
||||
mapImages :: (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
|
||||
default mapImages :: (f m' ~ m, Monad m', MFunctor f, HasImageWriter t m') => (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
|
||||
mapImages f = hoist (mapImages f)
|
||||
|
||||
instance (Monad m, Reflex t) => ImageWriter t (BehaviorWriterT t [Image] m) where
|
||||
tellImages = tellBehavior
|
||||
mapImages f x = do
|
||||
newtype ImageWriter t m a = ImageWriter { unImageWriter :: BehaviorWriterT t [Image] m a }
|
||||
deriving
|
||||
( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadFix
|
||||
, MonadHold t
|
||||
, MonadIO
|
||||
, MonadRef
|
||||
, MonadReflexCreateTrigger t
|
||||
, MonadSample t
|
||||
, NotReady t
|
||||
, PerformEvent t
|
||||
, PostBuild t
|
||||
, TriggerEvent t
|
||||
)
|
||||
|
||||
instance MonadTrans (ImageWriter t) where
|
||||
lift = ImageWriter . lift
|
||||
|
||||
instance MFunctor (ImageWriter t) where
|
||||
hoist f = ImageWriter . (hoist f) . unImageWriter
|
||||
|
||||
instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ImageWriter t m) where
|
||||
runWithReplace (ImageWriter a) e = ImageWriter $ runWithReplace a $ fmap unImageWriter e
|
||||
traverseIntMapWithKeyWithAdjust f m e = ImageWriter $ traverseIntMapWithKeyWithAdjust (\k v -> unImageWriter $ f k v) m e
|
||||
traverseDMapWithKeyWithAdjust f m e = ImageWriter $ traverseDMapWithKeyWithAdjust (\k v -> unImageWriter $ f k v) m e
|
||||
traverseDMapWithKeyWithAdjustWithMove f m e = ImageWriter $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unImageWriter $ f k v) m e
|
||||
|
||||
instance HasImageWriter t m => HasImageWriter t (ReaderT x m)
|
||||
instance HasImageWriter t m => HasImageWriter t (BehaviorWriterT t x m)
|
||||
instance HasImageWriter t m => HasImageWriter t (DynamicWriterT t x m)
|
||||
instance HasImageWriter t m => HasImageWriter t (EventWriterT t x m)
|
||||
instance HasImageWriter t m => HasImageWriter t (NodeIdT m)
|
||||
|
||||
instance (Monad m, Reflex t) => HasImageWriter t (ImageWriter t m) where
|
||||
tellImages = ImageWriter . tellBehavior
|
||||
mapImages f (ImageWriter x) = ImageWriter $ do
|
||||
(a, images) <- lift $ runBehaviorWriterT x
|
||||
tellImages $ f images
|
||||
tellBehavior $ f images
|
||||
pure a
|
||||
|
||||
instance HasDisplayRegion t m => HasDisplayRegion t (ImageWriter t m)
|
||||
|
||||
runImageWriter
|
||||
:: (Reflex t, Monad m)
|
||||
=> ImageWriter t m a
|
||||
-> m (a, Behavior t [Image])
|
||||
runImageWriter = runBehaviorWriterT . unImageWriter
|
||||
|
||||
-- | A chunk of the display area
|
||||
data Region = Region
|
||||
{ _region_left :: Int
|
||||
@ -287,7 +383,7 @@ withinImage (Region left top width height)
|
||||
-- * 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, HasVtyWidgetCtx t m, HasVtyInput t m, ImageWriter t m)
|
||||
:: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m, HasVtyInput t m, HasImageWriter t m, HasDisplayRegion t m)
|
||||
=> Dynamic t Region
|
||||
-> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
|
||||
-> m a
|
||||
@ -296,14 +392,12 @@ pane dr foc child = do
|
||||
let reg = current dr
|
||||
let subContext ctx = VtyWidgetCtx
|
||||
{ _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc
|
||||
, _vtyWidgetCtx_width = _region_width <$> dr
|
||||
, _vtyWidgetCtx_height = _region_height <$> dr
|
||||
}
|
||||
inputFilter = fmapMaybe id .
|
||||
attachWith (\(r,f) e -> filterInput r f e)
|
||||
(liftA2 (,) reg (current foc))
|
||||
let imagesWithinRegion images = liftA2 (\is r -> map (withinImage r) is) images reg
|
||||
mapImages imagesWithinRegion $ localInput inputFilter $ localCtx subContext child
|
||||
localRegion (const dr) $ mapImages imagesWithinRegion $ localInput inputFilter $ localCtx subContext child
|
||||
where
|
||||
filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent
|
||||
filterInput (Region l t w h) focused e = case e of
|
||||
@ -448,7 +542,7 @@ keyCombos ks = do
|
||||
|
||||
-- | 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, HasVtyWidgetCtx t m, HasDisplaySize t m, HasVtyInput t m, ImageWriter t m)
|
||||
splitV :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m, HasDisplayRegion t m, HasVtyInput t m, HasImageWriter t m)
|
||||
=> Dynamic t (Int -> Int)
|
||||
-- ^ Function used to determine size of first pane based on available size
|
||||
-> Dynamic t (Bool, Bool)
|
||||
@ -469,7 +563,7 @@ splitV sizeFunD focD wA wB = do
|
||||
|
||||
-- | A plain split of the available space into horizontally stacked panes.
|
||||
-- No visual separator is built in here.
|
||||
splitH :: (Reflex t, Monad m, MonadNodeId m, HasDisplaySize t m, HasVtyWidgetCtx t m, HasVtyInput t m, ImageWriter t m)
|
||||
splitH :: (Reflex t, Monad m, MonadNodeId m, HasDisplayRegion t m, HasVtyWidgetCtx t m, HasVtyInput t m, HasImageWriter t m)
|
||||
=> Dynamic t (Int -> Int)
|
||||
-- ^ Function used to determine size of first pane based on available size
|
||||
-> Dynamic t (Bool, Bool)
|
||||
@ -489,7 +583,7 @@ splitH sizeFunD focD wA wB = do
|
||||
-- | 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, HasDisplaySize t m, HasVtyInput t m, HasVtyWidgetCtx t m, ImageWriter t m)
|
||||
splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m, HasDisplayRegion t m, HasVtyInput t m, HasVtyWidgetCtx t m, HasImageWriter t m)
|
||||
=> m ()
|
||||
-> m a
|
||||
-> m b
|
||||
@ -527,7 +621,7 @@ splitVDrag wS wA wB = do
|
||||
return (m, x')
|
||||
|
||||
-- | Fill the background with a particular character.
|
||||
fill :: (HasDisplaySize t m, ImageWriter t m) => Behavior t Char -> m ()
|
||||
fill :: (HasDisplayRegion t m, HasImageWriter t m) => Behavior t Char -> m ()
|
||||
fill bc = do
|
||||
dw <- displayWidth
|
||||
dh <- displayHeight
|
||||
@ -539,7 +633,7 @@ fill bc = do
|
||||
tellImages fillImg
|
||||
|
||||
-- | Fill the background with the bottom box style
|
||||
hRule :: (HasDisplaySize t m, ImageWriter t m) => BoxStyle -> m ()
|
||||
hRule :: (HasDisplayRegion t m, HasImageWriter t m) => BoxStyle -> m ()
|
||||
hRule boxStyle = fill $ pure (_boxStyle_s boxStyle)
|
||||
|
||||
-- | Defines a set of symbols to use to draw the outlines of boxes
|
||||
@ -580,7 +674,7 @@ roundedBoxStyle :: BoxStyle
|
||||
roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
|
||||
|
||||
-- | Draws a titled box in the provided style and a child widget inside of that box
|
||||
boxTitle :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
|
||||
boxTitle :: (Monad m, Reflex t, MonadNodeId m, HasDisplayRegion t m, HasImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
|
||||
=> Behavior t BoxStyle
|
||||
-> Behavior t Text
|
||||
-> m a
|
||||
@ -632,7 +726,7 @@ boxTitle boxStyle title child = do
|
||||
right = mkHalf delta
|
||||
|
||||
-- | A box without a title
|
||||
box :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
|
||||
box :: (Monad m, Reflex t, MonadNodeId m, HasDisplayRegion t m, HasImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
|
||||
=> Behavior t BoxStyle
|
||||
-> m a
|
||||
-> m a
|
||||
@ -640,7 +734,7 @@ box boxStyle = boxTitle boxStyle mempty
|
||||
|
||||
-- | A box whose style is static
|
||||
boxStatic
|
||||
:: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
|
||||
:: (Monad m, Reflex t, MonadNodeId m, HasDisplayRegion t m, HasImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
|
||||
=> BoxStyle
|
||||
-> m a
|
||||
-> m a
|
||||
@ -656,7 +750,7 @@ instance Reflex t => Default (RichTextConfig t) where
|
||||
|
||||
-- | A widget that displays text with custom time-varying attributes
|
||||
richText
|
||||
:: (Reflex t, Monad m, HasDisplaySize t m, ImageWriter t m)
|
||||
:: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m)
|
||||
=> RichTextConfig t
|
||||
-> Behavior t Text
|
||||
-> m ()
|
||||
@ -674,7 +768,7 @@ richText cfg t = do
|
||||
|
||||
-- | Renders text, wrapped to the container width
|
||||
text
|
||||
:: (Reflex t, Monad m, HasDisplaySize t m, ImageWriter t m)
|
||||
:: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m)
|
||||
=> Behavior t Text
|
||||
-> m ()
|
||||
text = richText def
|
||||
@ -682,7 +776,7 @@ text = richText def
|
||||
-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those
|
||||
-- that are hidden)
|
||||
scrollableText
|
||||
:: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplaySize t m, HasVtyInput t m, ImageWriter t m)
|
||||
:: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasVtyInput t m, HasImageWriter t m)
|
||||
=> Event t Int
|
||||
-- ^ Number of lines to scroll by
|
||||
-> Behavior t Text
|
||||
@ -714,7 +808,7 @@ scrollableText scrollBy t = do
|
||||
-- | Renders any behavior whose value can be converted to
|
||||
-- 'String' as text
|
||||
display
|
||||
:: (Reflex t, Monad m, Show a, HasDisplaySize t m, ImageWriter t m)
|
||||
:: (Reflex t, Monad m, Show a, HasDisplayRegion t m, HasImageWriter t m)
|
||||
=> Behavior t a
|
||||
-> m ()
|
||||
display a = text $ T.pack . show <$> a
|
||||
|
||||
@ -30,7 +30,7 @@ instance Reflex t => Default (ButtonConfig t) where
|
||||
|
||||
-- | A button widget that contains a sub-widget
|
||||
button
|
||||
:: (Reflex t, Monad m, MonadNodeId m, HasFocus t m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
|
||||
:: (Reflex t, Monad m, MonadNodeId m, HasFocus t m, HasDisplayRegion t m, HasImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
|
||||
=> ButtonConfig t
|
||||
-> m ()
|
||||
-> m (Event t ())
|
||||
@ -48,7 +48,7 @@ button cfg child = do
|
||||
|
||||
-- | A button widget that displays text that can change
|
||||
textButton
|
||||
:: (Reflex t, Monad m, MonadNodeId m, HasDisplaySize t m, HasFocus t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
|
||||
:: (Reflex t, Monad m, MonadNodeId m, HasDisplayRegion t m, HasFocus t m, HasImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
|
||||
=> ButtonConfig t
|
||||
-> Behavior t Text
|
||||
-> m (Event t ())
|
||||
@ -56,7 +56,7 @@ 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, HasDisplaySize t m, HasFocus t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
|
||||
:: (Reflex t, Monad m, MonadNodeId m, HasDisplayRegion t m, HasFocus t m, HasImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
|
||||
=> ButtonConfig t
|
||||
-> Text
|
||||
-> m (Event t ())
|
||||
@ -64,7 +64,7 @@ textButtonStatic cfg = textButton cfg . pure
|
||||
|
||||
-- | A clickable link widget
|
||||
link
|
||||
:: (Reflex t, Monad m, HasDisplaySize t m, ImageWriter t m, HasVtyInput t m)
|
||||
:: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasVtyInput t m)
|
||||
=> Behavior t Text
|
||||
-> m (Event t MouseUp)
|
||||
link t = do
|
||||
@ -76,7 +76,7 @@ link t = do
|
||||
|
||||
-- | A clickable link widget with a static label
|
||||
linkStatic
|
||||
:: (Reflex t, Monad m, ImageWriter t m, HasDisplaySize t m, HasVtyInput t m)
|
||||
:: (Reflex t, Monad m, HasImageWriter t m, HasDisplayRegion t m, HasVtyInput t m)
|
||||
=> Text
|
||||
-> m (Event t MouseUp)
|
||||
linkStatic = link . pure
|
||||
@ -120,7 +120,7 @@ instance (Reflex t) => Default (CheckboxConfig t) where
|
||||
|
||||
-- | A checkbox widget
|
||||
checkbox
|
||||
:: (MonadHold t m, MonadFix m, Reflex t, HasVtyInput t m, HasDisplaySize t m, ImageWriter t m, HasFocus t m)
|
||||
:: (MonadHold t m, MonadFix m, Reflex t, HasVtyInput t m, HasDisplayRegion t m, HasImageWriter t m, HasFocus t m)
|
||||
=> CheckboxConfig t
|
||||
-> Bool
|
||||
-> m (Dynamic t Bool)
|
||||
|
||||
@ -43,7 +43,7 @@ data TextInput t = TextInput
|
||||
|
||||
-- | A widget that allows text input
|
||||
textInput
|
||||
:: (Reflex t, MonadHold t m, MonadFix m, HasVtyInput t m, HasFocus t m, HasDisplaySize t m, ImageWriter t m)
|
||||
:: (Reflex t, MonadHold t m, MonadFix m, HasVtyInput t m, HasFocus t m, HasDisplayRegion t m, HasImageWriter t m, HasDisplayRegion t m)
|
||||
=> TextInputConfig t
|
||||
-> m (TextInput t)
|
||||
textInput cfg = do
|
||||
@ -81,7 +81,7 @@ textInput cfg = do
|
||||
|
||||
-- | A widget that allows multiline text input
|
||||
multilineTextInput
|
||||
:: (Reflex t, MonadHold t m, MonadFix m, HasVtyInput t m, HasFocus t m, HasDisplaySize t m, ImageWriter t m)
|
||||
:: (Reflex t, MonadHold t m, MonadFix m, HasVtyInput t m, HasFocus t m, HasDisplayRegion t m, HasImageWriter t m)
|
||||
=> TextInputConfig t
|
||||
-> m (TextInput t)
|
||||
multilineTextInput cfg = do
|
||||
@ -99,7 +99,7 @@ multilineTextInput cfg = do
|
||||
-- the computed line count to greedily size the tile when vertically
|
||||
-- oriented, and uses the fallback width when horizontally oriented.
|
||||
textInputTile
|
||||
:: (Monad m, MonadNodeId m, Reflex t, MonadFix m, MonadLayout t m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, ImageWriter t m)
|
||||
:: (Monad m, MonadNodeId m, Reflex t, MonadFix m, MonadLayout t m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, HasImageWriter t m, HasDisplayRegion t m)
|
||||
=> m (TextInput t)
|
||||
-> Dynamic t Int
|
||||
-> m (TextInput t)
|
||||
|
||||
@ -105,7 +105,7 @@ newtype Focus t m a = Focus
|
||||
, PerformEvent t
|
||||
, NotReady t
|
||||
, MonadReflexCreateTrigger t
|
||||
, HasDisplaySize t
|
||||
, HasDisplayRegion t
|
||||
, PostBuild t
|
||||
, MonadNodeId
|
||||
, MonadIO
|
||||
@ -130,7 +130,7 @@ instance (Reflex t, MonadFix m, HasVtyInput t m) => HasVtyInput t (Focus t m) wh
|
||||
instance (HasVtyWidgetCtx t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Focus t m) where
|
||||
localCtx f = hoist (localCtx f)
|
||||
|
||||
instance (ImageWriter t m, MonadFix m) => ImageWriter t (Focus t m) where
|
||||
instance (HasImageWriter t m, MonadFix m) => HasImageWriter t (Focus t m) where
|
||||
mapImages f = hoist (mapImages f)
|
||||
|
||||
instance (HasFocus t m, Monad m) => HasFocus t (Focus t m)
|
||||
@ -382,18 +382,18 @@ newtype Layout t m a = Layout
|
||||
deriving
|
||||
( Functor
|
||||
, Applicative
|
||||
, HasDisplayRegion t
|
||||
, Monad
|
||||
, MonadHold t
|
||||
, MonadSample t
|
||||
, MonadFix
|
||||
, TriggerEvent t
|
||||
, PerformEvent t
|
||||
, NotReady t
|
||||
, MonadReflexCreateTrigger t
|
||||
, HasDisplaySize t
|
||||
, PostBuild t
|
||||
, MonadNodeId
|
||||
, MonadHold t
|
||||
, MonadIO
|
||||
, MonadNodeId
|
||||
, MonadReflexCreateTrigger t
|
||||
, MonadSample t
|
||||
, NotReady t
|
||||
, PerformEvent t
|
||||
, PostBuild t
|
||||
, TriggerEvent t
|
||||
)
|
||||
|
||||
instance MonadTrans (Layout t) where
|
||||
@ -408,7 +408,7 @@ instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m
|
||||
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
|
||||
|
||||
instance (HasVtyWidgetCtx t m, HasDisplaySize t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Layout t m) where
|
||||
instance (HasVtyWidgetCtx t m, HasDisplayRegion t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Layout t m) where
|
||||
localCtx f x = do
|
||||
solution <- Layout ask
|
||||
let orientation = snd . rootLT <$> solution
|
||||
@ -421,7 +421,7 @@ instance (HasVtyWidgetCtx t m, HasDisplaySize t m, Reflex t, MonadFix m) => HasV
|
||||
-- | Apply a transformation to the context of a child 'Layout' action and run
|
||||
-- that action
|
||||
hoistRunLayout
|
||||
:: (HasDisplaySize t m, MonadFix m, Monad n)
|
||||
:: (HasDisplayRegion t m, MonadFix m, Monad n)
|
||||
=> (m a -> n b)
|
||||
-> Layout t m a
|
||||
-> Layout t n b
|
||||
@ -434,10 +434,10 @@ hoistRunLayout f x = do
|
||||
let reg = Region 0 0 <$> dw <*> dh
|
||||
runLayout orientation reg x
|
||||
|
||||
instance (HasVtyInput t m, HasDisplaySize t m, MonadFix m, Reflex t) => HasVtyInput t (Layout t m) where
|
||||
instance (HasVtyInput t m, HasDisplayRegion t m, MonadFix m, Reflex t) => HasVtyInput t (Layout t m) where
|
||||
localInput = hoistRunLayout . localInput
|
||||
|
||||
instance (HasDisplaySize t m, ImageWriter t m, MonadFix m) => ImageWriter t (Layout t m) where
|
||||
instance (HasDisplayRegion t m, HasImageWriter t m, MonadFix m) => HasImageWriter t (Layout t m) where
|
||||
mapImages f = hoistRunLayout (mapImages f)
|
||||
|
||||
instance (HasFocus t m, Monad m) => HasFocus t (Layout t m)
|
||||
@ -480,7 +480,7 @@ runLayout o r (Layout x) = do
|
||||
return result
|
||||
|
||||
-- | Initialize and run the layout monad, using all of the available screen space.
|
||||
initLayout :: (HasDisplaySize t m, MonadFix m) => Layout t m a -> m a
|
||||
initLayout :: (HasDisplayRegion t m, MonadFix m) => Layout t m a -> m a
|
||||
initLayout f = do
|
||||
dw <- displayWidth
|
||||
dh <- displayHeight
|
||||
@ -496,7 +496,7 @@ initLayout f = do
|
||||
|
||||
-- | Initialize a 'Layout' and 'Focus' management context, returning the produced 'FocusSet'.
|
||||
initManager
|
||||
:: (HasDisplaySize t m, Reflex t, MonadHold t m, MonadFix m)
|
||||
:: (HasDisplayRegion t m, Reflex t, MonadHold t m, MonadFix m)
|
||||
=> Layout t (Focus t m) a
|
||||
-> m (a, Dynamic t FocusSet)
|
||||
initManager =
|
||||
@ -504,7 +504,7 @@ initManager =
|
||||
|
||||
-- | Initialize a 'Layout' and 'Focus' management context.
|
||||
initManager_
|
||||
:: (HasDisplaySize t m, Reflex t, MonadHold t m, MonadFix m)
|
||||
:: (HasDisplayRegion t m, Reflex t, MonadHold t m, MonadFix m)
|
||||
=> Layout t (Focus t m) a
|
||||
-> m a
|
||||
initManager_ = fmap fst . initManager
|
||||
@ -517,7 +517,7 @@ initManager_ = fmap fst . initManager
|
||||
-- provided constraint. Returns the 'FocusId' allowing for manual focus
|
||||
-- management.
|
||||
tile'
|
||||
:: (MonadNodeId m, MonadFix m, Reflex t, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m, ImageWriter t m)
|
||||
:: (MonadNodeId m, MonadFix m, Reflex t, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m, HasImageWriter t m, HasDisplayRegion t m)
|
||||
=> Dynamic t Constraint
|
||||
-> m a
|
||||
-> m (FocusId, a)
|
||||
@ -536,7 +536,7 @@ tile' c w = do
|
||||
-- | A widget that is focusable and occupies a layout region based on the
|
||||
-- provided constraint.
|
||||
tile
|
||||
:: (MonadNodeId m, MonadFix m, Reflex t, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m, ImageWriter t m)
|
||||
:: (MonadNodeId m, MonadFix m, Reflex t, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m, HasImageWriter t m, HasDisplayRegion t m)
|
||||
=> Dynamic t Constraint
|
||||
-> m a
|
||||
-> m a
|
||||
@ -547,7 +547,7 @@ tile c = fmap snd . tile' c
|
||||
-- | A widget that is not focusable and occupies a layout region based on the
|
||||
-- provided constraint.
|
||||
grout
|
||||
:: (Reflex t, MonadNodeId m, HasVtyWidgetCtx t m, MonadLayout t m, HasVtyInput t m, ImageWriter t m)
|
||||
:: (Reflex t, MonadNodeId m, HasVtyWidgetCtx t m, MonadLayout t m, HasVtyInput t m, HasImageWriter t m, HasDisplayRegion t m)
|
||||
=> Dynamic t Constraint
|
||||
-> m a
|
||||
-> m a
|
||||
|
||||
Loading…
Reference in New Issue
Block a user