Refactor modules a bit more

app/Main.hs

@@ -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 LocalWidget = Widget App AppEvent WidgetM
-type WidgetTree = TR.Tree (W.WidgetInstance 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
+  Click point _ _       -> handleEventFromPoint point widgets systemEvent
-  WheelScroll point _ _ -> W.handleEventFromPoint point widgets systemEvent
+  WheelScroll point _ _ -> handleEventFromPoint point widgets systemEvent
-  KeyAction _ _         -> W.handleEventFromPath currentFocus widgets systemEvent
+  KeyAction _ _         -> handleEventFromPath currentFocus widgets systemEvent
-  TextInput _           -> W.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 :: (Path, EventRequest) -> Bool
-isCustomHandler (_, W.RunCustom _) = True
+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 WidgetM -> WidgetTree -> WidgetTask -> AppM WidgetTree
-stepWidgetTask renderer widgets (W.WidgetTask path task) = do
+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 :: (MonadState s m) => Tree (WidgetInstance s e m) -> Path -> [(WidgetInstance s e m, Path)]
-collectPaths (TR.Node widgetNode children) path = (widgetNode, reverse path) : remainingItems where
+collectPaths (Node widgetNode children) path = (widgetNode, reverse path) : remainingItems where
-  pairs = zip (TR.seqToNodeList children) (map (: path) [0..])
+  pairs = zip (seqToNodeList children) (map (: path) [0..])
   remainingItems = concatMap (\(wn, path) -> collectPaths wn path) pairs

app/Types.hs

@@ -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

src/GUI/Common/Core.hs

@@ -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 Data.Dynamic
-import Lens.Micro.TH (makeLenses)
+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)
+type Timestamp = Int
-data AlignH = ALeft | ACenter | ARight deriving (Show, Eq)
-data AlignV = ATop | AMiddle | ABottom deriving (Show, Eq)
 
-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 {
+newtype WidgetType = WidgetType String deriving Eq
-  _x :: !Double,
+newtype WidgetKey = WidgetKey String deriving Eq
-  _y :: !Double
+
+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
+data EventRequest = IgnoreParentEvents
-  def = Point 0 0
+                  | IgnoreChildrenEvents
+                  | ResizeChildren
+                  | ResizeAll
+                  | forall a . Typeable a => RunCustom (IO a)
 
-data Size = Size {
+instance Eq EventRequest where
-  _w :: !Double,
+  IgnoreParentEvents == IgnoreParentEvents = True
-  _h :: !Double
+  IgnoreChildrenEvents == IgnoreChildrenEvents = True
-} deriving (Show, Eq)
+  ResizeChildren == ResizeChildren = True
+  ResizeAll == ResizeAll = True
+  _ == _ = False
 
-instance Default Size where
+data WidgetEventResult s e m = WidgetEventResult {
-  def = Size 0 0
+  _eventResultRequest :: [EventRequest],
-
+  _eventResultUserEvents :: [e],
-data Rect = Rect {
+  _eventResultNewWidget :: Maybe (Widget s e m)
-  _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
 }
 
-inRect :: Rect -> Point -> Bool
+data WidgetResizeResult s e m = WidgetResizeResult {
-inRect (Rect x y w h) (Point x2 y2) = (x2 >= x && x2 < x + w) && (y2 >= y && y2 < y + h)
+  _resizeResultRenderAreas :: [Rect],
+  _resizeResultViewports :: [Rect],
+  _resizeResultWidget :: Maybe (Widget s e m)
+}
 
-rotateList :: [a] -> [a]
+data WidgetTask = forall a . Typeable a => WidgetTask {
-rotateList [] = []
+  widgetTaskPath :: Path,
-rotateList (x:xs) = xs ++ [x]
+  widgetTask :: Async a
+}
 
-firstJust :: Maybe a -> Maybe a -> Maybe a
+data ChildEventResult s e m = ChildEventResult {
-firstJust (Just val) _ = Just val
+  cerIgnoreParentEvents :: Bool,
-firstJust _ value = value
+  cerEventRequests :: [(Path, EventRequest)],
+  cerUserEvents :: SQ.Seq e,
+  cerNewTreeNode :: Maybe (WidgetNode s e m)
+}
 
-justDef :: (Default a) => Maybe a -> a
+data Widget s e m =
-justDef Nothing = def
+  (MonadState s m) => Widget {
-justDef (Just val) = val
+    -- | 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
+-- | Complementary information to a Widget, forming a node in the view tree
-midPoint (Point x1 y1) (Point x2 y2) = Point x3 y3 where
+--
-  x3 = (x2 + x1) / 2
+-- Type variables:
-  y3 = (y2 + y1) / 2
+-- * 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
+data GUIContext app = GUIContext {
-moveRect (Rect x y w h) dx dy = Rect (x + dx) (y + dy) w h
+  _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

src/GUI/Common/Drawing.hs

@@ -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

src/GUI/Common/Event.hs

@@ -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)
 

src/GUI/Common/Style.hs

@@ -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
 

src/GUI/Common/Types.hs

@@ -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

src/GUI/Common/Util.hs

@@ -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

src/GUI/Platform/NanoVGRenderer.hs

@@ -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
 

src/GUI/Widget/Button.hs

@@ -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
 

src/GUI/Widget/Core.hs

@@ -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

src/GUI/Widget/Grid.hs

@@ -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
 

src/GUI/Widget/Label.hs

@@ -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
 

src/GUI/Widget/Sandbox.hs

@@ -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
 

src/GUI/Widget/Scroll.hs

@@ -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
 

src/GUI/Widget/Spacer.hs

@@ -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

src/GUI/Widget/Stack.hs

@@ -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

src/GUI/Widget/TextField.hs

@@ -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
 

src/GUI/Widgets.hs

@@ -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