{-# 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
, ScrollDirection(..)
, mouseScroll
, pane
, splitV
, splitH
, splitVDrag
, boxTitle
, box
, boxStatic
, RichTextConfig(..)
, richText
, text
, scrollableText
, display
, BoxStyle(..)
, hyphenBoxStyle
, singleBoxStyle
, roundedBoxStyle
, thickBoxStyle
, doubleBoxStyle
, fill
, hRule
, KeyCombo
, key
, keys
, keyCombo
, keyCombos
, blank
) where
import Control.Applicative (liftA2)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (ReaderT, ask, asks, runReaderT)
import Control.Monad.Trans (MonadTrans, 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
data VtyWidgetCtx t = VtyWidgetCtx
{ _vtyWidgetCtx_width :: Dynamic t Int
, _vtyWidgetCtx_height :: Dynamic t Int
, _vtyWidgetCtx_focus :: Dynamic t Bool
, _vtyWidgetCtx_input :: Event t VtyEvent
}
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'
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
runVtyWidget
:: (Reflex t, MonadNodeId m)
=> VtyWidgetCtx t
-> VtyWidget t m a
-> m (a, Behavior t [Image])
runVtyWidget ctx w = runReaderT (runBehaviorWriterT (unVtyWidget w)) ctx
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
}
mainWidget
:: (forall t m. (MonadVtyApp t m, MonadNodeId m) => VtyWidget t m (Event t ()))
-> IO ()
mainWidget child = do
vty <- getDefaultVty
mainWidgetWithHandle vty child
class (Reflex t, Monad m) => HasDisplaySize t m | m -> t where
displayWidth :: m (Dynamic t Int)
default displayWidth :: (f m' ~ m, MonadTrans f, HasDisplaySize t m') => m (Dynamic t Int)
displayWidth = lift displayWidth
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)
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
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
class (Reflex t, Monad m) => ImageWriter t m | m -> t where
tellImages :: Behavior t [Image] -> m ()
instance (Monad m, Reflex t) => ImageWriter t (BehaviorWriterT t [Image] m) where
tellImages = tellBehavior
data Region = Region
{ _region_left :: Int
, _region_top :: Int
, _region_width :: Int
, _region_height :: Int
}
deriving (Show, Read, Eq, Ord)
data DynRegion t = DynRegion
{ _dynRegion_left :: Dynamic t Int
, _dynRegion_top :: Dynamic t Int
, _dynRegion_width :: Dynamic t Int
, _dynRegion_height :: Dynamic t Int
}
regionSize :: Region -> (Int, Int)
regionSize (Region _ _ w h) = (w, h)
regionBlankImage :: Region -> Image
regionBlankImage r@(Region _ _ width height) =
withinImage r $ V.charFill V.defAttr ' ' width height
currentRegion :: Reflex t => DynRegion t -> Behavior t Region
currentRegion (DynRegion l t w h) = Region <$> current l <*> current t <*> current w <*> current h
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
pane
:: (Reflex t, Monad m, MonadNodeId m)
=> DynRegion t
-> Dynamic t Bool
-> 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
[ 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))
data Drag = Drag
{ _drag_from :: (Int, Int)
, _drag_to :: (Int, Int)
, _drag_button :: V.Button
, _drag_modifiers :: [V.Modifier]
, _drag_end :: Bool
}
deriving (Eq, Ord, Show)
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 && btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods' False
| btn == btn' -> Just $ Drag from (x,y) btn mods' False
| otherwise -> Nothing
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
| 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)
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
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
data MouseDown = MouseDown
{ _mouseDown_button :: V.Button
, _mouseDown_coordinates :: (Int, Int)
, _mouseDown_modifiers :: [V.Modifier]
}
deriving (Eq, Ord, Show)
data MouseUp = MouseUp
{ _mouseUp_button :: Maybe V.Button
, _mouseUp_coordinates :: (Int, Int)
}
deriving (Eq, Ord, Show)
data ScrollDirection = ScrollDirection_Up | ScrollDirection_Down
deriving (Eq, Ord, Show)
mouseScroll
:: (Reflex t, Monad m)
=> VtyWidget t m (Event t ScrollDirection)
mouseScroll = do
up <- mouseDown V.BScrollUp
down <- mouseDown V.BScrollDown
return $ leftmost
[ ScrollDirection_Up <$ up
, ScrollDirection_Down <$ down
]
type KeyCombo = (V.Key, [V.Modifier])
key :: (Monad m, Reflex t) => V.Key -> VtyWidget t m (Event t KeyCombo)
key = keyCombos . Set.singleton . (,[])
keys :: (Monad m, Reflex t) => [V.Key] -> VtyWidget t m (Event t KeyCombo)
keys = keyCombos . Set.fromList . fmap (,[])
keyCombo
:: (Reflex t, Monad m)
=> KeyCombo
-> VtyWidget t m (Event t KeyCombo)
keyCombo = keyCombos . Set.singleton
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
splitV :: (Reflex t, Monad m, MonadNodeId m)
=> Dynamic t (Int -> Int)
-> Dynamic t (Bool, Bool)
-> VtyWidget t m a
-> VtyWidget t m b
-> 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)
splitH :: (Reflex t, Monad m, MonadNodeId m)
=> Dynamic t (Int -> Int)
-> Dynamic t (Bool, Bool)
-> VtyWidget t m a
-> VtyWidget t m b
-> VtyWidget t m (a,b)
splitH sizeFunD focD wA wB = do
dw <- displayWidth
dh <- displayHeight
let regA = DynRegion
{ _dynRegion_left = pure 0
, _dynRegion_top = pure 0
, _dynRegion_width = sizeFunD <*> dw
, _dynRegion_height = dh
}
regB = DynRegion
{ _dynRegion_left = _dynRegion_width regA
, _dynRegion_top = pure 0
, _dynRegion_width = liftA2 (-) dw (_dynRegion_width regA)
, _dynRegion_height = dh
}
liftA2 (,) (pane regA (fmap fst focD) wA) (pane regB (fmap snd focD) wB)
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
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 :: (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
hRule :: (Reflex t, Monad m) => BoxStyle -> VtyWidget t m ()
hRule boxStyle = fill (_boxStyle_s boxStyle)
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
hyphenBoxStyle :: BoxStyle
hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'
singleBoxStyle :: BoxStyle
singleBoxStyle = BoxStyle '┌' '─' '┐' '│' '┘' '─' '└' '│'
thickBoxStyle :: BoxStyle
thickBoxStyle = BoxStyle '┏' '━' '┓' '┃' '┛' '━' '┗' '┃'
doubleBoxStyle :: BoxStyle
doubleBoxStyle = BoxStyle '╔' '═' '╗' '║' '╝' '═' '╚' '║'
roundedBoxStyle :: BoxStyle
roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
boxTitle :: (Monad m, Reflex t, MonadNodeId m)
=> Behavior t BoxStyle
-> Text
-> VtyWidget t m a
-> VtyWidget t m a
boxTitle boxStyle title 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.text' V.defAttr $
hPadText title (_boxStyle_n style) (width - 2)
, 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 []
hPadText :: T.Text -> Char -> Int -> T.Text
hPadText t c l = if lt >= l
then t
else left <> t <> right
where
lt = T.length t
delta = l - lt
mkHalf n = T.replicate (n `div` 2) (T.singleton c)
left = mkHalf $ delta + 1
right = mkHalf delta
box :: (Monad m, Reflex t, MonadNodeId m)
=> Behavior t BoxStyle
-> VtyWidget t m a
-> VtyWidget t m a
box boxStyle = boxTitle boxStyle mempty
boxStatic
:: (Reflex t, Monad m, MonadNodeId m)
=> BoxStyle
-> VtyWidget t m a
-> VtyWidget t m a
boxStatic = box . pure
data RichTextConfig t = RichTextConfig
{ _richTextConfig_attributes :: Behavior t V.Attr
}
instance Reflex t => Default (RichTextConfig t) where
def = RichTextConfig $ pure V.defAttr
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')
text
:: (Reflex t, Monad m)
=> Behavior t Text
-> VtyWidget t m ()
text = richText def
scrollableText
:: forall t m. (Reflex t, MonadHold t m, MonadFix m)
=> Event t Int
-> Behavior t Text
-> VtyWidget t m (Behavior t (Int, Int))
scrollableText scrollBy t = do
dw <- displayWidth
let imgs = wrap <$> current dw <*> t
kup <- key V.KUp
kdown <- key V.KDown
m <- mouseScroll
let requestedScroll :: Event t Int
requestedScroll = leftmost
[ 1 <$ kdown
, (-1) <$ kup
, ffor m $ \case
ScrollDirection_Up -> (-1)
ScrollDirection_Down -> 1
, scrollBy
]
updateLine maxN delta ix = min (max 0 (ix + delta)) maxN
lineIndex :: Dynamic t Int <- foldDyn (\(maxN, delta) ix -> updateLine (maxN - 1) delta ix) 0 $
attach (length <$> imgs) requestedScroll
tellImages $ fmap ((:[]) . V.vertCat) $ drop <$> current lineIndex <*> imgs
return $ (,) <$> ((+) <$> current lineIndex <*> pure 1) <*> (length <$> imgs)
where
wrap maxWidth = concatMap (fmap (V.string V.defAttr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')
display
:: (Reflex t, Monad m, Show a)
=> Behavior t a
-> VtyWidget t m ()
display a = text $ T.pack . show <$> a
blank :: Monad m => VtyWidget t m ()
blank = return ()