fjvallarino/monomer
1
1
Fork 0
mirror of https://github.com/fjvallarino/monomer.git synced 2024-09-21 00:38:01 +03:00
Code Issues Projects Releases Wiki Activity

Refactor modules a bit more

Browse Source
This commit is contained in:
Francisco Vallarino 2019-12-19 00:40:24 -03:00
parent 3cdc2e3c13
commit efbcf92649
19 changed files with 542 additions and 524 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
app/Main.hs
View File

@ -46,21 +46,22 @@ import Types
import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Style
import GUI.Common.Types
import GUI.Common.Util
import GUI.Data.Tree
import GUI.Widgets
import qualified GUI.Data.Tree as TR
import qualified GUI.Platform.NanoVGRenderer as NV
import qualified GUI.Widget.Core as W
foreign import ccall unsafe "initGlew" glewInit :: IO CInt
data AppEvent = Action1 Int | Action2 deriving (Show, Eq)
type WidgetM = StateT App IO
type LocalWidget = W.Widget App AppEvent WidgetM
type WidgetTree = TR.Tree (W.WidgetInstance App AppEvent WidgetM)
type LocalWidget = Widget App AppEvent WidgetM
type WidgetTree = Tree (WidgetInstance App AppEvent WidgetM)
type AppContext = W.GUIContext App
type AppContext = GUIContext App
type AppM = StateT AppContext IO
(screenWidth, screenHeight) = (640, 480)
@ -104,7 +105,7 @@ main = do
SREv.startTextInput
runStateT (runWidgets window c) (W.initGUIContext def)
runStateT (runWidgets window c) (initGUIContext def)
putStrLn "About to destroyWindow"
SDL.destroyWindow window
@ -172,7 +173,7 @@ buildUI model = styledTree where
button "Add items" (Action1 0) `style` buttonStyle,
textField `style` textStyle
] ++ extraWidgets)
styledTree = W.cascadeStyle mempty widgetTree
styledTree = cascadeStyle mempty widgetTree
runWidgets :: SDL.Window -> Context -> AppM ()
runWidgets window c = do
@ -187,13 +188,13 @@ updateUI :: Renderer WidgetM -> WidgetTree -> AppM WidgetTree
updateUI renderer oldWidgets = do
resizedUI <- zoom appContext $ do
app <- get
W.resizeUI renderer windowSize (W.mergeTrees (buildUI app) oldWidgets)
resizeUI renderer windowSize (mergeTrees (buildUI app) oldWidgets)
let paths = map snd $ filter (W.isFocusable . fst) $ collectPaths resizedUI []
let paths = map snd $ filter (isFocusable . fst) $ collectPaths resizedUI []
focusRing .= paths
currentFocus <- getCurrentFocus
return (W.setFocusedStatus currentFocus True resizedUI)
return (setFocusedStatus currentFocus True resizedUI)
mainLoop :: SDL.Window -> Context -> Renderer WidgetM -> Int -> WidgetTree -> AppM ()
mainLoop window c renderer prevTicks widgets = do
@ -222,25 +223,25 @@ getCurrentMousePos = do
SDL.P (SDL.V2 x y) <- Mouse.getAbsoluteMouseLocation
return $ Point (fromIntegral x) (fromIntegral y)
getCurrentFocus :: AppM TR.Path
getCurrentFocus :: AppM Path
getCurrentFocus = do
ring <- use focusRing
return (if length ring > 0 then ring!!0 else [])
handleSystemEvents :: Renderer WidgetM -> [SystemEvent] -> TR.Path -> WidgetTree -> AppM WidgetTree
handleSystemEvents :: Renderer WidgetM -> [SystemEvent] -> Path -> WidgetTree -> AppM WidgetTree
handleSystemEvents renderer systemEvents currentFocus widgets =
foldM (\newWidgets event -> handleSystemEvent renderer event currentFocus newWidgets) widgets systemEvents
handleEvent :: Renderer WidgetM -> SystemEvent -> TR.Path -> WidgetTree -> W.ChildEventResult App AppEvent WidgetM
handleEvent :: Renderer WidgetM -> SystemEvent -> Path -> WidgetTree -> ChildEventResult App AppEvent WidgetM
handleEvent renderer systemEvent currentFocus widgets = case systemEvent of
Click point _ _ -> W.handleEventFromPoint point widgets systemEvent
WheelScroll point _ _ -> W.handleEventFromPoint point widgets systemEvent
KeyAction _ _ -> W.handleEventFromPath currentFocus widgets systemEvent
TextInput _ -> W.handleEventFromPath currentFocus widgets systemEvent
Click point _ _ -> handleEventFromPoint point widgets systemEvent
WheelScroll point _ _ -> handleEventFromPoint point widgets systemEvent
KeyAction _ _ -> handleEventFromPath currentFocus widgets systemEvent
TextInput _ -> handleEventFromPath currentFocus widgets systemEvent
handleSystemEvent :: Renderer WidgetM -> SystemEvent -> TR.Path -> WidgetTree -> AppM WidgetTree
handleSystemEvent :: Renderer WidgetM -> SystemEvent -> Path -> WidgetTree -> AppM WidgetTree
handleSystemEvent renderer systemEvent currentFocus widgets = do
let (W.ChildEventResult stopProcessing eventRequests appEvents newWidgets) = handleEvent renderer systemEvent currentFocus widgets
let (ChildEventResult stopProcessing eventRequests appEvents newWidgets) = handleEvent renderer systemEvent currentFocus widgets
let newRoot = fromMaybe widgets newWidgets
launchWidgetTasks renderer eventRequests
@ -249,64 +250,64 @@ handleSystemEvent renderer systemEvent currentFocus widgets = do
>>= handleAppEvents renderer appEvents
>>= handleResizeChildren renderer eventRequests
handleFocusChange :: TR.Path -> SystemEvent -> Bool -> WidgetTree -> AppM WidgetTree
handleFocusChange :: Path -> SystemEvent -> Bool -> WidgetTree -> AppM WidgetTree
handleFocusChange currentFocus systemEvent stopProcessing widgetRoot
| focusChangeRequested = do
ring <- use focusRing
focusRing .= rotateList ring
newFocus <- getCurrentFocus
return $ W.setFocusedStatus newFocus True (W.setFocusedStatus currentFocus False widgetRoot)
return $ setFocusedStatus newFocus True (setFocusedStatus currentFocus False widgetRoot)
| otherwise = return widgetRoot
where
focusChangeRequested = not stopProcessing && isKeyPressed systemEvent keycodeTab
handleResizeChildren :: Renderer WidgetM -> [(TR.Path, W.EventRequest)] -> WidgetTree -> AppM WidgetTree
handleResizeChildren :: Renderer WidgetM -> [(Path, EventRequest)] -> WidgetTree -> AppM WidgetTree
handleResizeChildren renderer eventRequests widgetRoot =
case L.find (\(path, evt) -> evt == W.ResizeChildren) eventRequests of
case L.find (\(path, evt) -> evt == ResizeChildren) eventRequests of
Just (path, event) -> updateUI renderer widgetRoot
Nothing -> return widgetRoot
launchWidgetTasks :: Renderer WidgetM -> [(TR.Path, W.EventRequest)] -> AppM ()
launchWidgetTasks :: Renderer WidgetM -> [(Path, EventRequest)] -> AppM ()
launchWidgetTasks renderer eventRequests = do
let customHandlers = L.filter isCustomHandler eventRequests
tasks <- forM customHandlers $ \(path, W.RunCustom handler) -> do
tasks <- forM customHandlers $ \(path, RunCustom handler) -> do
asyncTask <- liftIO $ async (liftIO handler)
return $ W.WidgetTask path asyncTask
return $ WidgetTask path asyncTask
previousTasks <- use widgetTasks
widgetTasks .= previousTasks ++ tasks
isCustomHandler :: (TR.Path, W.EventRequest) -> Bool
isCustomHandler (_, W.RunCustom _) = True
isCustomHandler :: (Path, EventRequest) -> Bool
isCustomHandler (_, RunCustom _) = True
isCustomHandler _ = False
processWidgetTasks :: Renderer WidgetM -> WidgetTree -> AppM WidgetTree
processWidgetTasks renderer widgets = do
tasks <- use widgetTasks
(active, finished) <- partitionM (\(W.WidgetTask _ task) -> fmap isNothing (liftIO $ poll task)) tasks
(active, finished) <- partitionM (\(WidgetTask _ task) -> fmap isNothing (liftIO $ poll task)) tasks
widgetTasks .= active
processCustomHandlers renderer widgets finished
processCustomHandlers :: Renderer WidgetM -> WidgetTree -> [W.WidgetTask] -> AppM WidgetTree
processCustomHandlers :: Renderer WidgetM -> WidgetTree -> [WidgetTask] -> AppM WidgetTree
processCustomHandlers renderer widgets tasks = do
newWidgets <- foldM (stepWidgetTask renderer) widgets tasks
return newWidgets
stepWidgetTask :: Renderer WidgetM -> WidgetTree -> W.WidgetTask -> AppM WidgetTree
stepWidgetTask renderer widgets (W.WidgetTask path task) = do
stepWidgetTask :: Renderer WidgetM -> WidgetTree -> WidgetTask -> AppM WidgetTree
stepWidgetTask renderer widgets (WidgetTask path task) = do
taskStatus <- liftIO $ poll task
if (isJust taskStatus)
then processCustomHandler renderer widgets path (fromJust taskStatus)
else return widgets
processCustomHandler :: (Typeable a) => Renderer WidgetM -> WidgetTree -> TR.Path -> Either SomeException a -> AppM WidgetTree
processCustomHandler :: (Typeable a) => Renderer WidgetM -> WidgetTree -> Path -> Either SomeException a -> AppM WidgetTree
processCustomHandler renderer widgets _ (Left _) = return widgets
processCustomHandler renderer widgets path (Right val) = do
let (W.ChildEventResult stopProcessing eventRequests appEvents newWidgets) = W.handleCustomCommand path widgets val
let (ChildEventResult stopProcessing eventRequests appEvents newWidgets) = handleCustomCommand path widgets val
let newRoot = fromMaybe widgets newWidgets
launchWidgetTasks renderer eventRequests
@ -350,7 +351,7 @@ renderWidgets !window !c !renderer widgets ticks =
doInDrawingContext window c $ do
guiContext <- get
zoom appContext $ do
W.handleRender renderer widgets ticks
handleRender renderer widgets ticks
doInDrawingContext :: SDL.Window -> Context -> AppM a -> AppM a
doInDrawingContext window c action = do
@ -366,7 +367,7 @@ doInDrawingContext window c action = do
SDL.glSwapWindow window
return ret
collectPaths :: (MonadState s m) => TR.Tree (W.WidgetInstance s e m) -> TR.Path -> [(W.WidgetInstance s e m, TR.Path)]
collectPaths (TR.Node widgetNode children) path = (widgetNode, reverse path) : remainingItems where
pairs = zip (TR.seqToNodeList children) (map (: path) [0..])
collectPaths :: (MonadState s m) => Tree (WidgetInstance s e m) -> Path -> [(WidgetInstance s e m, Path)]
collectPaths (Node widgetNode children) path = (widgetNode, reverse path) : remainingItems where
pairs = zip (seqToNodeList children) (map (: path) [0..])
remainingItems = concatMap (\(wn, path) -> collectPaths wn path) pairs

