module Graphics.Vty.Widgets.Core
(
WidgetImpl(..)
, Widget
, getNormalAttr
, defaultContext
, updateWidget
, updateWidgetState
, newWidget
, getState
, getCurrentSize
, setCurrentPosition
, getCurrentPosition
, growVertical
, growHorizontal
, getCursorPosition
, showWidget
, getVisible
, setVisible
, (<~)
, (<~~)
, RenderContext(..)
, RenderError(..)
, render
, renderAndPosition
, HasNormalAttr(..)
, HasFocusAttr(..)
, withNormalAttribute
, withFocusAttribute
, handleKeyEvent
, onKeyPressed
, onGainFocus
, onLoseFocus
, onResize
, relayKeyEvents
, relayFocusEvents
, FocusGroup
, FocusGroupError(..)
, newFocusGroup
, mergeFocusGroups
, appendFocusGroup
, resetFocusGroup
, addToFocusGroup
, focusNext
, focusPrevious
, setFocusGroupNextKey
, setFocusGroupPrevKey
, focus
, unfocus
)
where
import Data.Typeable
import Data.IORef
import Control.Applicative
import Control.Monad
import Control.Exception
import Graphics.Vty
import Graphics.Vty.Widgets.Util
import Graphics.Vty.Widgets.Skins
import Graphics.Vty.Widgets.Events
class HasNormalAttr w where
setNormalAttribute :: w -> Attr -> IO ()
class HasFocusAttr w where
setFocusAttribute :: w -> Attr -> IO ()
instance HasNormalAttr (Widget a) where
setNormalAttribute wRef a =
updateWidget wRef $ \w -> w { normalAttribute = mergeAttr a (normalAttribute w) }
instance HasFocusAttr (Widget a) where
setFocusAttribute wRef a =
updateWidget wRef $ \w -> w { focusAttribute = mergeAttr a (focusAttribute w) }
withNormalAttribute :: (HasNormalAttr w) => Attr -> w -> IO w
withNormalAttribute att w = do
setNormalAttribute w att
return w
withFocusAttribute :: (HasFocusAttr w) => Attr -> w -> IO w
withFocusAttribute att w = do
setFocusAttribute w att
return w
data RenderError = ImageTooBig String DisplayRegion DisplayRegion
deriving (Show, Typeable)
instance Exception RenderError
data RenderContext =
RenderContext { normalAttr :: Attr
, focusAttr :: Attr
, overrideAttr :: Attr
, skin :: Skin
}
getNormalAttr :: RenderContext -> Attr
getNormalAttr ctx = mergeAttrs [ overrideAttr ctx, normalAttr ctx ]
defaultContext :: RenderContext
defaultContext = RenderContext def_attr (white `on` blue) def_attr unicodeSkin
data WidgetImpl a = WidgetImpl {
state :: !a
, visible :: !Bool
, render_ :: Widget a -> DisplayRegion -> RenderContext -> IO Image
, growHorizontal_ :: a -> IO Bool
, growVertical_ :: a -> IO Bool
, currentSize :: DisplayRegion
, currentPosition :: DisplayRegion
, normalAttribute :: Attr
, focusAttribute :: Attr
, setCurrentPosition_ :: Widget a -> DisplayRegion -> IO ()
, keyEventHandler :: Widget a -> Key -> [Modifier] -> IO Bool
, gainFocusHandlers :: Handlers (Widget a)
, resizeHandlers :: Handlers (DisplayRegion, DisplayRegion)
, loseFocusHandlers :: Handlers (Widget a)
, focused :: Bool
, getCursorPosition_ :: Widget a -> IO (Maybe DisplayRegion)
}
type Widget a = IORef (WidgetImpl a)
showWidget :: (Show a) => Widget a -> IO String
showWidget wRef = show <$> readIORef wRef
instance (Show a) => Show (WidgetImpl a) where
show w = concat [ "WidgetImpl { "
, show $ state w
, ", currentSize = "
, show $ currentSize w
, ", currentPosition = "
, show $ currentPosition w
, ", focused = "
, show $ focused w
, " }"
]
setVisible :: Widget a -> Bool -> IO ()
setVisible wRef v = updateWidget wRef $ \st -> st { visible = v }
getVisible :: Widget a -> IO Bool
getVisible = (visible <~)
growHorizontal :: Widget a -> IO Bool
growHorizontal w = do
v <- visible <~ w
case v of
True -> do
act <- growHorizontal_ <~ w
st <- state <~ w
act st
False -> return False
growVertical :: Widget a -> IO Bool
growVertical w = do
v <- visible <~ w
case v of
True -> do
act <- growVertical_ <~ w
st <- state <~ w
act st
False -> return False
render :: (Show a) =>
Widget a
-> DisplayRegion
-> RenderContext
-> IO Image
render wRef sz ctx = do
impl <- readIORef wRef
v <- visible <~ wRef
case v of
False -> return empty_image
True -> do
norm <- normalAttribute <~ wRef
foc <- focusAttribute <~ wRef
let newCtx = ctx { normalAttr = mergeAttr norm $ normalAttr ctx
, focusAttr = mergeAttr foc $ focusAttr ctx
}
img <- render_ impl wRef sz newCtx
let imgsz = DisplayRegion (image_width img) (image_height img)
when (image_width img > region_width sz ||
image_height img > region_height sz) $ throw $ ImageTooBig (show impl) sz imgsz
setCurrentSize wRef $ DisplayRegion (image_width img) (image_height img)
return img
renderAndPosition :: (Show a) =>
Widget a
-> DisplayRegion
-> DisplayRegion
-> RenderContext
-> IO Image
renderAndPosition wRef pos sz ctx = do
img <- render wRef sz ctx
setCurrentPosition wRef pos
return img
setCurrentSize :: Widget a -> DisplayRegion -> IO ()
setCurrentSize wRef newSize = do
oldSize <- getCurrentSize wRef
modifyIORef wRef $ \w ->
let new = w { currentSize = newSize }
in seq new new
when (oldSize /= newSize) $ handleResizeEvent wRef (oldSize, newSize)
getCurrentSize :: Widget a -> IO DisplayRegion
getCurrentSize wRef = (return . currentSize) =<< (readIORef wRef)
getCurrentPosition :: Widget a -> IO DisplayRegion
getCurrentPosition wRef = currentPosition <$> (readIORef wRef)
setCurrentPosition :: Widget a -> DisplayRegion -> IO ()
setCurrentPosition wRef pos = do
updateWidget wRef $ \w -> w { currentPosition = pos }
w <- readIORef wRef
(setCurrentPosition_ w) wRef pos
newWidget :: a
-> (WidgetImpl a -> WidgetImpl a)
-> IO (Widget a)
newWidget initState f = do
gfhs <- newHandlers
lfhs <- newHandlers
rhs <- newHandlers
wRef <- newIORef $
WidgetImpl { state = initState
, render_ = \_ _ _ -> return empty_image
, growVertical_ = const $ return False
, growHorizontal_ = const $ return False
, setCurrentPosition_ = \_ _ -> return ()
, currentSize = DisplayRegion 0 0
, currentPosition = DisplayRegion 0 0
, focused = False
, visible = True
, gainFocusHandlers = gfhs
, resizeHandlers = rhs
, loseFocusHandlers = lfhs
, keyEventHandler = \_ _ _ -> return False
, getCursorPosition_ = defaultCursorInfo
, normalAttribute = def_attr
, focusAttribute = def_attr
}
updateWidget wRef f
return wRef
defaultCursorInfo :: Widget a -> IO (Maybe DisplayRegion)
defaultCursorInfo w = do
sz <- getCurrentSize w
pos <- getCurrentPosition w
if region_width sz > 0 then
return $ Just $ pos `plusWidth` (region_width sz 1) else
return Nothing
handleKeyEvent :: Widget a -> Key -> [Modifier] -> IO Bool
handleKeyEvent wRef keyEvent mods = do
act <- keyEventHandler <~ wRef
act wRef keyEvent mods
handleResizeEvent :: Widget a -> (DisplayRegion, DisplayRegion) -> IO ()
handleResizeEvent wRef szs = fireEvent wRef (resizeHandlers <~) szs
relayKeyEvents :: Widget a -> Widget b -> IO ()
relayKeyEvents a b = a `onKeyPressed` \_ k mods -> handleKeyEvent b k mods
relayFocusEvents :: Widget a -> Widget b -> IO ()
relayFocusEvents a b = do
a `onGainFocus` \_ -> focus b
a `onLoseFocus` \_ -> unfocus b
onKeyPressed :: Widget a -> (Widget a -> Key -> [Modifier] -> IO Bool) -> IO ()
onKeyPressed wRef handler = do
oldHandler <- keyEventHandler <~ wRef
let combinedHandler =
\w k ms -> do
v <- handler w k ms
case v of
True -> return True
False -> oldHandler w k ms
updateWidget wRef $ \w -> w { keyEventHandler = combinedHandler }
focus :: Widget a -> IO ()
focus wRef = do
updateWidget wRef $ \w -> w { focused = True }
fireEvent wRef (gainFocusHandlers <~) wRef
unfocus :: Widget a -> IO ()
unfocus wRef = do
updateWidget wRef $ \w -> w { focused = False }
fireEvent wRef (loseFocusHandlers <~) wRef
onGainFocus :: Widget a -> (Widget a -> IO ()) -> IO ()
onGainFocus = addHandler (gainFocusHandlers <~)
onResize :: Widget a -> ((DisplayRegion, DisplayRegion) -> IO ()) -> IO ()
onResize = addHandler (resizeHandlers <~)
onLoseFocus :: Widget a -> (Widget a -> IO ()) -> IO ()
onLoseFocus = addHandler (loseFocusHandlers <~)
(<~) :: (a -> b) -> IORef a -> IO b
(<~) f wRef = (return . f) =<< (readIORef wRef)
(<~~) :: (a -> b) -> Widget a -> IO b
(<~~) f wRef = (return . f . state) =<< (readIORef wRef)
updateWidget :: Widget a -> (WidgetImpl a -> WidgetImpl a) -> IO ()
updateWidget wRef f = modifyIORef wRef $ \val -> let new = f val
in seq new new
getState :: Widget a -> IO a
getState wRef = state <~ wRef
updateWidgetState :: Widget a -> (a -> a) -> IO ()
updateWidgetState wRef f = do
w <- readIORef wRef
writeIORef wRef $ let new = w { state = f (state w) }
in seq new new
data FocusGroupError = FocusGroupEmpty
| FocusGroupBadIndex Int
deriving (Typeable, Show)
instance Exception FocusGroupError
data FocusEntry = forall a. FocusEntry (Widget a)
data FocusGroup = FocusGroup { entries :: [Widget FocusEntry]
, currentEntryNum :: Int
, nextKey :: (Key, [Modifier])
, prevKey :: (Key, [Modifier])
}
newFocusEntry :: (Show a) => Widget a -> IO (Widget FocusEntry)
newFocusEntry chRef = do
let st = FocusEntry chRef
wRef <- newWidget st $ \w ->
w { growHorizontal_ = const $ growHorizontal chRef
, growVertical_ = const $ growVertical chRef
, render_ = \_ sz ctx -> render chRef sz ctx
, setCurrentPosition_ =
\this pos -> do
(FocusEntry ch) <- getState this
setCurrentPosition ch pos
}
wRef `relayFocusEvents` chRef
wRef `relayKeyEvents` chRef
return wRef
newFocusGroup :: IO (Widget FocusGroup)
newFocusGroup = do
let initSt = FocusGroup { entries = []
, currentEntryNum = 1
, nextKey = (KASCII '\t', [])
, prevKey = (KBackTab, [])
}
wRef <- newWidget initSt $ \w ->
w { getCursorPosition_ =
\this -> do
cur <- currentEntryNum <~~ this
case cur of
(1) -> return Nothing
_ -> do
eRef <- currentEntry this
(FocusEntry e) <- state <~ eRef
getCursorPosition e
, keyEventHandler =
\this key mods -> do
st <- getState this
case currentEntryNum st of
(1) -> return False
i -> do
if (key, mods) == nextKey st then
(focusNext this >> return True) else
if (key, mods) == prevKey st then
(focusPrevious this >> return True) else
do
let e = entries st !! i
handleKeyEvent e key mods
}
return wRef
setFocusGroupNextKey :: Widget FocusGroup -> Key -> [Modifier] -> IO ()
setFocusGroupNextKey fg k mods =
updateWidgetState fg $ \s -> s { nextKey = (k, mods) }
setFocusGroupPrevKey :: Widget FocusGroup -> Key -> [Modifier] -> IO ()
setFocusGroupPrevKey fg k mods =
updateWidgetState fg $ \s -> s { prevKey = (k, mods) }
mergeFocusGroups :: Widget FocusGroup -> Widget FocusGroup -> IO (Widget FocusGroup)
mergeFocusGroups a b = do
c <- newFocusGroup
aEntries <- entries <~~ a
bEntries <- entries <~~ b
when (null aEntries && null bEntries) $
throw FocusGroupEmpty
updateWidgetState c $ \s -> s { entries = aEntries ++ bEntries
, currentEntryNum = 0
}
forM_ (zip [0..] aEntries) $ \(i, e) -> do
(FocusEntry w) <- state <~ e
w `onGainFocus` (const $ setCurrentFocus c i)
forM_ (zip [(length aEntries)..] bEntries) $ \(i, e) -> do
(FocusEntry w) <- state <~ e
w `onGainFocus` (const $ setCurrentFocus c i)
return c
appendFocusGroup :: Widget FocusGroup -> Widget FocusGroup -> IO ()
appendFocusGroup a b = do
aEntries <- entries <~~ a
bEntries <- entries <~~ b
when (null bEntries) $
throw FocusGroupEmpty
updateWidgetState a $ \s -> s { entries = (entries s) ++ bEntries
, currentEntryNum = 0
}
forM_ (zip [(length aEntries)..] bEntries) $ \(i, e) -> do
(FocusEntry w) <- state <~ e
w `onGainFocus` (const $ setCurrentFocus a i)
resetFocusGroup :: Widget FocusGroup -> IO ()
resetFocusGroup fg = do
cur <- currentEntryNum <~~ fg
es <- entries <~~ fg
forM_ (zip [0..] es) $ \(i, e) ->
when (i /= cur) $ unfocus e
when (cur >= 0) $
focus =<< currentEntry fg
getCursorPosition :: Widget a -> IO (Maybe DisplayRegion)
getCursorPosition wRef = do
v <- visible <~ wRef
case v of
True -> do
ci <- getCursorPosition_ <~ wRef
ci wRef
False -> return Nothing
currentEntry :: Widget FocusGroup -> IO (Widget FocusEntry)
currentEntry wRef = do
es <- entries <~~ wRef
i <- currentEntryNum <~~ wRef
when (i == 1) $ throw FocusGroupEmpty
return (es !! i)
addToFocusGroup :: (Show a) => Widget FocusGroup -> Widget a -> IO (Widget FocusEntry)
addToFocusGroup cRef wRef = do
eRef <- newFocusEntry wRef
entryPos <- (length . entries) <~~ cRef
updateWidgetState cRef $ \s -> s { entries = (entries s) ++ [eRef] }
wRef `onGainFocus` \_ ->
setCurrentFocus cRef entryPos
when (entryPos == 0) $ focus eRef
return eRef
focusNext :: Widget FocusGroup -> IO ()
focusNext wRef = do
st <- getState wRef
let cur = currentEntryNum st
when (cur == 1) $ throw FocusGroupEmpty
let nextEntry = if cur < length (entries st) 1 then
(entries st) !! (cur + 1) else
(entries st) !! 0
focus nextEntry
focusPrevious :: Widget FocusGroup -> IO ()
focusPrevious wRef = do
st <- getState wRef
let cur = currentEntryNum st
when (cur == 1) $ throw FocusGroupEmpty
let prevEntry = if cur > 0 then
(entries st) !! (cur 1) else
(entries st) !! (length (entries st) 1)
focus prevEntry
setCurrentFocus :: Widget FocusGroup -> Int -> IO ()
setCurrentFocus cRef i = do
st <- state <~ cRef
when (i >= length (entries st) || i < 0) $
throw $ FocusGroupBadIndex i
when (currentEntryNum st /= i) $
do
when (currentEntryNum st >= 0) $
unfocus ((entries st) !! (currentEntryNum st))
updateWidgetState cRef $ \s -> s { currentEntryNum = i }