{-# Language UndecidableInstances #-}
module Reflex.Vty.Widget where
import Control.Applicative (liftA2)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Morph
import Control.Monad.NodeId
import Control.Monad.Reader (ReaderT, ask, local, runReaderT)
import Control.Monad.Ref
import Control.Monad.Trans (MonadTrans, lift)
import Data.Set (Set)
import qualified Data.Set as Set
import Graphics.Vty (Image)
import qualified Graphics.Vty as V
import Reflex
import Reflex.Class ()
import Reflex.Host.Class (MonadReflexCreateTrigger)
import Reflex.Vty.Host
mainWidgetWithHandle
:: V.Vty
-> (forall t m.
( MonadVtyApp t m
, HasImageWriter t m
, MonadNodeId m
, HasDisplayRegion t m
, HasFocusReader t m
, HasInput t m
, HasTheme t m
) => 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
(shutdown, images) <- runThemeReader (constant V.defAttr) $
runFocusReader (pure True) $
runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $
runImageWriter $
runNodeIdT $
runInput inp' $ 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
}
data VtyWidgetOut t = VtyWidgetOut
{ _vtyWidgetOut_shutdown :: Event t ()
}
mainWidget
:: (forall t m.
( MonadVtyApp t m
, HasImageWriter t m
, MonadNodeId m
, HasDisplayRegion t m
, HasFocusReader t m
, HasTheme t m
, HasInput t m
) => m (Event t ()))
-> IO ()
mainWidget child = do
vty <- getDefaultVty
mainWidgetWithHandle vty child
class HasInput t m | m -> t where
input :: m (Event t VtyEvent)
default input :: (f m' ~ m, Monad m', MonadTrans f, HasInput t m') => m (Event t VtyEvent)
input = lift input
localInput :: (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a
default localInput :: (f m' ~ m, Monad m', MFunctor f, HasInput t m') => (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a
localInput f = hoist (localInput f)
instance (Reflex t, Monad m) => HasInput t (Input t m) where
input = Input ask
localInput f (Input m) = Input $ local f m
newtype Input t m a = Input
{ unInput :: ReaderT (Event t VtyEvent) m a
} deriving
( Functor
, Applicative
, Monad
, MonadSample t
, MonadHold t
, MonadFix
, MonadIO
, MonadRef
)
instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (Input t m) where
runWithReplace a0 a' = Input $ runWithReplace (unInput a0) $ fmap unInput a'
traverseIntMapWithKeyWithAdjust f dm0 dm' = Input $
traverseIntMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm'
traverseDMapWithKeyWithAdjust f dm0 dm' = Input $ do
traverseDMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm'
traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = Input $ do
traverseDMapWithKeyWithAdjustWithMove (\k v -> unInput (f k v)) dm0 dm'
deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Input t m)
deriving instance NotReady t m => NotReady t (Input t m)
deriving instance PerformEvent t m => PerformEvent t (Input t m)
deriving instance PostBuild t m => PostBuild t (Input t m)
deriving instance TriggerEvent t m => TriggerEvent t (Input t m)
instance HasImageWriter t m => HasImageWriter t (Input t m)
instance HasDisplayRegion t m => HasDisplayRegion t (Input t m)
instance HasFocusReader t m => HasFocusReader t (Input t m)
instance MonadTrans (Input t) where
lift f = Input $ lift f
instance MFunctor (Input t) where
hoist f = Input . hoist f . unInput
instance MonadNodeId m => MonadNodeId (Input t m)
runInput
:: Reflex t
=> Event t VtyEvent
-> Input t m a
-> m a
runInput e w = runReaderT (unInput w) e
type KeyCombo = (V.Key, [V.Modifier])
key :: (Monad m, Reflex t, HasInput t m) => V.Key -> m (Event t KeyCombo)
key = keyCombos . Set.singleton . (,[])
keys :: (Monad m, Reflex t, HasInput t m) => [V.Key] -> m (Event t KeyCombo)
keys = keyCombos . Set.fromList . fmap (,[])
keyCombo
:: (Reflex t, Monad m, HasInput t m)
=> KeyCombo
-> m (Event t KeyCombo)
keyCombo = keyCombos . Set.singleton
keyCombos
:: (Reflex t, Monad m, HasInput t m)
=> Set KeyCombo
-> 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
filterKeys :: (Reflex t, HasInput t m) => (KeyCombo -> Bool) -> m a -> m a
filterKeys f x = localInput (ffilter (\case
V.EvKey k mods -> f (k, mods)
_ -> True)) x
mouseInRegion :: Region -> VtyEvent -> Maybe VtyEvent
mouseInRegion (Region l t w h) e = case e of
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))
inputInFocusedRegion
:: (HasDisplayRegion t m, HasFocusReader t m, HasInput t m)
=> m (Event t VtyEvent)
inputInFocusedRegion = do
inp <- input
reg <- current <$> askRegion
foc <- current <$> focus
pure $ fmapMaybe id $ attachWith filterInput ((,) <$> reg <*> foc) inp
where
filterInput (r, f) = \case
V.EvKey {} | not f -> Nothing
x -> mouseInRegion r x
data Region = Region
{ _region_left :: Int
, _region_top :: Int
, _region_width :: Int
, _region_height :: Int
}
deriving (Show, Read, Eq, Ord)
nilRegion :: Region
nilRegion = Region 0 0 0 0
regionSize :: Region -> (Int, Int)
regionSize (Region _ _ w h) = (w, h)
regionBlankImage :: V.Attr -> Region -> Image
regionBlankImage attr r@(Region _ _ width height) =
withinImage r $ V.charFill attr ' ' width height
class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where
askRegion :: m (Dynamic t Region)
default askRegion :: (f m' ~ m, MonadTrans f, HasDisplayRegion t m') => m (Dynamic t Region)
askRegion = lift askRegion
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)
displayWidth :: HasDisplayRegion t m => m (Dynamic t Int)
displayWidth = fmap _region_width <$> askRegion
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 HasFocusReader t m => HasFocusReader 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
class (Reflex t, Monad m) => HasFocusReader t m | m -> t where
focus :: m (Dynamic t Bool)
default focus :: (f m' ~ m, Monad m', MonadTrans f, HasFocusReader t m') => m (Dynamic t Bool)
focus = lift focus
localFocus :: (Dynamic t Bool -> Dynamic t Bool) -> m a -> m a
default localFocus :: (f m' ~ m, Monad m', MFunctor f, HasFocusReader t m') => (Dynamic t Bool -> Dynamic t Bool) -> m a -> m a
localFocus f = hoist (localFocus f)
instance HasFocusReader t m => HasFocusReader t (ReaderT x m)
instance HasFocusReader t m => HasFocusReader t (BehaviorWriterT t x m)
instance HasFocusReader t m => HasFocusReader t (DynamicWriterT t x m)
instance HasFocusReader t m => HasFocusReader t (EventWriterT t x m)
instance HasFocusReader t m => HasFocusReader t (NodeIdT m)
newtype FocusReader t m a = FocusReader
{ unFocusReader :: ReaderT (Dynamic t Bool) m a }
deriving
( Functor
, Applicative
, Monad
, MonadFix
, MonadHold t
, MonadIO
, MonadRef
, MonadSample t
)
instance (Monad m, Reflex t) => HasFocusReader t (FocusReader t m) where
focus = FocusReader ask
localFocus f = FocusReader . local f . unFocusReader
deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (FocusReader t m)
deriving instance NotReady t m => NotReady t (FocusReader t m)
deriving instance PerformEvent t m => PerformEvent t (FocusReader t m)
deriving instance PostBuild t m => PostBuild t (FocusReader t m)
deriving instance TriggerEvent t m => TriggerEvent t (FocusReader t m)
instance HasImageWriter t m => HasImageWriter t (FocusReader t m)
instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (FocusReader t m) where
runWithReplace (FocusReader a) e = FocusReader $ runWithReplace a $ fmap unFocusReader e
traverseIntMapWithKeyWithAdjust f m e = FocusReader $ traverseIntMapWithKeyWithAdjust (\k v -> unFocusReader $ f k v) m e
traverseDMapWithKeyWithAdjust f m e = FocusReader $ traverseDMapWithKeyWithAdjust (\k v -> unFocusReader $ f k v) m e
traverseDMapWithKeyWithAdjustWithMove f m e = FocusReader $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocusReader $ f k v) m e
instance MonadTrans (FocusReader t) where
lift = FocusReader . lift
instance MFunctor (FocusReader t) where
hoist f = FocusReader . hoist f . unFocusReader
instance MonadNodeId m => MonadNodeId (FocusReader t m)
runFocusReader
:: (Reflex t, Monad m)
=> Dynamic t Bool
-> FocusReader t m a
-> m a
runFocusReader b = flip runReaderT b . unFocusReader
class (Reflex t, Monad m) => HasImageWriter t m | m -> t where
tellImages :: Behavior t [Image] -> m ()
default tellImages :: (f m' ~ m, Monad m', MonadTrans f, HasImageWriter t m') => Behavior t [Image] -> m ()
tellImages = lift . tellImages
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)
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
tellBehavior $ f images
pure a
instance HasDisplayRegion t m => HasDisplayRegion t (ImageWriter t m)
instance HasFocusReader t m => HasFocusReader t (ImageWriter t m)
runImageWriter
:: (Reflex t, Monad m)
=> ImageWriter t m a
-> m (a, Behavior t [Image])
runImageWriter = runBehaviorWriterT . unImageWriter
class (Reflex t, Monad m) => HasTheme t m | m -> t where
theme :: m (Behavior t V.Attr)
default theme :: (f m' ~ m, Monad m', MonadTrans f, HasTheme t m') => m (Behavior t V.Attr)
theme = lift theme
localTheme :: (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a
default localTheme :: (f m' ~ m, Monad m', MFunctor f, HasTheme t m') => (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a
localTheme f = hoist (localTheme f)
instance HasTheme t m => HasTheme t (ReaderT x m)
instance HasTheme t m => HasTheme t (BehaviorWriterT t x m)
instance HasTheme t m => HasTheme t (DynamicWriterT t x m)
instance HasTheme t m => HasTheme t (EventWriterT t x m)
instance HasTheme t m => HasTheme t (NodeIdT m)
instance HasTheme t m => HasTheme t (Input t m)
instance HasTheme t m => HasTheme t (ImageWriter t m)
instance HasTheme t m => HasTheme t (DisplayRegion t m)
instance HasTheme t m => HasTheme t (FocusReader t m)
newtype ThemeReader t m a = ThemeReader
{ unThemeReader :: ReaderT (Behavior t V.Attr) m a }
deriving
( Functor
, Applicative
, Monad
, MonadFix
, MonadHold t
, MonadIO
, MonadRef
, MonadSample t
)
instance (Monad m, Reflex t) => HasTheme t (ThemeReader t m) where
theme = ThemeReader ask
localTheme f = ThemeReader . local f . unThemeReader
deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ThemeReader t m)
deriving instance NotReady t m => NotReady t (ThemeReader t m)
deriving instance PerformEvent t m => PerformEvent t (ThemeReader t m)
deriving instance PostBuild t m => PostBuild t (ThemeReader t m)
deriving instance TriggerEvent t m => TriggerEvent t (ThemeReader t m)
instance HasImageWriter t m => HasImageWriter t (ThemeReader t m)
instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ThemeReader t m) where
runWithReplace (ThemeReader a) e = ThemeReader $ runWithReplace a $ fmap unThemeReader e
traverseIntMapWithKeyWithAdjust f m e = ThemeReader $ traverseIntMapWithKeyWithAdjust (\k v -> unThemeReader $ f k v) m e
traverseDMapWithKeyWithAdjust f m e = ThemeReader $ traverseDMapWithKeyWithAdjust (\k v -> unThemeReader $ f k v) m e
traverseDMapWithKeyWithAdjustWithMove f m e = ThemeReader $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unThemeReader $ f k v) m e
instance MonadTrans (ThemeReader t) where
lift = ThemeReader . lift
instance MFunctor (ThemeReader t) where
hoist f = ThemeReader . hoist f . unThemeReader
instance MonadNodeId m => MonadNodeId (ThemeReader t m)
runThemeReader
:: (Reflex t, Monad m)
=> Behavior t V.Attr
-> ThemeReader t m a
-> m a
runThemeReader b = flip runReaderT b . unThemeReader
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
imagesInRegion
:: Reflex t
=> Behavior t Region
-> Behavior t [Image]
-> Behavior t [Image]
imagesInRegion reg = liftA2 (\r is -> map (withinImage r) is) reg
pane
:: (Reflex t, Monad m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
=> Dynamic t Region
-> Dynamic t Bool
-> m a
-> m a
pane dr foc child = localRegion (const dr) $
mapImages (imagesInRegion $ current dr) $
localFocus (const foc) $
inputInFocusedRegion >>= \e -> localInput (const e) child
blank :: Monad m => m ()
blank = return ()