2
app/Types.hs
View File

@ -11,7 +11,7 @@ import Control.Monad
import Control.Monad.State
import qualified GUI.Data.Tree as TR
import GUI.Widget.Core (GUIContext, WidgetTask, _appContext, _focusRing, _widgetTasks)
import GUI.Common.Core (GUIContext, WidgetTask, _appContext, _focusRing, _widgetTasks)
data App = App {
_clickCount :: !Int

443
src/GUI/Common/Core.hs
View File

@ -1,122 +1,367 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module GUI.Common.Core where
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.State
import Data.Default
import Lens.Micro
import Lens.Micro.TH (makeLenses)
import Data.Dynamic
import Data.Maybe
import Data.String
import Data.Typeable (cast, Typeable)
import Debug.Trace
import GUI.Common.Event
import GUI.Common.Style
import GUI.Common.Types
import GUI.Common.Util
import GUI.Data.Tree
import GHC.Generics
import qualified Data.Text as T
import qualified Data.Sequence as SQ
data Align = Align AlignH AlignV deriving (Show, Eq)
data AlignH = ALeft | ACenter | ARight deriving (Show, Eq)
data AlignV = ATop | AMiddle | ABottom deriving (Show, Eq)
type Timestamp = Int
data SizePolicy = StrictSize | FlexibleSize | RemainderSize deriving (Show, Eq)
type WidgetNode s e m = Tree (WidgetInstance s e m)
type WidgetChildren s e m = SQ.Seq (WidgetNode s e m)
data Point = Point {
_x :: !Double,
_y :: !Double
newtype WidgetType = WidgetType String deriving Eq
newtype WidgetKey = WidgetKey String deriving Eq
instance IsString WidgetType where
fromString string = WidgetType string
instance IsString WidgetKey where
fromString string = WidgetKey string
data WidgetState = forall i . (Typeable i, Generic i) => WidgetState i
data SizeReq = SizeReq {
_srSize :: Size,
_srPolicyWidth :: SizePolicy,
_srPolicyHeight :: SizePolicy
} deriving (Show, Eq)
instance Default Point where
def = Point 0 0
data EventRequest = IgnoreParentEvents
| IgnoreChildrenEvents
| ResizeChildren
| ResizeAll
| forall a . Typeable a => RunCustom (IO a)
data Size = Size {
_w :: !Double,
_h :: !Double
} deriving (Show, Eq)
instance Eq EventRequest where
IgnoreParentEvents == IgnoreParentEvents = True
IgnoreChildrenEvents == IgnoreChildrenEvents = True
ResizeChildren == ResizeChildren = True
ResizeAll == ResizeAll = True
_ == _ = False
instance Default Size where
def = Size 0 0
data Rect = Rect {
_rx :: !Double,
_ry :: !Double,
_rw :: !Double,
_rh :: !Double
} deriving (Show, Eq)
instance Default Rect where
def = Rect 0 0 0 0
data Color =
RGB !Double !Double !Double
deriving (Show, Eq)
instance Semigroup Color where
(<>) _ c2 = c2
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
lightGray = RGB 191 191 191
gray = RGB 127 127 127
darkGray = RGB 63 63 63
makeLenses ''Point
makeLenses ''Size
makeLenses ''Rect
type Font = T.Text
type FontSize = Double
data Renderer m = (Monad m) => Renderer {
beginPath :: m (),
-- Context management
saveContext :: m (),
restoreContext :: m (),
-- Scissor operations
scissor :: Rect -> m (),
resetScissor :: m (),
-- Strokes
stroke :: m (),
strokeColor :: Color -> m (),
strokeWidth :: Double -> m (),
-- Fill
fill :: m (),
fillColor :: Color -> m (),
fillLinearGradient :: Point -> Point -> Color -> Color -> m (),
-- Drawing
moveTo :: Point -> m (),
line :: Point -> Point -> m (),
lineTo :: Point -> m (),
rect :: Rect -> m (),
arc :: Point -> Double -> Double -> Double -> m (),
quadTo :: Point -> Point -> m (),
ellipse :: Rect -> m (),
-- Text
text :: Rect -> Font -> FontSize -> Align -> T.Text -> m (),
textBounds :: Font -> FontSize -> T.Text -> m Size
data WidgetEventResult s e m = WidgetEventResult {
_eventResultRequest :: [EventRequest],
_eventResultUserEvents :: [e],
_eventResultNewWidget :: Maybe (Widget s e m)
}
inRect :: Rect -> Point -> Bool
inRect (Rect x y w h) (Point x2 y2) = (x2 >= x && x2 < x + w) && (y2 >= y && y2 < y + h)
data WidgetResizeResult s e m = WidgetResizeResult {
_resizeResultRenderAreas :: [Rect],
_resizeResultViewports :: [Rect],
_resizeResultWidget :: Maybe (Widget s e m)
}
rotateList :: [a] -> [a]
rotateList [] = []
rotateList (x:xs) = xs ++ [x]
data WidgetTask = forall a . Typeable a => WidgetTask {
widgetTaskPath :: Path,
widgetTask :: Async a
}
firstJust :: Maybe a -> Maybe a -> Maybe a
firstJust (Just val) _ = Just val
firstJust _ value = value
data ChildEventResult s e m = ChildEventResult {
cerIgnoreParentEvents :: Bool,
cerEventRequests :: [(Path, EventRequest)],
cerUserEvents :: SQ.Seq e,
cerNewTreeNode :: Maybe (WidgetNode s e m)
}
justDef :: (Default a) => Maybe a -> a
justDef Nothing = def
justDef (Just val) = val
data Widget s e m =
(MonadState s m) => Widget {
-- | Type of the widget
_widgetType :: WidgetType,
-- | Indicates whether the widget can receive focus
_widgetFocusable :: Bool,
-- | Provides the previous internal state to the new widget, which can choose to ignore it or update itself
_widgetRestoreState :: WidgetState -> Maybe (Widget s e m),
-- | Returns the current internal state, which can later be used to restore the widget
_widgetSaveState :: Maybe WidgetState,
-- | Handles an event
--
-- Region assigned to the widget
-- Event to handle
--
-- Returns: the list of generated events and, maybe, a new version of the widget if internal state changed
_widgetHandleEvent :: Rect -> SystemEvent -> Maybe (WidgetEventResult s e m),
-- | Handles an custom asynchronous event
--
-- Result of asynchronous computation
--
-- Returns: the list of generated events and, maybe, a new version of the widget if internal state changed
_widgetHandleCustom :: forall i . Typeable i => i -> Maybe (WidgetEventResult s e m),
-- | Minimum size desired by the widget
--
-- Style options
-- Preferred size for each of the children widgets
-- Renderer (mainly for text sizing functions)
--
-- Returns: the minimum size desired by the widget
_widgetPreferredSize :: Renderer m -> Style -> [SizeReq] -> m SizeReq,
-- | Resizes the children of this widget
--
-- Region assigned to the widget
-- Style options
-- Preferred size for each of the children widgets
--
-- Returns: the size assigned to each of the children
_widgetResizeChildren :: Rect -> Rect -> Style -> [SizeReq] -> Maybe (WidgetResizeResult s e m),
-- | Renders the widget
--
-- Renderer
-- Style options
-- renderArea: The area of the screen where the widget can draw
-- viewport: The visible area of the screen assigned to the widget
-- Indicates if the widget (and its children) are enabled
-- Indicates if the widget has focus
-- The current time in milliseconds
--
-- Returns: unit
_widgetRender :: Renderer m -> WidgetInstance s e m -> WidgetChildren s e m -> Timestamp -> m ()
}
midPoint :: Point -> Point -> Point
midPoint (Point x1 y1) (Point x2 y2) = Point x3 y3 where
x3 = (x2 + x1) / 2
y3 = (y2 + y1) / 2
-- | Complementary information to a Widget, forming a node in the view tree
--
-- Type variables:
-- * n: Identifier for a node
data WidgetInstance s e m =
(MonadState s m) => WidgetInstance {
-- | Key/Identifier of the widget. If provided, it needs to be unique in the same hierarchy level (not globally)
_widgetInstanceKey :: Maybe WidgetKey,
-- | The actual widget
_widgetInstanceWidget :: Widget s e m,
-- | Indicates if the widget is enabled for user interaction
_widgetInstanceEnabled :: Bool,
-- | Indicates if the widget is focused
_widgetInstanceFocused :: Bool,
-- | The visible area of the screen assigned to the widget
_widgetInstanceViewport :: Rect,
-- | The area of the screen where the widget can draw
-- | Usually equal to _widgetInstanceViewport, but may be larger if the widget is wrapped in a scrollable container
_widgetInstanceRenderArea :: Rect,
-- | Style attributes of the widget instance
_widgetInstanceStyle :: Style
--_widgetInstanceElementStyle :: Style
}
moveRect :: Rect -> Double -> Double -> Rect
moveRect (Rect x y w h) dx dy = Rect (x + dx) (y + dy) w h
data GUIContext app = GUIContext {
_appContext :: app,
_focusRing :: [Path],
_widgetTasks :: [WidgetTask]
}
initGUIContext :: app -> GUIContext app
initGUIContext app = GUIContext {
_appContext = app,
_focusRing = [],
_widgetTasks = []
}
resultEvents :: [e] -> Maybe (WidgetEventResult s e m)
resultEvents userEvents = Just $ WidgetEventResult [] userEvents Nothing
resultEventsWidget :: [e] -> (Widget s e m) -> Maybe (WidgetEventResult s e m)
resultEventsWidget userEvents newWidget = Just $ WidgetEventResult [] userEvents (Just newWidget)
resultReqsEventsWidget :: [EventRequest] -> [e] -> (Widget s e m) -> Maybe (WidgetEventResult s e m)
resultReqsEventsWidget requests userEvents newWidget = Just $ WidgetEventResult requests userEvents (Just newWidget)
isFocusable :: (MonadState s m) => WidgetInstance s e m -> Bool
isFocusable (WidgetInstance { _widgetInstanceWidget = Widget{..}, ..}) = _widgetInstanceEnabled && _widgetFocusable
defaultCustomHandler :: a -> Maybe (WidgetEventResult s e m)
defaultCustomHandler _ = Nothing
defaultRestoreState :: WidgetState -> Maybe (Widget s e m)
defaultRestoreState _ = Nothing
defaultSaveState :: Maybe WidgetState
defaultSaveState = Nothing
makeState :: (Typeable i, Generic i) => i -> Maybe WidgetState
makeState state = Just (WidgetState state)
useState :: (Typeable i, Generic i) => WidgetState -> Maybe i
useState (WidgetState state) = cast state
key :: (MonadState s m) => WidgetKey -> WidgetInstance s e m -> WidgetInstance s e m
key key wn = wn { _widgetInstanceKey = Just key }
style :: (MonadState s m) => WidgetNode s e m -> Style -> WidgetNode s e m
style (Node value children) newStyle = Node (value { _widgetInstanceStyle = newStyle }) children
children :: (MonadState s m) => WidgetNode s e m -> [WidgetNode s e m] -> WidgetNode s e m
children (Node value _) newChildren = fromList value newChildren
cascadeStyle :: (MonadState s m) => Style -> WidgetNode s e m -> WidgetNode s e m
cascadeStyle parentStyle (Node (wn@WidgetInstance{..}) children) = newNode where
newNode = Node (wn { _widgetInstanceStyle = newStyle }) newChildren
newStyle = _widgetInstanceStyle <> parentStyle
newChildren = fmap (cascadeStyle newStyle) children
defaultWidgetInstance :: (MonadState s m) => Widget s e m -> WidgetInstance s e m
defaultWidgetInstance widget = WidgetInstance {
_widgetInstanceKey = Nothing,
_widgetInstanceWidget = widget,
_widgetInstanceEnabled = True,
_widgetInstanceFocused = False,
_widgetInstanceViewport = def,
_widgetInstanceRenderArea = def,
_widgetInstanceStyle = mempty
}
singleWidget :: (MonadState s m) => Widget s e m -> WidgetNode s e m
singleWidget widget = singleton (defaultWidgetInstance widget)
parentWidget :: (MonadState s m) => Widget s e m -> [WidgetNode s e m] -> WidgetNode s e m
parentWidget widget = fromList (defaultWidgetInstance widget)
widgetMatches :: (MonadState s m) => WidgetInstance s e m -> WidgetInstance s e m -> Bool
widgetMatches wn1 wn2 = _widgetType (_widgetInstanceWidget wn1) == _widgetType (_widgetInstanceWidget wn2) && _widgetInstanceKey wn1 == _widgetInstanceKey wn2
mergeTrees :: (MonadState s m) => WidgetNode s e m -> WidgetNode s e m -> WidgetNode s e m
mergeTrees node1@(Node candidateInstance candidateChildren) (Node oldInstance oldChildren) = newNode where
matches = widgetMatches candidateInstance oldInstance
newNode = if | matches -> Node newInstance newChildren
| otherwise -> node1
oldWidget = _widgetInstanceWidget oldInstance
candidateWidget = _widgetInstanceWidget candidateInstance
newWidget = case _widgetSaveState oldWidget of
Just st -> fromMaybe candidateWidget (_widgetRestoreState candidateWidget st)
Nothing -> candidateWidget
newInstance = candidateInstance { _widgetInstanceWidget = newWidget }
newChildren = mergedChildren SQ.>< addedChildren
mergedChildren = fmap mergeChild (SQ.zip candidateChildren oldChildren)
addedChildren = SQ.drop (SQ.length oldChildren) candidateChildren
mergeChild = \(c1, c2) -> mergeTrees c1 c2
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 -> Path -> WidgetNode s e m -> SystemEvent -> ChildEventResult s e m
handleChildEvent selectorFn selector path treeNode@(Node wn@WidgetInstance{..} children) systemEvent = ChildEventResult ignoreParentEvents eventRequests userEvents newTreeNode where
(ignoreParentEvents, eventRequests, userEvents, newTreeNode) = case (ice, ipeChild) of
(True, _) -> (ipe, er, ue, newNode1)
(_, True) -> (ipeChild, erChild, ueChild, newNode1)
(_, False) -> (ipe, erChild ++ er, ueChild SQ.>< ue, newNode2)
-- Children widgets
(ipeChild, erChild, ueChild, tnChild, tnChildIdx) = case selectorFn selector children of
(_, Nothing) -> (False, [], SQ.empty, Nothing, 0)
(newSelector, Just idx) -> (ipe2, er2, ue2, tn2, idx) where
(ChildEventResult ipe2 er2 ue2 tn2) = handleChildEvent selectorFn newSelector widgetPath (SQ.index children idx) systemEvent
widgetPath = reverse (idx:path)
-- Current widget
(ice, ipe, er, ue, tn) = case handleWidgetEvents _widgetInstanceWidget _widgetInstanceRenderArea systemEvent of
Nothing -> (False, False, [], SQ.empty, Nothing)
Just (WidgetEventResult er2 ue2 widget) -> (ice, ipe, pathEvents, SQ.fromList ue2, updatedNode) where
ice = elem IgnoreChildrenEvents er2
ipe = elem IgnoreParentEvents er2
pathEvents = fmap (path,) er2
updatedNode = 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)
newNode2 = case (tn, tnChild) of
(Nothing, Nothing) -> Nothing
(Nothing, Just cn) -> newNode1
(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 -> ChildEventResult 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 -> ChildEventResult 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
inNodeRect = \(Node (WidgetInstance {..}) _, _) -> inRect _widgetInstanceViewport point
childrenPair = SQ.zip children (SQ.fromList [0..(length children - 1)])
handleCustomCommand :: (MonadState s m, Typeable i) => Path -> WidgetNode s e m -> i -> ChildEventResult s e m
handleCustomCommand path treeNode customData = traceShow path $ case GUI.Data.Tree.lookup path treeNode of
Just (WidgetInstance{ _widgetInstanceWidget = Widget{..}, ..}) ->
case _widgetHandleCustom customData of
Just (WidgetEventResult er ue tn) -> ChildEventResult False (fmap (path,) er) (SQ.fromList ue) Nothing
Nothing -> ChildEventResult False [] SQ.Empty Nothing
Nothing -> ChildEventResult False [] SQ.Empty Nothing
handleRender :: (MonadState s m) => Renderer m -> WidgetNode s e m -> Timestamp -> m ()
handleRender renderer (Node (widgetInstance@WidgetInstance { _widgetInstanceWidget = Widget{..}, .. }) children) ts = do
_widgetRender renderer widgetInstance children ts
handleRenderChildren :: (MonadState s m) => Renderer m -> WidgetChildren s e m -> Timestamp -> m ()
handleRenderChildren renderer children ts = do
mapM_ (\treeNode -> handleRender renderer treeNode ts) children
updateWidgetInstance :: Path -> WidgetNode s e m -> (WidgetInstance s e m -> WidgetInstance s e m) -> Maybe (WidgetNode s e m)
updateWidgetInstance path root updateFn = updateNode path root (\(Node widgetInstance children) -> Node (updateFn widgetInstance) children)
setFocusedStatus :: Path -> Bool -> WidgetNode s e m -> WidgetNode s e m
setFocusedStatus path focused root = case updateWidgetInstance path root updateFn of
Just newRoot -> newRoot
Nothing -> root
where
updateFn wn@(WidgetInstance {..}) = wn {
_widgetInstanceFocused = focused
}
resizeUI :: (MonadState s m) => Renderer m -> Rect -> WidgetNode s e m -> m (WidgetNode s e m)
resizeUI renderer assignedRect widgetInstance = do
preferredSizes <- buildPreferredSizes renderer widgetInstance
resizeNode renderer assignedRect assignedRect preferredSizes widgetInstance
buildPreferredSizes :: (MonadState s m) => Renderer m -> WidgetNode s e m -> m (Tree SizeReq)
buildPreferredSizes renderer (Node (WidgetInstance {..}) children) = do
childrenSizes <- mapM (buildPreferredSizes renderer) children
size <- _widgetPreferredSize _widgetInstanceWidget renderer _widgetInstanceStyle (seqToList childrenSizes)
return $ Node size childrenSizes
resizeNode :: (MonadState s m) => Renderer m -> Rect -> Rect -> Tree SizeReq -> WidgetNode s e m -> m (WidgetNode s e m)
resizeNode renderer viewport renderArea (Node _ childrenSizes) (Node widgetInstance childrenWns) = do
newChildren <- mapM childResize childrenPair
return (Node updatedNode newChildren)
where
widget = _widgetInstanceWidget widgetInstance
style = _widgetInstanceStyle widgetInstance
(WidgetResizeResult viewports renderAreas newWidget) = case (_widgetResizeChildren widget) viewport renderArea style (seqToList childrenSizes) of
Nothing -> WidgetResizeResult [] [] Nothing
Just wrr -> wrr
updatedNode = widgetInstance {
_widgetInstanceViewport = viewport,
_widgetInstanceRenderArea = renderArea,
_widgetInstanceWidget = fromMaybe widget newWidget
}
childrenPair = SQ.zip4 childrenSizes childrenWns (SQ.fromList viewports) (SQ.fromList renderAreas)
childResize = \(size, node, viewport, renderArea) -> resizeNode renderer viewport renderArea size node

3
src/GUI/Common/Drawing.hs
View File

@ -7,8 +7,9 @@ import qualified Data.Text as T
import Control.Monad (when)
import Data.Maybe
import GUI.Common.Core
import GUI.Common.Types
import GUI.Common.Style
import GUI.Common.Util
defaultColor :: Color
defaultColor = RGB 255 255 255

3
src/GUI/Common/Event.hs
View File

@ -10,7 +10,7 @@ import Unsafe.Coerce
import Control.Monad (when)
import Data.Maybe
import GUI.Common.Core
import GUI.Common.Types
import GUI.Common.Style
import qualified SDL
@ -21,7 +21,6 @@ data Button = LeftBtn | RightBtn deriving (Show, Eq)
data ButtonState = PressedBtn | ReleasedBtn deriving (Show, Eq)
data KeyMotion = KeyPressed | KeyReleased deriving (Show, Eq)
data Direction = Horizontal | Vertical deriving (Show, Eq)
data WheelDirection = WheelNormal | WheelFlipped deriving (Show, Eq)

3
src/GUI/Common/Style.hs
View File

@ -6,7 +6,8 @@ import Data.Default
import Lens.Micro
import Lens.Micro.TH (makeLenses)
import GUI.Common.Core
import GUI.Common.Types
import GUI.Common.Util
data FontInstance = FontInstance

100
src/GUI/Common/Types.hs Normal file
View File

@ -0,0 +1,100 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TemplateHaskell #-}
module GUI.Common.Types where
import Control.Monad
import Data.Default
import Lens.Micro
import Lens.Micro.TH (makeLenses)
import qualified Data.Text as T
type Font = T.Text
type FontSize = Double
data Align = Align AlignH AlignV deriving (Show, Eq)
data AlignH = ALeft |
ACenter |
ARight deriving (Show, Eq)
data AlignV = ATop |
AMiddle |
ABottom deriving (Show, Eq)
data Direction = Horizontal | Vertical deriving (Show, Eq)
data SizePolicy = StrictSize |
FlexibleSize |
RemainderSize deriving (Show, Eq)
data Point = Point {
_x :: !Double,
_y :: !Double
} deriving (Show, Eq)
instance Default Point where
def = Point 0 0
data Size = Size {
_w :: !Double,
_h :: !Double
} deriving (Show, Eq)
instance Default Size where
def = Size 0 0
data Rect = Rect {
_rx :: !Double,
_ry :: !Double,
_rw :: !Double,
_rh :: !Double
} deriving (Show, Eq)
instance Default Rect where
def = Rect 0 0 0 0
data Color =
RGB !Double !Double !Double
deriving (Show, Eq)
instance Semigroup Color where
(<>) _ c2 = c2
instance Default Color where
def = RGB 0 0 0
data Renderer m = (Monad m) => Renderer {
beginPath :: m (),
-- Context management
saveContext :: m (),
restoreContext :: m (),
-- Scissor operations
scissor :: Rect -> m (),
resetScissor :: m (),
-- Strokes
stroke :: m (),
strokeColor :: Color -> m (),
strokeWidth :: Double -> m (),
-- Fill
fill :: m (),
fillColor :: Color -> m (),
fillLinearGradient :: Point -> Point -> Color -> Color -> m (),
-- Drawing
moveTo :: Point -> m (),
line :: Point -> Point -> m (),
lineTo :: Point -> m (),
rect :: Rect -> m (),
arc :: Point -> Double -> Double -> Double -> m (),
quadTo :: Point -> Point -> m (),
ellipse :: Rect -> m (),
-- Text
text :: Rect -> Font -> FontSize -> Align -> T.Text -> m (),
textBounds :: Font -> FontSize -> T.Text -> m Size
}
makeLenses ''Point
makeLenses ''Size
makeLenses ''Rect

39
src/GUI/Common/Util.hs Normal file
View File

@ -0,0 +1,39 @@
{-# LANGUAGE BangPatterns #-}
module GUI.Common.Util where
import Data.Default
import GUI.Common.Types
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
inRect :: Rect -> Point -> Bool
inRect (Rect x y w h) (Point x2 y2) = (x2 >= x && x2 < x + w) && (y2 >= y && y2 < y + h)
rotateList :: [a] -> [a]
rotateList [] = []
rotateList (x:xs) = xs ++ [x]
firstJust :: Maybe a -> Maybe a -> Maybe a
firstJust (Just val) _ = Just val
firstJust _ value = value
justDef :: (Default a) => Maybe a -> a
justDef Nothing = def
justDef (Just val) = val
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

2
src/GUI/Platform/NanoVGRenderer.hs
View File

@ -5,7 +5,7 @@ module GUI.Platform.NanoVGRenderer (makeRenderer) where
import Data.Default
import qualified GUI.Common.Core as C
import qualified GUI.Common.Types as C
import qualified Data.Text as T
import qualified NanoVG as VG

3
src/GUI/Widget/Button.hs
View File

@ -12,8 +12,9 @@ import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Drawing
import GUI.Common.Style
import GUI.Common.Types
import GUI.Common.Util
import GUI.Data.Tree
import GUI.Widget.Core
import qualified Data.Text as T

371
src/GUI/Widget/Core.hs
View File

@ -1,371 +0,0 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module GUI.Widget.Core where
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.State
import Data.Default
import Data.Dynamic
import Data.Maybe
import Data.String
import Data.Typeable (cast, Typeable)
import Debug.Trace
import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Style
import GUI.Data.Tree
import GHC.Generics
import qualified Data.Text as T
import qualified Data.Sequence as SQ
type Timestamp = Int
type Enabled = Bool
type Focused = Bool
type WidgetNode s e m = Tree (WidgetInstance s e m)
type WidgetChildren s e m = SQ.Seq (WidgetNode s e m)
data SizeReq = SizeReq {
_srSize :: Size,
_srPolicyWidth :: SizePolicy,
_srPolicyHeight :: SizePolicy
} deriving (Show, Eq)
data EventRequest = IgnoreParentEvents
| IgnoreChildrenEvents
| ResizeChildren
| ResizeAll
| forall a . Typeable a => RunCustom (IO a)
instance Eq EventRequest where
IgnoreParentEvents == IgnoreParentEvents = True
IgnoreChildrenEvents == IgnoreChildrenEvents = True
ResizeChildren == ResizeChildren = True
ResizeAll == ResizeAll = True
_ == _ = False
data WidgetEventResult s e m = WidgetEventResult {
_eventResultRequest :: [EventRequest],
_eventResultUserEvents :: [e],
_eventResultNewWidget :: Maybe (Widget s e m)
}
data WidgetResizeResult s e m = WidgetResizeResult {
_resizeResultRenderAreas :: [Rect],
_resizeResultViewports :: [Rect],
_resizeResultWidget :: Maybe (Widget s e m)
}
resultEvents :: [e] -> Maybe (WidgetEventResult s e m)
resultEvents userEvents = Just $ WidgetEventResult [] userEvents Nothing
resultEventsWidget :: [e] -> (Widget s e m) -> Maybe (WidgetEventResult s e m)
resultEventsWidget userEvents newWidget = Just $ WidgetEventResult [] userEvents (Just newWidget)
resultReqsEventsWidget :: [EventRequest] -> [e] -> (Widget s e m) -> Maybe (WidgetEventResult s e m)
resultReqsEventsWidget requests userEvents newWidget = Just $ WidgetEventResult requests userEvents (Just newWidget)
newtype WidgetType = WidgetType String deriving Eq
newtype WidgetKey = WidgetKey String deriving Eq
instance IsString WidgetType where
fromString string = WidgetType string
instance IsString WidgetKey where
fromString string = WidgetKey string
newtype NodePath = NodePath [Int]
data NodeInfo = NodeInfo WidgetType (Maybe WidgetKey)
data WidgetTask = forall a . Typeable a => WidgetTask {
widgetTaskPath :: Path,
widgetTask :: Async a
}
data GUIContext app = GUIContext {
_appContext :: app,
_focusRing :: [Path],
_widgetTasks :: [WidgetTask]
}
initGUIContext :: app -> GUIContext app
initGUIContext app = GUIContext {
_appContext = app,
_focusRing = [],
_widgetTasks = []
}
isFocusable :: (MonadState s m) => WidgetInstance s e m -> Bool
isFocusable (WidgetInstance { _widgetInstanceWidget = Widget{..}, ..}) = _widgetInstanceEnabled && _widgetFocusable
defaultCustomHandler :: a -> Maybe (WidgetEventResult s e m)
defaultCustomHandler _ = Nothing
data WidgetState = forall i . (Typeable i, Generic i) => WidgetState i
defaultRestoreState :: WidgetState -> Maybe (Widget s e m)
defaultRestoreState _ = Nothing
defaultSaveState :: Maybe WidgetState
defaultSaveState = Nothing
makeState :: (Typeable i, Generic i) => i -> Maybe WidgetState
makeState state = Just (WidgetState state)
useState :: (Typeable i, Generic i) => WidgetState -> Maybe i
useState (WidgetState state) = cast state
data Widget s e m =
(MonadState s m) => Widget {
-- | Type of the widget
_widgetType :: WidgetType,
-- | Indicates whether the widget can receive focus
_widgetFocusable :: Bool,
-- | Provides the previous internal state to the new widget, which can choose to ignore it or update itself
_widgetRestoreState :: WidgetState -> Maybe (Widget s e m),
-- | Returns the current internal state, which can later be used to restore the widget
_widgetSaveState :: Maybe WidgetState,
-- | Handles an event
--
-- Region assigned to the widget
-- Event to handle
--
-- Returns: the list of generated events and, maybe, a new version of the widget if internal state changed
_widgetHandleEvent :: Rect -> SystemEvent -> Maybe (WidgetEventResult s e m),
-- | Handles an custom asynchronous event
--
-- Result of asynchronous computation
--
-- Returns: the list of generated events and, maybe, a new version of the widget if internal state changed
_widgetHandleCustom :: forall i . Typeable i => i -> Maybe (WidgetEventResult s e m),
-- | Minimum size desired by the widget
--
-- Style options
-- Preferred size for each of the children widgets
-- Renderer (mainly for text sizing functions)
--
-- Returns: the minimum size desired by the widget
_widgetPreferredSize :: Renderer m -> Style -> [SizeReq] -> m SizeReq,
-- | Resizes the children of this widget
--
-- Region assigned to the widget
-- Style options
-- Preferred size for each of the children widgets
--
-- Returns: the size assigned to each of the children
_widgetResizeChildren :: Rect -> Rect -> Style -> [SizeReq] -> Maybe (WidgetResizeResult s e m),
-- | Renders the widget
--
-- Renderer
-- Style options
-- renderArea: The area of the screen where the widget can draw
-- viewport: The visible area of the screen assigned to the widget
-- Indicates if the widget (and its children) are enabled
-- Indicates if the widget has focus
-- The current time in milliseconds
--
-- Returns: unit
_widgetRender :: Renderer m -> WidgetInstance s e m -> WidgetChildren s e m -> Timestamp -> m ()
}
-- | Complementary information to a Widget, forming a node in the view tree
--
-- Type variables:
-- * n: Identifier for a node
data WidgetInstance s e m =
(MonadState s m) => WidgetInstance {
-- | Key/Identifier of the widget. If provided, it needs to be unique in the same hierarchy level (not globally)
_widgetInstanceKey :: Maybe WidgetKey,
-- | The actual widget
_widgetInstanceWidget :: Widget s e m,
-- | Indicates if the widget is enabled for user interaction
_widgetInstanceEnabled :: Bool,
-- | Indicates if the widget is focused
_widgetInstanceFocused :: Bool,
-- | The visible area of the screen assigned to the widget
_widgetInstanceViewport :: Rect,
-- | The area of the screen where the widget can draw
-- | Usually equal to _widgetInstanceViewport, but may be larger if the widget is wrapped in a scrollable container
_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
key key wn = wn { _widgetInstanceKey = Just key }
style :: (MonadState s m) => WidgetNode s e m -> Style -> WidgetNode s e m
style (Node value children) newStyle = Node (value { _widgetInstanceStyle = newStyle }) children
children :: (MonadState s m) => WidgetNode s e m -> [WidgetNode s e m] -> WidgetNode s e m
children (Node value _) newChildren = fromList value newChildren
cascadeStyle :: (MonadState s m) => Style -> WidgetNode s e m -> WidgetNode s e m
cascadeStyle parentStyle (Node (wn@WidgetInstance{..}) children) = newNode where
newNode = Node (wn { _widgetInstanceStyle = newStyle }) newChildren
newStyle = _widgetInstanceStyle <> parentStyle
newChildren = fmap (cascadeStyle newStyle) children
defaultWidgetInstance :: (MonadState s m) => Widget s e m -> WidgetInstance s e m
defaultWidgetInstance widget = WidgetInstance {
_widgetInstanceKey = Nothing,
_widgetInstanceWidget = widget,
_widgetInstanceEnabled = True,
_widgetInstanceFocused = False,
_widgetInstanceViewport = def,
_widgetInstanceRenderArea = def,
_widgetInstanceStyle = mempty
}
singleWidget :: (MonadState s m) => Widget s e m -> WidgetNode s e m
singleWidget widget = singleton (defaultWidgetInstance widget)
parentWidget :: (MonadState s m) => Widget s e m -> [WidgetNode s e m] -> WidgetNode s e m
parentWidget widget = fromList (defaultWidgetInstance widget)
widgetMatches :: (MonadState s m) => WidgetInstance s e m -> WidgetInstance s e m -> Bool
widgetMatches wn1 wn2 = _widgetType (_widgetInstanceWidget wn1) == _widgetType (_widgetInstanceWidget wn2) && _widgetInstanceKey wn1 == _widgetInstanceKey wn2
mergeTrees :: (MonadState s m) => WidgetNode s e m -> WidgetNode s e m -> WidgetNode s e m
mergeTrees node1@(Node candidateInstance candidateChildren) (Node oldInstance oldChildren) = newNode where
matches = widgetMatches candidateInstance oldInstance
newNode = if | matches -> Node newInstance newChildren
| otherwise -> node1
oldWidget = _widgetInstanceWidget oldInstance
candidateWidget = _widgetInstanceWidget candidateInstance
newWidget = case _widgetSaveState oldWidget of
Just st -> fromMaybe candidateWidget (_widgetRestoreState candidateWidget st)
Nothing -> candidateWidget
newInstance = candidateInstance { _widgetInstanceWidget = newWidget }
newChildren = mergedChildren SQ.>< addedChildren
mergedChildren = fmap mergeChild (SQ.zip candidateChildren oldChildren)
addedChildren = SQ.drop (SQ.length oldChildren) candidateChildren
mergeChild = \(c1, c2) -> mergeTrees c1 c2
handleWidgetEvents :: (MonadState s m) => Widget s e m -> Rect -> SystemEvent -> Maybe (WidgetEventResult s e m)
handleWidgetEvents (Widget {..}) viewport systemEvent = _widgetHandleEvent viewport systemEvent
data ChildEventResult s e m = ChildEventResult {
cerIgnoreParentEvents :: Bool,
cerEventRequests :: [(Path, EventRequest)],
cerUserEvents :: SQ.Seq e,
cerNewTreeNode :: Maybe (WidgetNode s e m)
}
handleChildEvent :: (MonadState s m) => (a -> SQ.Seq (WidgetNode s e m) -> (a, Maybe Int)) -> a -> Path -> WidgetNode s e m -> SystemEvent -> ChildEventResult s e m
handleChildEvent selectorFn selector path treeNode@(Node wn@WidgetInstance{..} children) systemEvent = ChildEventResult ignoreParentEvents eventRequests userEvents newTreeNode where
(ignoreParentEvents, eventRequests, userEvents, newTreeNode) = case (ice, ipeChild) of
(True, _) -> (ipe, er, ue, newNode1)
(_, True) -> (ipeChild, erChild, ueChild, newNode1)
(_, False) -> (ipe, erChild ++ er, ueChild SQ.>< ue, newNode2)
-- Children widgets
(ipeChild, erChild, ueChild, tnChild, tnChildIdx) = case selectorFn selector children of
(_, Nothing) -> (False, [], SQ.empty, Nothing, 0)
(newSelector, Just idx) -> (ipe2, er2, ue2, tn2, idx) where
(ChildEventResult ipe2 er2 ue2 tn2) = handleChildEvent selectorFn newSelector widgetPath (SQ.index children idx) systemEvent
widgetPath = reverse (idx:path)
-- Current widget
(ice, ipe, er, ue, tn) = case handleWidgetEvents _widgetInstanceWidget _widgetInstanceRenderArea systemEvent of
Nothing -> (False, False, [], SQ.empty, Nothing)
Just (WidgetEventResult er2 ue2 widget) -> (ice, ipe, pathEvents, SQ.fromList ue2, updatedNode) where
ice = elem IgnoreChildrenEvents er2
ipe = elem IgnoreParentEvents er2
pathEvents = fmap (path,) er2
updatedNode = 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)
newNode2 = case (tn, tnChild) of
(Nothing, Nothing) -> Nothing
(Nothing, Just cn) -> newNode1
(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 -> ChildEventResult 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 -> ChildEventResult 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
inNodeRect = \(Node (WidgetInstance {..}) _, _) -> inRect _widgetInstanceViewport point
childrenPair = SQ.zip children (SQ.fromList [0..(length children - 1)])
handleCustomCommand :: (MonadState s m, Typeable i) => Path -> WidgetNode s e m -> i -> ChildEventResult s e m
handleCustomCommand path treeNode customData = traceShow path $ case GUI.Data.Tree.lookup path treeNode of
Just (WidgetInstance{ _widgetInstanceWidget = Widget{..}, ..}) ->
case _widgetHandleCustom customData of
Just (WidgetEventResult er ue tn) -> ChildEventResult False (fmap (path,) er) (SQ.fromList ue) Nothing
Nothing -> ChildEventResult False [] SQ.Empty Nothing
Nothing -> ChildEventResult False [] SQ.Empty Nothing
handleRender :: (MonadState s m) => Renderer m -> WidgetNode s e m -> Timestamp -> m ()
handleRender renderer (Node (widgetInstance@WidgetInstance { _widgetInstanceWidget = Widget{..}, .. }) children) ts = do
_widgetRender renderer widgetInstance children ts
handleRenderChildren :: (MonadState s m) => Renderer m -> WidgetChildren s e m -> Timestamp -> m ()
handleRenderChildren renderer children ts = do
mapM_ (\treeNode -> handleRender renderer treeNode ts) children
updateWidgetInstance :: Path -> WidgetNode s e m -> (WidgetInstance s e m -> WidgetInstance s e m) -> Maybe (WidgetNode s e m)
updateWidgetInstance path root updateFn = updateNode path root (\(Node widgetInstance children) -> Node (updateFn widgetInstance) children)
setFocusedStatus :: Path -> Bool -> WidgetNode s e m -> WidgetNode s e m
setFocusedStatus path focused root = case updateWidgetInstance path root updateFn of
Just newRoot -> newRoot
Nothing -> root
where
updateFn wn@(WidgetInstance {..}) = wn {
_widgetInstanceFocused = focused
}
resizeUI :: (MonadState s m) => Renderer m -> Rect -> WidgetNode s e m -> m (WidgetNode s e m)
resizeUI renderer assignedRect widgetInstance = do
preferredSizes <- buildPreferredSizes renderer widgetInstance
resizeNode renderer assignedRect assignedRect preferredSizes widgetInstance
buildPreferredSizes :: (MonadState s m) => Renderer m -> WidgetNode s e m -> m (Tree SizeReq)
buildPreferredSizes renderer (Node (WidgetInstance {..}) children) = do
childrenSizes <- mapM (buildPreferredSizes renderer) children
size <- _widgetPreferredSize _widgetInstanceWidget renderer _widgetInstanceStyle (seqToList childrenSizes)
return $ Node size childrenSizes
resizeNode :: (MonadState s m) => Renderer m -> Rect -> Rect -> Tree SizeReq -> WidgetNode s e m -> m (WidgetNode s e m)
resizeNode renderer viewport renderArea (Node _ childrenSizes) (Node widgetInstance childrenWns) = do
newChildren <- mapM childResize childrenPair
return (Node updatedNode newChildren)
where
widget = _widgetInstanceWidget widgetInstance
style = _widgetInstanceStyle widgetInstance
(WidgetResizeResult viewports renderAreas newWidget) = case (_widgetResizeChildren widget) viewport renderArea style (seqToList childrenSizes) of
Nothing -> WidgetResizeResult [] [] Nothing
Just wrr -> wrr
updatedNode = widgetInstance {
_widgetInstanceViewport = viewport,
_widgetInstanceRenderArea = renderArea,
_widgetInstanceWidget = fromMaybe widget newWidget
}
childrenPair = SQ.zip4 childrenSizes childrenWns (SQ.fromList viewports) (SQ.fromList renderAreas)
childResize = \(size, node, viewport, renderArea) -> resizeNode renderer viewport renderArea size node

2
src/GUI/Widget/Grid.hs
View File

@ -10,8 +10,8 @@ import Data.Default
import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Style
import GUI.Common.Types
import GUI.Data.Tree
import GUI.Widget.Core
import qualified Data.Text as T

2
src/GUI/Widget/Label.hs
View File

@ -8,8 +8,8 @@ import Control.Monad.State
import GUI.Common.Core
import GUI.Common.Drawing
import GUI.Common.Style
import GUI.Common.Types
import GUI.Data.Tree
import GUI.Widget.Core
import qualified Data.Text as T

3
src/GUI/Widget/Sandbox.hs
View File

@ -15,8 +15,9 @@ import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Drawing
import GUI.Common.Style
import GUI.Common.Types
import GUI.Common.Util
import GUI.Data.Tree
import GUI.Widget.Core
import GHC.Generics

3
src/GUI/Widget/Scroll.hs
View File

@ -16,8 +16,9 @@ import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Drawing
import GUI.Common.Style
import GUI.Common.Types
import GUI.Common.Util
import GUI.Data.Tree
import GUI.Widget.Core
import GHC.Generics

2
src/GUI/Widget/Spacer.hs
View File

@ -7,8 +7,8 @@ import Control.Monad.State
import GUI.Common.Core
import GUI.Common.Style
import GUI.Common.Types
import GUI.Data.Tree
import GUI.Widget.Core
spacer :: (MonadState s m) => WidgetNode s e m
spacer = singleWidget makeSpacer

2
src/GUI/Widget/Stack.hs
View File

@ -9,8 +9,8 @@ import Control.Monad.State
import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Style
import GUI.Common.Types
import GUI.Data.Tree
import GUI.Widget.Core
hstack :: (MonadState s m) => [WidgetNode s e m] -> WidgetNode s e m
hstack = parentWidget makeHStack

2
src/GUI/Widget/TextField.hs
View File

@ -16,8 +16,8 @@ import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Drawing
import GUI.Common.Style
import GUI.Common.Types
import GUI.Data.Tree
import GUI.Widget.Core
import GHC.Generics

4
src/GUI/Widgets.hs
View File

@ -1,5 +1,5 @@
module GUI.Widgets (
module GUI.Widget.Core,
module GUI.Common.Core,
module GUI.Widget.Button,
module GUI.Widget.Grid,
module GUI.Widget.Label,
@ -10,7 +10,7 @@ module GUI.Widgets (
module GUI.Widget.TextField
) where
import GUI.Widget.Core (key, style, children)
import GUI.Common.Core (key, style, children)
import GUI.Widget.Button
import GUI.Widget.Grid
import GUI.Widget.Label