mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-10-26 19:49:50 +03:00
Basic scrollbar display, minor general improvements and tests that will not stand the test of time
This commit is contained in:
Francisco Vallarino
parent
79faed3625
commit
b316848600
2
.gitignore
vendored
2
.gitignore
vendored
@ -1,7 +1,5 @@
|
||||
.stack-work/
|
||||
.vscode/
|
||||
app copy/
|
||||
src copy/
|
||||
hs-GUI.cabal
|
||||
*~
|
||||
*.prof
|
||||
|
||||
15
app/Main.hs
15
app/Main.hs
@ -124,8 +124,8 @@ buildUI model = styledTree where
|
||||
textField `style` textStyle
|
||||
],
|
||||
hgrid [
|
||||
scroll $ label "This is a really really really long label, you know?" `style` labelStyle,
|
||||
label "Short"
|
||||
label "Short",
|
||||
scroll $ label "This is a really really really long label, you know?" `style` labelStyle
|
||||
],
|
||||
hgrid [
|
||||
button (Action1 1) `style` buttonStyle,
|
||||
@ -186,13 +186,13 @@ handleSystemEvents :: Renderer WidgetM -> [W.SystemEvent] -> TR.Path -> WidgetTr
|
||||
handleSystemEvents renderer systemEvents currentFocus widgets =
|
||||
foldM (\newWidgets event -> handleSystemEvent renderer event currentFocus newWidgets) widgets systemEvents
|
||||
|
||||
handleEvent :: Renderer WidgetM -> W.SystemEvent -> TR.Path -> WidgetTree -> (Bool, SQ.Seq AppEvent, Maybe WidgetTree)
|
||||
handleEvent :: Renderer WidgetM -> W.SystemEvent -> TR.Path -> WidgetTree -> (Bool, [W.EventRequest], SQ.Seq AppEvent, Maybe WidgetTree)
|
||||
handleEvent renderer systemEvent@(W.Click point _ _) currentFocus widgets = W.handleEventFromPoint point widgets systemEvent
|
||||
handleEvent renderer systemEvent@(W.KeyAction _ _) currentFocus widgets = W.handleEventFromPath currentFocus widgets systemEvent
|
||||
|
||||
handleSystemEvent :: Renderer WidgetM -> W.SystemEvent -> TR.Path -> WidgetTree -> AppM WidgetTree
|
||||
handleSystemEvent renderer systemEvent currentFocus widgets = do
|
||||
let (stop, appEvents, newWidgets) = handleEvent renderer systemEvent currentFocus widgets
|
||||
let (stop, eventRequests, appEvents, newWidgets) = handleEvent renderer systemEvent currentFocus widgets
|
||||
let newRoot = fromMaybe widgets newWidgets
|
||||
|
||||
updatedRoot <- if (not stop && isKeyPressed systemEvent keycodeTab) then do
|
||||
@ -203,11 +203,16 @@ handleSystemEvent renderer systemEvent currentFocus widgets = do
|
||||
else
|
||||
return newRoot
|
||||
|
||||
if length appEvents == 0 then
|
||||
updatedRoot2 <- if length appEvents == 0 then
|
||||
return updatedRoot
|
||||
else
|
||||
handleAppEvents renderer appEvents updatedRoot
|
||||
|
||||
if elem W.ResizeChildren eventRequests then
|
||||
updateUI renderer updatedRoot2
|
||||
else
|
||||
return updatedRoot2
|
||||
|
||||
keycodeTab = fromIntegral $ Keyboard.unwrapKeycode SDL.KeycodeTab
|
||||
|
||||
isKeyboardEvent :: W.SystemEvent -> Bool
|
||||
|
||||
@ -51,11 +51,14 @@ instance Semigroup Color where
|
||||
instance Default Color where
|
||||
def = RGB 0 0 0
|
||||
|
||||
white = RGB 255 255 255
|
||||
black = RGB 0 0 0
|
||||
red = RGB 255 0 0
|
||||
green = RGB 0 255 0
|
||||
blue = RGB 0 0 255
|
||||
white = RGB 255 255 255
|
||||
black = RGB 0 0 0
|
||||
red = RGB 255 0 0
|
||||
green = RGB 0 255 0
|
||||
blue = RGB 0 0 255
|
||||
lightGray = RGB 191 191 191
|
||||
gray = RGB 127 127 127
|
||||
darkGray = RGB 63 63 63
|
||||
|
||||
makeLenses ''Point
|
||||
makeLenses ''Size
|
||||
@ -112,3 +115,6 @@ midPoint :: Point -> Point -> Point
|
||||
midPoint (Point x1 y1) (Point x2 y2) = Point x3 y3 where
|
||||
x3 = (x2 + x1) / 2
|
||||
y3 = (y2 + y1) / 2
|
||||
|
||||
moveRect :: Rect -> Double -> Double -> Rect
|
||||
moveRect (Rect x y w h) dx dy = Rect (x + dx) (y + dy) w h
|
||||
|
||||
@ -24,7 +24,7 @@ makeButton state onClick = Widget widgetType focusable handleEvent preferredSize
|
||||
widgetType = "button"
|
||||
focusable = False
|
||||
handleEvent view evt = case evt of
|
||||
Click (Point x y) _ status -> widgetEventResult False events (makeButton newState onClick) where
|
||||
Click (Point x y) _ status -> eventResult events (makeButton newState onClick) where
|
||||
isPressed = status == PressedBtn && inRect view (Point x y)
|
||||
newState = if isPressed then state + 1 else state
|
||||
events = if isPressed then [onClick] else []
|
||||
|
||||
@ -38,8 +38,10 @@ data KeyMotion = KeyPressed | KeyReleased deriving (Show, Eq)
|
||||
data SystemEvent = Click Point Button ButtonState |
|
||||
KeyAction KeyCode KeyMotion deriving (Show, Eq)
|
||||
|
||||
data EventRequest = StopPropagation | ResizeChildren | ResizeAll deriving (Show, Eq)
|
||||
|
||||
data WidgetEventResult s e m = WidgetEventResult {
|
||||
_eventResultStop :: Bool,
|
||||
_eventResultRequest :: [EventRequest],
|
||||
_eventResultUserEvents :: [e],
|
||||
_eventResultNewWidget :: Maybe (Widget s e m)
|
||||
}
|
||||
@ -50,8 +52,11 @@ data WidgetResizeResult s e m = WidgetResizeResult {
|
||||
_resizeResultWidget :: Maybe (Widget s e m)
|
||||
}
|
||||
|
||||
widgetEventResult :: Bool -> [e] -> (Widget s e m) -> Maybe (WidgetEventResult s e m)
|
||||
widgetEventResult stop userEvents newWidget = Just $ WidgetEventResult stop userEvents (Just newWidget)
|
||||
eventResult :: [e] -> (Widget s e m) -> Maybe (WidgetEventResult s e m)
|
||||
eventResult userEvents newWidget = Just $ WidgetEventResult [] userEvents (Just newWidget)
|
||||
|
||||
eventResultRequest :: [EventRequest] -> [e] -> (Widget s e m) -> Maybe (WidgetEventResult s e m)
|
||||
eventResultRequest requests userEvents newWidget = Just $ WidgetEventResult requests userEvents (Just newWidget)
|
||||
|
||||
newtype WidgetType = WidgetType String deriving Eq
|
||||
newtype WidgetKey = WidgetKey String deriving Eq
|
||||
@ -143,6 +148,7 @@ data WidgetInstance s e m =
|
||||
_widgetInstanceRenderArea :: Rect,
|
||||
-- | Style attributes of the widget instance
|
||||
_widgetInstanceStyle :: Style
|
||||
--_widgetInstanceElementStyle :: Style
|
||||
}
|
||||
|
||||
key :: (MonadState s m) => WidgetKey -> WidgetInstance s e m -> WidgetInstance s e m
|
||||
@ -193,18 +199,20 @@ mergeTrees node1@(Node widget1 seq1) (Node widget2 seq2) = newNode where
|
||||
handleWidgetEvents :: (MonadState s m) => Widget s e m -> Rect -> SystemEvent -> Maybe (WidgetEventResult s e m)
|
||||
handleWidgetEvents (Widget {..}) viewport systemEvent = _widgetHandleEvent viewport systemEvent
|
||||
|
||||
handleChildEvent :: (MonadState s m) => (a -> SQ.Seq (WidgetNode s e m) -> (a, Maybe Int)) -> a -> WidgetNode s e m -> SystemEvent -> (Bool, SQ.Seq e, Maybe (WidgetNode s e m))
|
||||
handleChildEvent selectorFn selector treeNode@(Node wn@WidgetInstance{..} children) systemEvent = (stopPropagation, userEvents, newTreeNode) where
|
||||
(stopPropagation, userEvents, newTreeNode) = case spChild of
|
||||
True -> (spChild, ueChild, newNode1)
|
||||
False -> (sp, ueChild SQ.>< ue, newNode2)
|
||||
(spChild, ueChild, tnChild, tnChildIdx) = case selectorFn selector children of
|
||||
(_, Nothing) -> (False, SQ.empty, Nothing, 0)
|
||||
(newSelector, Just idx) -> (sp2, ue2, tn2, idx) where
|
||||
(sp2, ue2, tn2) = handleChildEvent selectorFn newSelector (SQ.index children idx) systemEvent
|
||||
(sp, ue, tn) = case handleWidgetEvents _widgetInstanceWidget _widgetInstanceViewport systemEvent of
|
||||
Nothing -> (False, SQ.empty, Nothing)
|
||||
Just (WidgetEventResult sp2 ue2 widget) -> (sp2, SQ.fromList ue2, if isNothing widget then Nothing else Just (Node (wn { _widgetInstanceWidget = fromJust widget }) children))
|
||||
handleChildEvent :: (MonadState s m) => (a -> SQ.Seq (WidgetNode s e m) -> (a, Maybe Int)) -> a -> WidgetNode s e m -> SystemEvent -> (Bool, [EventRequest], SQ.Seq e, Maybe (WidgetNode s e m))
|
||||
handleChildEvent selectorFn selector treeNode@(Node wn@WidgetInstance{..} children) systemEvent = (stopPropagation, eventRequests, userEvents, newTreeNode) where
|
||||
(stopPropagation, eventRequests, userEvents, newTreeNode) = case spChild of
|
||||
True -> (spChild, erChild, ueChild, newNode1)
|
||||
False -> (sp, erChild ++ er, ueChild SQ.>< ue, newNode2)
|
||||
-- Children widgets
|
||||
(spChild, erChild, ueChild, tnChild, tnChildIdx) = case selectorFn selector children of
|
||||
(_, Nothing) -> (False, [], SQ.empty, Nothing, 0)
|
||||
(newSelector, Just idx) -> (sp2, er2, ue2, tn2, idx) where
|
||||
(sp2, er2, ue2, tn2) = handleChildEvent selectorFn newSelector (SQ.index children idx) systemEvent
|
||||
-- Current widget
|
||||
(sp, er, ue, tn) = case handleWidgetEvents _widgetInstanceWidget _widgetInstanceRenderArea systemEvent of
|
||||
Nothing -> (False, [], SQ.empty, Nothing)
|
||||
Just (WidgetEventResult er2 ue2 widget) -> (elem StopPropagation er2, er2, SQ.fromList ue2, if isNothing widget then Nothing else Just (Node (wn { _widgetInstanceWidget = fromJust widget }) children))
|
||||
newNode1 = case tnChild of
|
||||
Nothing -> Nothing
|
||||
Just wnChild -> Just $ Node wn (SQ.update tnChildIdx wnChild children)
|
||||
@ -214,14 +222,14 @@ handleChildEvent selectorFn selector treeNode@(Node wn@WidgetInstance{..} childr
|
||||
(Just pn, Nothing) -> tn
|
||||
(Just (Node wn _), Just tnChild) -> Just $ Node wn (SQ.update tnChildIdx tnChild children)
|
||||
|
||||
handleEventFromPath :: (MonadState s m) => Path -> WidgetNode s e m -> SystemEvent -> (Bool, SQ.Seq e, Maybe (WidgetNode s e m))
|
||||
handleEventFromPath :: (MonadState s m) => Path -> WidgetNode s e m -> SystemEvent -> (Bool, [EventRequest], SQ.Seq e, Maybe (WidgetNode s e m))
|
||||
handleEventFromPath path widgetInstance systemEvent = handleChildEvent pathSelector path widgetInstance systemEvent where
|
||||
pathSelector [] _ = ([], Nothing)
|
||||
pathSelector (p:ps) children
|
||||
| length children > p = (ps, Just p)
|
||||
| otherwise = ([], Nothing)
|
||||
|
||||
handleEventFromPoint :: (MonadState s m) => Point -> WidgetNode s e m -> SystemEvent -> (Bool, SQ.Seq e, Maybe (WidgetNode s e m))
|
||||
handleEventFromPoint :: (MonadState s m) => Point -> WidgetNode s e m -> SystemEvent -> (Bool, [EventRequest], SQ.Seq e, Maybe (WidgetNode s e m))
|
||||
handleEventFromPoint cursorPos widgetInstance systemEvent = handleChildEvent rectSelector cursorPos widgetInstance systemEvent where
|
||||
rectSelector point children = (point, SQ.lookup 0 inRectList) where
|
||||
inRectList = fmap snd $ SQ.filter inNodeRect childrenPair
|
||||
@ -275,4 +283,3 @@ resizeNode renderer viewport renderArea (Node _ childrenSizes) (Node widgetInsta
|
||||
}
|
||||
childrenPair = SQ.zip4 childrenSizes childrenWns (SQ.fromList viewports) (SQ.fromList renderAreas)
|
||||
childResize = \(size, node, viewport, renderArea) -> resizeNode renderer viewport renderArea size node
|
||||
|
||||
|
||||
@ -15,6 +15,15 @@ import GUI.Widget.Core
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
{--
|
||||
|
||||
***********************************
|
||||
|
||||
Implement auto scalable label! Selects correct size to fit the given text
|
||||
|
||||
***********************************
|
||||
|
||||
--}
|
||||
label :: (MonadState s m) => T.Text -> WidgetNode s e m
|
||||
label caption = singleWidget (makeLabel caption)
|
||||
|
||||
|
||||
@ -4,6 +4,8 @@
|
||||
|
||||
module GUI.Widget.Scroll (scroll) where
|
||||
|
||||
import Data.Default
|
||||
import Debug.Trace
|
||||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
|
||||
@ -16,28 +18,65 @@ import GUI.Data.Tree
|
||||
import GUI.Widget.Core
|
||||
|
||||
data ScrollState = ScrollState {
|
||||
_scPosition :: Int
|
||||
_scDeltaX :: !Double,
|
||||
_scDeltaY :: !Double,
|
||||
_scChildSize :: Size
|
||||
} deriving (Eq, Show)
|
||||
|
||||
scroll :: (MonadState s m) => WidgetNode s e m -> WidgetNode s e m
|
||||
scroll managedWidget = parentWidget (makeScroll (ScrollState 0)) [managedWidget]
|
||||
scroll managedWidget = parentWidget (makeScroll (ScrollState 0 0 def)) [managedWidget]
|
||||
|
||||
makeScroll :: (MonadState s m) => ScrollState -> Widget s e m
|
||||
makeScroll state = Widget widgetType focusable handleEvent preferredSize resizeChildren render
|
||||
makeScroll state@(ScrollState dx dy cs@(Size cw ch)) = Widget {
|
||||
_widgetType = "scroll",
|
||||
_widgetFocusable = False,
|
||||
_widgetHandleEvent = handleEvent,
|
||||
_widgetPreferredSize = preferredSize,
|
||||
_widgetResizeChildren = resizeChildren,
|
||||
_widgetRender = render
|
||||
}
|
||||
where
|
||||
stepSize = 50
|
||||
widgetType = "scroll"
|
||||
focusable = False
|
||||
handleEvent view evt = Nothing
|
||||
handleEvent view@(Rect rx ry rw rh) evt = case evt of
|
||||
Click (Point px py) btn status -> eventResultRequest [ResizeChildren] [] (makeScroll newState) where
|
||||
isPressed = status == PressedBtn && inRect view (Point px py)
|
||||
isLeftClick = traceShow state $ isPressed && btn == LeftBtn
|
||||
isRigthClick = isPressed && btn == RightBtn
|
||||
newDx = if | isLeftClick -> if dx + stepSize < 0 then dx + stepSize else 0
|
||||
| isRigthClick -> if cw - rw + dx - stepSize > 0 then dx - stepSize else rw - cw
|
||||
| otherwise -> dx
|
||||
newState = ScrollState newDx dy cs
|
||||
_ -> Nothing
|
||||
preferredSize _ _ children = return (head children)
|
||||
resizeChildren (Rect l t _ _) _ children = Just $ WidgetResizeResult viewport renderArea newWidget where
|
||||
Size w h = (head children)
|
||||
newWidget = Just $ makeScroll state
|
||||
resizeChildren (Rect l t w h) _ children = Just $ WidgetResizeResult viewport renderArea newWidget where
|
||||
Size cw2 ch2 = (head children)
|
||||
newWidget = Just $ makeScroll (ScrollState dx dy (Size cw2 ch2))
|
||||
viewport = [Rect l t w h]
|
||||
renderArea = [Rect l t w h]
|
||||
renderArea = [Rect (l + dx) (t + dy) cw2 ch2]
|
||||
render renderer WidgetInstance{..} children ts =
|
||||
do
|
||||
scissor renderer _widgetInstanceViewport
|
||||
handleRenderChildren renderer children ts
|
||||
resetScissor renderer
|
||||
|
||||
drawText renderer _widgetInstanceRenderArea (_textStyle _widgetInstanceStyle) (T.pack (show state))
|
||||
drawText renderer _widgetInstanceRenderArea (_textStyle _widgetInstanceStyle) (T.pack (show dx))
|
||||
|
||||
when (barRatioH < 1) $ do
|
||||
drawRect renderer scrollRectH (Just darkGray) Nothing
|
||||
|
||||
when (barRatioV < 1) $ do
|
||||
drawRect renderer scrollRectV (Just darkGray) Nothing
|
||||
where
|
||||
barThickness = 10
|
||||
vpLeft = (_rx _widgetInstanceViewport)
|
||||
vpTop = (_ry _widgetInstanceViewport)
|
||||
vpWidth = (_rw _widgetInstanceViewport)
|
||||
vpHeight = (_rh _widgetInstanceViewport)
|
||||
barTop = vpHeight - barThickness
|
||||
barLeft = vpWidth - barThickness
|
||||
barRatioH = vpWidth / cw
|
||||
barRatioV = vpHeight / ch
|
||||
scrollRectH = Rect (vpLeft - barRatioH * dx) (vpTop + barTop) (barRatioH * vpWidth) barThickness
|
||||
scrollRectV = Rect (vpLeft + barLeft) (vpTop - barRatioV * dy) barThickness (barRatioV * vpHeight)
|
||||
|
||||
@ -48,7 +48,7 @@ makeTextField (TextFieldState txt tp) = Widget widgetType focusable handleEvent
|
||||
newText = if isKeyPrintable code then [chr code] else ""
|
||||
(part1, part2) = splitAt currTp currText
|
||||
handleEvent _ evt = case evt of
|
||||
KeyAction code KeyPressed -> widgetEventResult False [] (makeTextField newState) where
|
||||
KeyAction code KeyPressed -> eventResult [] (makeTextField newState) where
|
||||
(txt2, tp2) = handleKeyPress txt tp code
|
||||
newState = TextFieldState txt2 tp2
|
||||
_ -> Nothing
|
||||
|
||||
Loading…
Reference in New Issue
Block a user