fjvallarino/monomer
1
1
Fork 0
mirror of https://github.com/fjvallarino/monomer.git synced 2024-09-20 16:27:49 +03:00
Code Issues Projects Releases Wiki Activity

Promote Common/Core to a top level module and split into submodules

Browse Source
This commit is contained in:
Francisco Vallarino 2020-05-11 19:53:41 -03:00
parent ca95f4f3d8
commit 6f15890840
23 changed files with 453 additions and 405 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
app/Main.hs
View File

@ -25,17 +25,19 @@ import qualified SDL.Raw.Error as SRE
import qualified SDL.Raw.Event as SREv
import Types
import Monomer.Common.Core
import Monomer.Common.Style
import Monomer.Common.Types
import Monomer.Common.Util
import Monomer.Data.Tree
import Monomer.Main.Core
import Monomer.Main.Platform
import Monomer.Widgets
import Monomer.Graphics.Color
import Monomer.Graphics.Types
import Monomer.Main.Core
import Monomer.Main.Platform
import Monomer.Main.Types
import Monomer.Main.Util
import Monomer.Widget.Core
import Monomer.Widget.Util
import Monomer.Widgets
foreign import ccall unsafe "initGlew" glewInit :: IO CInt

6
src/Monomer/Main/Core.hs
View File

@ -15,18 +15,22 @@ import qualified Graphics.Rendering.OpenGL as GL
import qualified SDL
import qualified NanoVG as NV
import Monomer.Common.Core
import Monomer.Common.Types
import Monomer.Common.Util
import Monomer.Event.Core
import Monomer.Event.Types
import Monomer.Main.Internal
import Monomer.Main.Handlers
import Monomer.Main.Platform
import Monomer.Main.UserTask
import Monomer.Main.Types
import Monomer.Main.Util
import Monomer.Main.WidgetTask
import Monomer.Graphics.NanoVGRenderer
import Monomer.Graphics.Renderer
import Monomer.Widget.Core
import Monomer.Widget.Types
import Monomer.Widget.Util
runWidgets :: (MonomerM s e m) => SDL.Window -> NV.Context -> MonomerApp s e m -> m ()
runWidgets window c mapp = do

5
src/Monomer/Main/Handlers.hs
View File

@ -10,18 +10,21 @@ import Lens.Micro.Mtl
import qualified Data.List as L
import qualified SDL
import Monomer.Common.Core
import Monomer.Common.Types
import Monomer.Common.Util
import Monomer.Data.Tree
import Monomer.Event.Core
import Monomer.Event.Keyboard
import Monomer.Event.Types
import Monomer.Main.Internal
import Monomer.Main.Platform
import Monomer.Main.UserTask
import Monomer.Main.WidgetTask
import Monomer.Main.Types
import Monomer.Main.Util
import Monomer.Graphics.Renderer
import Monomer.Widget.Core
import Monomer.Widget.Types
type HandlerStep s e m = (s, WidgetNode s e m, [e])

31
src/Monomer/Main/Internal.hs Normal file
View File

@ -0,0 +1,31 @@
{-# LANGUAGE FlexibleContexts #-}
module Monomer.Main.Internal where
import Lens.Micro.Mtl
import Monomer.Data.Tree
import Monomer.Event.Types
import Monomer.Main.Types
import Monomer.Widget.Types
getCurrentFocus :: (MonomerM s e m) => m Path
getCurrentFocus = do
ring <- use focusRing
return (if length ring > 0 then ring!!0 else [])
collectPaths :: (Monad m) => Tree (WidgetInstance s e m) -> Path -> [(WidgetInstance s e m, Path)]
collectPaths treeNode path = fmap (\(node, path) -> (node, reverse path)) (collectReversedPaths treeNode path)
collectReversedPaths :: (Monad m) => Tree (WidgetInstance s e m) -> Path -> [(WidgetInstance s e m, Path)]
collectReversedPaths (Node widgetNode children) path = (widgetNode, path) : remainingItems where
pairs = zip (seqToNodeList children) (map (: path) [0..])
remainingItems = concatMap (\(wn, path) -> collectReversedPaths wn path) pairs
isCustomHandler :: (Path, EventRequest) -> Bool
isCustomHandler (_, RunCustom _) = True
isCustomHandler _ = False
isUpdateUserState :: (Path, EventRequest) -> Bool
isUpdateUserState (_, UpdateUserState) = True
isUpdateUserState _ = False

50
src/Monomer/Main/Types.hs Normal file
View File

@ -0,0 +1,50 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
module Monomer.Main.Types where
import Control.Concurrent.Async
import Control.Monad.State
import Data.Typeable (Typeable)
import Lens.Micro.TH (makeLenses)
import Monomer.Common.Types
import Monomer.Data.Tree
import Monomer.Event.Types
import Monomer.Widget.Types
type MonomerM s e m = (MonadState (MonomerContext s e) m, MonadIO m, Eq s)
type UIBuilder s e m = s -> WidgetNode s e m
type AppEventHandler s e = s -> e -> EventResponse s e
data EventResponse s e = State s | StateEvent s e | Task s (IO (Maybe e))
data MonomerApp s e m = MonomerApp {
_uiBuilder :: UIBuilder s e m,
_appEventHandler :: AppEventHandler s e
}
data MonomerContext s e = MonomerContext {
_appContext :: s,
_windowSize :: Rect,
_useHiDPI :: Bool,
_devicePixelRate :: Double,
_inputStatus :: InputStatus,
_focusRing :: [Path],
_latestHover :: Maybe Path,
_userTasks :: [UserTask (Maybe e)],
_widgetTasks :: [WidgetTask]
}
data UserTask e = UserTask {
userTask :: Async e
}
data WidgetTask = forall a . Typeable a => WidgetTask {
widgetTaskPath :: Path,
widgetTask :: Async a
}
makeLenses ''MonomerContext

2
src/Monomer/Main/UserTask.hs
View File

@ -10,7 +10,7 @@ import Control.Monad.IO.Class
import Data.Maybe
import Lens.Micro.Mtl
import Monomer.Common.Core
import Monomer.Main.Types
launchUserTasks :: MonomerM a e m => [IO (Maybe e)] -> m ()
launchUserTasks handlers = do

42
src/Monomer/Main/Util.hs
View File

@ -1,30 +1,18 @@
{-# LANGUAGE FlexibleContexts #-}
module Monomer.Main.Util where
import Lens.Micro.Mtl
import Monomer.Common.Types
import Monomer.Event.Util
import Monomer.Main.Types
import Monomer.Common.Core
import Monomer.Data.Tree
import Monomer.Event.Types
getCurrentFocus :: (MonomerM s e m) => m Path
getCurrentFocus = do
ring <- use focusRing
return (if length ring > 0 then ring!!0 else [])
collectPaths :: (Monad m) => Tree (WidgetInstance s e m) -> Path -> [(WidgetInstance s e m, Path)]
collectPaths treeNode path = fmap (\(node, path) -> (node, reverse path)) (collectReversedPaths treeNode path)
collectReversedPaths :: (Monad m) => Tree (WidgetInstance s e m) -> Path -> [(WidgetInstance s e m, Path)]
collectReversedPaths (Node widgetNode children) path = (widgetNode, path) : remainingItems where
pairs = zip (seqToNodeList children) (map (: path) [0..])
remainingItems = concatMap (\(wn, path) -> collectReversedPaths wn path) pairs
isCustomHandler :: (Path, EventRequest) -> Bool
isCustomHandler (_, RunCustom _) = True
isCustomHandler _ = False
isUpdateUserState :: (Path, EventRequest) -> Bool
isUpdateUserState (_, UpdateUserState) = True
isUpdateUserState _ = False
initMonomerContext :: s -> Rect -> Bool -> Double -> MonomerContext s e
initMonomerContext app winSize useHiDPI devicePixelRate = MonomerContext {
_appContext = app,
_windowSize = winSize,
_useHiDPI = useHiDPI,
_devicePixelRate = devicePixelRate,
_inputStatus = defInputStatus,
_focusRing = [],
_latestHover = Nothing,
_userTasks = [],
_widgetTasks = []
}

5
src/Monomer/Main/WidgetTask.hs
View File

@ -13,13 +13,16 @@ import Lens.Micro.Mtl
import qualified Data.List as L
import Monomer.Common.Core
import Monomer.Common.Types
import Monomer.Common.Util
import Monomer.Data.Tree
import Monomer.Event.Core
import Monomer.Event.Types
import Monomer.Main.Internal
import Monomer.Main.Util
import Monomer.Main.Types
import Monomer.Widget.Core
import Monomer.Widget.Types
launchWidgetTasks :: (MonomerM s e m) => [(Path, EventRequest)] -> m ()
launchWidgetTasks eventRequests = do

325
src/Monomer/Common/Core.hs → src/Monomer/Widget/Core.hs
View File

@ -1,31 +1,16 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Monomer.Common.Core where
module Monomer.Widget.Core where
import Control.Applicative
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.State
import Data.Default
import Data.Maybe
import Data.String
import Data.Typeable (cast, Typeable)
import GHC.Generics
import Lens.Micro.TH (makeLenses)
import Data.Typeable (Typeable)
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Sequence as SQ
import Monomer.Common.Style
@ -34,254 +19,9 @@ import Monomer.Common.Util
import Monomer.Data.Tree
import Monomer.Event.Core
import Monomer.Event.Types
import Monomer.Event.Util
import Monomer.Graphics.Renderer
data UserTask e = UserTask {
userTask :: Async e
}
type Timestamp = Int
type MonomerM s e m = (MonadState (MonomerContext s e) m, MonadIO m, Eq s)
data EventResponse s e = State s | StateEvent s e | Task s (IO (Maybe e))
type WidgetNode s e m = Tree (WidgetInstance s e m)
type WidgetChildren s e m = SQ.Seq (WidgetNode s e m)
type UIBuilder s e m = s -> WidgetNode s e m
type AppEventHandler s e = s -> e -> EventResponse s e
data MonomerApp s e m = MonomerApp {
_uiBuilder :: UIBuilder s e m,
_appEventHandler :: AppEventHandler s e
}
newtype WidgetType = WidgetType String deriving (Eq, Show)
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 Direction = Horizontal | Vertical deriving (Show, Eq)
data SizePolicy = StrictSize |
FlexibleSize |
RemainderSize deriving (Show, Eq)
data SizeReq = SizeReq {
_srSize :: Size,
_srPolicyWidth :: SizePolicy,
_srPolicyHeight :: SizePolicy,
_srVisible :: Bool
} deriving (Show, Eq)
data WidgetEventResult s e m = WidgetEventResult {
_eventResultRequest :: [EventRequest],
_eventResultUserEvents :: [e],
_eventResultNewWidget :: Maybe (Widget s e m),
_eventResultNewState :: s -> s
}
data WidgetResizeResult s e m = WidgetResizeResult {
_resizeResultRenderAreas :: [Rect],
_resizeResultViewports :: [Rect],
_resizeResultWidget :: Maybe (Widget s e m)
}
data WidgetTask = forall a . Typeable a => WidgetTask {
widgetTaskPath :: Path,
widgetTask :: Async a
}
data ChildEventResult s e m = ChildEventResult {
cerIgnoreParentEvents :: Bool,
cerEventRequests :: [(Path, EventRequest)],
cerUserEvents :: [e],
cerNewTreeNode :: Maybe (WidgetNode s e m),
cerNewState :: [s -> s]
}
data Widget s e m =
(Monad 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 :: s -> Maybe WidgetState -> Maybe (Widget s e m),
-- | Returns the current internal state, which can later be used to restore the widget
_widgetSaveState :: s -> 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 :: s -> 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 => s -> 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 -> s -> Style -> [SizeReq] -> m SizeReq,
-- | Resizes the children of this widget
--
-- Vieport assigned to the 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
-- The widget instance to render
-- The current time in milliseconds
--
-- Returns: unit
_widgetRender :: Renderer m -> s -> WidgetInstance s e m -> Timestamp -> m (),
_widgetRenderPost :: Renderer m -> s -> WidgetInstance 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 =
(Monad 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 visible
_widgetInstanceVisible :: 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
}
data MonomerContext s e = MonomerContext {
_appContext :: s,
_windowSize :: Rect,
_useHiDPI :: Bool,
_devicePixelRate :: Double,
_inputStatus :: InputStatus,
_focusRing :: [Path],
_latestHover :: Maybe Path,
_userTasks :: [UserTask (Maybe e)],
_widgetTasks :: [WidgetTask]
}
makeLenses ''MonomerContext
initMonomerContext :: s -> Rect -> Bool -> Double -> MonomerContext s e
initMonomerContext app winSize useHiDPI devicePixelRate = MonomerContext {
_appContext = app,
_windowSize = winSize,
_useHiDPI = useHiDPI,
_devicePixelRate = devicePixelRate,
_inputStatus = defInputStatus,
_focusRing = [],
_latestHover = Nothing,
_userTasks = [],
_widgetTasks = []
}
sizeReq :: Size -> SizePolicy -> SizePolicy -> SizeReq
sizeReq size policyWidth policyHeight = SizeReq size policyWidth policyHeight True
resultEvents :: [e] -> Maybe (WidgetEventResult s e m)
resultEvents userEvents = Just $ WidgetEventResult [] userEvents Nothing id
resultEventsWidget :: [e] -> (Widget s e m) -> Maybe (WidgetEventResult s e m)
resultEventsWidget userEvents newWidget = Just $ WidgetEventResult [] userEvents (Just newWidget) id
isFocusable :: (Monad m) => WidgetInstance s e m -> Bool
isFocusable (WidgetInstance { _widgetInstanceWidget = Widget{..}, ..}) = _widgetInstanceVisible && _widgetInstanceEnabled && _widgetFocusable
defaultCustomHandler :: Typeable i => s -> i -> Maybe (WidgetEventResult s e m)
defaultCustomHandler _ _ = Nothing
ignoreRestoreState :: s -> Maybe WidgetState -> Maybe (Widget s e m)
ignoreRestoreState _ _ = Nothing
ignoreSaveState :: s -> Maybe WidgetState
ignoreSaveState _ = Nothing
ignoreHandleEvent :: (Monad m) => s -> Rect -> SystemEvent -> Maybe (WidgetEventResult s e m)
ignoreHandleEvent _ _ _ = Nothing
ignorePreferredSize :: (Monad m) => Renderer m -> s -> Style -> [SizeReq] -> m SizeReq
ignorePreferredSize _ _ _ _ = return $ SizeReq (Size 0 0) FlexibleSize FlexibleSize False
ignoreResizeChildren :: (Monad m) => Rect -> Rect -> Style -> [SizeReq] -> Maybe (WidgetResizeResult s e m)
ignoreResizeChildren _ _ _ _ = Nothing
ignoreRender :: (Monad m) => Renderer m -> s -> WidgetInstance s e m -> Timestamp -> m ()
ignoreRender _ _ _ _ = return ()
ignoreRenderPost :: (Monad m) => Renderer m -> s -> WidgetInstance s e m -> Timestamp -> m ()
ignoreRenderPost _ _ _ _ = return ()
baseWidget :: (Monad m) => Widget s e m
baseWidget = Widget {
_widgetType = "base",
_widgetFocusable = False,
_widgetRestoreState = ignoreRestoreState,
_widgetSaveState = ignoreSaveState,
_widgetHandleEvent = ignoreHandleEvent,
_widgetHandleCustom = defaultCustomHandler,
_widgetPreferredSize = ignorePreferredSize,
_widgetResizeChildren = ignoreResizeChildren,
_widgetRender = ignoreRender,
_widgetRenderPost = ignoreRenderPost
}
makeState :: (Typeable i, Generic i) => i -> s -> Maybe WidgetState
makeState state app = Just (WidgetState state)
useState :: (Typeable i, Generic i) => Maybe WidgetState -> Maybe i
useState Nothing = Nothing
useState (Just (WidgetState state)) = cast state
defaultRestoreState :: (Monad m, Typeable i, Generic i) => (i -> Widget s e m) -> s -> Maybe WidgetState -> Maybe (Widget s e m)
defaultRestoreState makeState _ oldState = fmap makeState $ useState oldState
key :: (Monad m) => WidgetKey -> WidgetInstance s e m -> WidgetInstance s e m
key key wn = wn { _widgetInstanceKey = Just key }
style :: (Monad m) => WidgetNode s e m -> Style -> WidgetNode s e m
style (Node value children) newStyle = Node (value { _widgetInstanceStyle = newStyle }) children
visible :: (Monad m) => WidgetNode s e m -> Bool -> WidgetNode s e m
visible (Node value children) visibility = Node (value { _widgetInstanceVisible = visibility }) children
children :: (Monad m) => WidgetNode s e m -> [WidgetNode s e m] -> WidgetNode s e m
children (Node value _) newChildren = fromList value newChildren
import Monomer.Widget.Internal
import Monomer.Widget.Types
cascadeStyle :: (Monad m) => Style -> WidgetNode s e m -> WidgetNode s e m
cascadeStyle parentStyle (Node (wn@WidgetInstance{..}) children) = newNode where
@ -297,27 +37,6 @@ cascadeStyle parentStyle (Node (wn@WidgetInstance{..}) children) = newNode where
}
newChildren = fmap (cascadeStyle newStyle) children
defaultWidgetInstance :: (Monad m) => Widget s e m -> WidgetInstance s e m
defaultWidgetInstance widget = WidgetInstance {
_widgetInstanceKey = Nothing,
_widgetInstanceWidget = widget,
_widgetInstanceEnabled = True,
_widgetInstanceVisible = True,
_widgetInstanceFocused = False,
_widgetInstanceViewport = def,
_widgetInstanceRenderArea = def,
_widgetInstanceStyle = mempty
}
singleWidget :: (Monad m) => Widget s e m -> WidgetNode s e m
singleWidget widget = singleton (defaultWidgetInstance widget)
parentWidget :: (Monad m) => Widget s e m -> [WidgetNode s e m] -> WidgetNode s e m
parentWidget widget = fromList (defaultWidgetInstance widget)
empty :: (Monad m) => WidgetNode s e m
empty = singleWidget baseWidget
widgetMatches :: (Monad m) => WidgetInstance s e m -> WidgetInstance s e m -> Bool
widgetMatches wn1 wn2 = _widgetType (_widgetInstanceWidget wn1) == _widgetType (_widgetInstanceWidget wn2) && _widgetInstanceKey wn1 == _widgetInstanceKey wn2
@ -336,26 +55,6 @@ mergeTrees app node1@(Node candidateInstance candidateChildren) (Node oldInstanc
addedChildren = SQ.drop (SQ.length oldChildren) candidateChildren
mergeChild = \(c1, c2) -> mergeTrees app c1 c2
type ChildrenSelector s e m a = a -> SQ.Seq (WidgetNode s e m) -> (a, Maybe Int)
data EventsParent s e m = EventsParent {
epIgnoreChildrenEvents :: Bool,
epIgnoreParentEvents :: Bool,
epEventRequests :: [(Path, EventRequest)],
epUserEvents :: [e],
epUpdatedNode :: Maybe (Tree (WidgetInstance s e m)),
epNewStates :: [s -> s]
}
data EventsChildren s e m = EventsChildren {
ecIgnoreParentEvents :: Bool,
ecEventRequests :: [(Path, EventRequest)],
ecUserEvents :: [e],
ecUpdatedNode :: Maybe (Tree (WidgetInstance s e m)),
ecNewStates :: [s -> s],
ecNodePosition :: Int
}
handleWidgetEvents :: (Monad m) => s -> Widget s e m -> Rect -> SystemEvent -> Maybe (WidgetEventResult s e m)
handleWidgetEvents app widget viewport systemEvent = _widgetHandleEvent widget app viewport systemEvent
@ -504,19 +203,9 @@ buildPreferredSizes renderer app parentVisible (Node (WidgetInstance {..}) child
updateSizeReq :: SizeReq -> Maybe Double -> Maybe Double -> SizeReq
updateSizeReq sr Nothing Nothing = sr
updateSizeReq sr (Just width) Nothing = sr {
_srSize = Size width (_h . _srSize $ sr),
_srPolicyWidth = StrictSize
}
updateSizeReq sr Nothing (Just height) = sr {
_srSize = Size (_w . _srSize $ sr) height,
_srPolicyHeight = StrictSize
}
updateSizeReq sr (Just width) (Just height) = sr {
_srSize = Size width height,
_srPolicyWidth = StrictSize,
_srPolicyHeight = StrictSize
}
updateSizeReq sr (Just width) Nothing = sr { _srSize = Size width (_h . _srSize $ sr), _srPolicyWidth = StrictSize }
updateSizeReq sr Nothing (Just height) = sr { _srSize = Size (_w . _srSize $ sr) height, _srPolicyHeight = StrictSize }
updateSizeReq sr (Just width) (Just height) = sr { _srSize = Size width height, _srPolicyWidth = StrictSize, _srPolicyHeight = StrictSize }
resizeNode :: (Monad 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

41
src/Monomer/Widget/Internal.hs Normal file
View File

@ -0,0 +1,41 @@
module Monomer.Widget.Internal where
import Data.Default
import qualified Data.Sequence as SQ
import Monomer.Data.Tree
import Monomer.Event.Types
import Monomer.Widget.Types
type ChildrenSelector s e m a = a -> SQ.Seq (WidgetNode s e m) -> (a, Maybe Int)
data EventsParent s e m = EventsParent {
epIgnoreChildrenEvents :: Bool,
epIgnoreParentEvents :: Bool,
epEventRequests :: [(Path, EventRequest)],
epUserEvents :: [e],
epUpdatedNode :: Maybe (Tree (WidgetInstance s e m)),
epNewStates :: [s -> s]
}
data EventsChildren s e m = EventsChildren {
ecIgnoreParentEvents :: Bool,
ecEventRequests :: [(Path, EventRequest)],
ecUserEvents :: [e],
ecUpdatedNode :: Maybe (Tree (WidgetInstance s e m)),
ecNewStates :: [s -> s],
ecNodePosition :: Int
}
defaultWidgetInstance :: (Monad m) => Widget s e m -> WidgetInstance s e m
defaultWidgetInstance widget = WidgetInstance {
_widgetInstanceKey = Nothing,
_widgetInstanceWidget = widget,
_widgetInstanceEnabled = True,
_widgetInstanceVisible = True,
_widgetInstanceFocused = False,
_widgetInstanceViewport = def,
_widgetInstanceRenderArea = def,
_widgetInstanceStyle = mempty
}

129
src/Monomer/Widget/Types.hs Normal file
View File

@ -0,0 +1,129 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
module Monomer.Widget.Types where
import Data.Typeable (cast, Typeable)
import GHC.Generics
import qualified Data.Sequence as SQ
import Monomer.Common.Style
import Monomer.Common.Types
import Monomer.Data.Tree
import Monomer.Event.Types
import Monomer.Graphics.Renderer
type Timestamp = Int
type WidgetType = String
type WidgetKey = String
type WidgetNode s e m = Tree (WidgetInstance s e m)
type WidgetChildren s e m = SQ.Seq (WidgetNode s e m)
data WidgetState = forall i . (Typeable i, Generic i) => WidgetState i
data SizePolicy = StrictSize | FlexibleSize | RemainderSize deriving (Show, Eq)
data SizeReq = SizeReq {
_srSize :: Size,
_srPolicyWidth :: SizePolicy,
_srPolicyHeight :: SizePolicy,
_srVisible :: Bool
} deriving (Show, Eq)
data WidgetEventResult s e m = WidgetEventResult {
_eventResultRequest :: [EventRequest],
_eventResultUserEvents :: [e],
_eventResultNewWidget :: Maybe (Widget s e m),
_eventResultNewState :: s -> s
}
data WidgetResizeResult s e m = WidgetResizeResult {
_resizeResultRenderAreas :: [Rect],
_resizeResultViewports :: [Rect],
_resizeResultWidget :: Maybe (Widget s e m)
}
data ChildEventResult s e m = ChildEventResult {
cerIgnoreParentEvents :: Bool,
cerEventRequests :: [(Path, EventRequest)],
cerUserEvents :: [e],
cerNewTreeNode :: Maybe (WidgetNode s e m),
cerNewState :: [s -> s]
}
data Widget s e m =
(Monad 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 :: s -> Maybe WidgetState -> Maybe (Widget s e m),
-- | Returns the current internal state, which can later be used to restore the widget
_widgetSaveState :: s -> 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 :: s -> 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 => s -> 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 -> s -> Style -> [SizeReq] -> m SizeReq,
-- | Resizes the children of this widget
--
-- Vieport assigned to the 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
-- The widget instance to render
-- The current time in milliseconds
--
-- Returns: unit
_widgetRender :: Renderer m -> s -> WidgetInstance s e m -> Timestamp -> m (),
_widgetRenderPost :: Renderer m -> s -> WidgetInstance 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 =
(Monad 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 visible
_widgetInstanceVisible :: 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
}

58
src/Monomer/Widget/Util.hs Normal file
View File

@ -0,0 +1,58 @@
{-# LANGUAGE RecordWildCards #-}
module Monomer.Widget.Util where
import Data.Typeable (cast, Typeable)
import GHC.Generics
import Monomer.Common.Style
import Monomer.Common.Types
import Monomer.Data.Tree
import Monomer.Main.Types
import Monomer.Widget.Internal
import Monomer.Widget.Types
import Monomer.Widget.Widgets.Base
key :: (Monad m) => WidgetKey -> WidgetInstance s e m -> WidgetInstance s e m
key key wn = wn { _widgetInstanceKey = Just key }
style :: (Monad m) => WidgetNode s e m -> Style -> WidgetNode s e m
style (Node value children) newStyle = Node (value { _widgetInstanceStyle = newStyle }) children
visible :: (Monad m) => WidgetNode s e m -> Bool -> WidgetNode s e m
visible (Node value children) visibility = Node (value { _widgetInstanceVisible = visibility }) children
children :: (Monad m) => WidgetNode s e m -> [WidgetNode s e m] -> WidgetNode s e m
children (Node value _) newChildren = fromList value newChildren
isFocusable :: (Monad m) => WidgetInstance s e m -> Bool
isFocusable (WidgetInstance { _widgetInstanceWidget = Widget{..}, ..}) = _widgetInstanceVisible && _widgetInstanceEnabled && _widgetFocusable
empty :: (Monad m) => WidgetNode s e m
empty = singleWidget baseWidget
singleWidget :: (Monad m) => Widget s e m -> WidgetNode s e m
singleWidget widget = singleton (defaultWidgetInstance widget)
parentWidget :: (Monad m) => Widget s e m -> [WidgetNode s e m] -> WidgetNode s e m
parentWidget widget = fromList (defaultWidgetInstance widget)
sizeReq :: Size -> SizePolicy -> SizePolicy -> SizeReq
sizeReq size policyWidth policyHeight = SizeReq size policyWidth policyHeight True
resultEvents :: [e] -> Maybe (WidgetEventResult s e m)
resultEvents userEvents = Just $ WidgetEventResult [] userEvents Nothing id
resultEventsWidget :: [e] -> (Widget s e m) -> Maybe (WidgetEventResult s e m)
resultEventsWidget userEvents newWidget = Just $ WidgetEventResult [] userEvents (Just newWidget) id
makeState :: (Typeable i, Generic i) => i -> s -> Maybe WidgetState
makeState state app = Just (WidgetState state)
useState :: (Typeable i, Generic i) => Maybe WidgetState -> Maybe i
useState Nothing = Nothing
useState (Just (WidgetState state)) = cast state
defaultRestoreState :: (Monad m, Typeable i, Generic i) => (i -> Widget s e m) -> s -> Maybe WidgetState -> Maybe (Widget s e m)
defaultRestoreState makeState _ oldState = fmap makeState $ useState oldState

48
src/Monomer/Widget/Widgets/Base.hs Normal file
View File

@ -0,0 +1,48 @@
module Monomer.Widget.Widgets.Base where
import Control.Monad
import Data.Typeable (Typeable)
import Monomer.Common.Style
import Monomer.Common.Types
import Monomer.Event.Types
import Monomer.Graphics.Renderer
import Monomer.Widget.Types
baseWidget :: (Monad m) => Widget s e m
baseWidget = Widget {
_widgetType = "base",
_widgetFocusable = False,
_widgetRestoreState = ignoreRestoreState,
_widgetSaveState = ignoreSaveState,
_widgetHandleEvent = ignoreHandleEvent,
_widgetHandleCustom = defaultCustomHandler,
_widgetPreferredSize = ignorePreferredSize,
_widgetResizeChildren = ignoreResizeChildren,
_widgetRender = ignoreRender,
_widgetRenderPost = ignoreRenderPost
}
ignoreRestoreState :: s -> Maybe WidgetState -> Maybe (Widget s e m)
ignoreRestoreState _ _ = Nothing
ignoreSaveState :: s -> Maybe WidgetState
ignoreSaveState _ = Nothing
ignoreHandleEvent :: (Monad m) => s -> Rect -> SystemEvent -> Maybe (WidgetEventResult s e m)
ignoreHandleEvent _ _ _ = Nothing
defaultCustomHandler :: Typeable i => s -> i -> Maybe (WidgetEventResult s e m)
defaultCustomHandler _ _ = Nothing
ignorePreferredSize :: (Monad m) => Renderer m -> s -> Style -> [SizeReq] -> m SizeReq
ignorePreferredSize _ _ _ _ = return $ SizeReq (Size 0 0) FlexibleSize FlexibleSize False
ignoreResizeChildren :: (Monad m) => Rect -> Rect -> Style -> [SizeReq] -> Maybe (WidgetResizeResult s e m)
ignoreResizeChildren _ _ _ _ = Nothing
ignoreRender :: (Monad m) => Renderer m -> s -> WidgetInstance s e m -> Timestamp -> m ()
ignoreRender _ _ _ _ = return ()
ignoreRenderPost :: (Monad m) => Renderer m -> s -> WidgetInstance s e m -> Timestamp -> m ()
ignoreRenderPost _ _ _ _ = return ()

7
src/Monomer/Widget/Widgets/Button.hs
View File

@ -4,15 +4,18 @@ module Monomer.Widget.Widgets.Button (button) where
import Control.Monad
import Monomer.Common.Core
import qualified Data.Text as T
import Monomer.Common.Style
import Monomer.Common.Types
import Monomer.Common.Util
import Monomer.Event.Types
import Monomer.Graphics.Drawing
import Monomer.Graphics.Types
import Monomer.Widget.Types
import Monomer.Widget.Util
import Monomer.Widget.Widgets.Base
import qualified Data.Text as T
button :: (Monad m) => T.Text -> e -> WidgetNode s e m
button label onClick = singleWidget (makeButton label onClick)

24
src/Monomer/Widget/Widgets/Grid.hs
View File

@ -4,25 +4,27 @@ module Monomer.Widget.Widgets.Grid (empty, hgrid, vgrid) where
import Control.Monad
import Monomer.Common.Core
import Monomer.Common.Types
import qualified Data.Text as T
import Monomer.Common.Types
import Monomer.Widget.Types
import Monomer.Widget.Util
import Monomer.Widget.Widgets.Base
hgrid :: (Monad m) => [WidgetNode s e m] -> WidgetNode s e m
hgrid = parentWidget makeHGrid
makeHGrid :: (Monad m) => Widget s e m
makeHGrid = makeFixedGrid "hgrid" Horizontal
makeHGrid = makeFixedGrid "hgrid" True
vgrid :: (Monad m) => [WidgetNode s e m] -> WidgetNode s e m
vgrid = parentWidget makeVGrid
makeVGrid :: (Monad m) => Widget s e m
makeVGrid = makeFixedGrid "vgrid" Vertical
makeVGrid = makeFixedGrid "vgrid" False
makeFixedGrid :: (Monad m) => WidgetType -> Direction -> Widget s e m
makeFixedGrid widgetType direction = baseWidget {
makeFixedGrid :: (Monad m) => WidgetType -> Bool -> Widget s e m
makeFixedGrid widgetType isHorizontal = baseWidget {
_widgetType = widgetType,
_widgetHandleEvent = handleEvent,
_widgetPreferredSize = preferredSize,
@ -35,12 +37,12 @@ makeFixedGrid widgetType direction = baseWidget {
reqSize = sizeReq (Size width height) FlexibleSize FlexibleSize
width = if null children then 0 else (fromIntegral wMul) * (maximum . map (_w . _srSize)) children
height = if null children then 0 else (fromIntegral hMul) * (maximum . map (_h . _srSize)) children
wMul = if direction == Horizontal then length children else 1
hMul = if direction == Horizontal then 1 else length children
wMul = if isHorizontal then length children else 1
hMul = if isHorizontal then 1 else length children
resizeChildren _ (Rect l t w h) style children = Just $ WidgetResizeResult newViewports newViewports Nothing where
visibleChildren = filter _srVisible children
cols = if direction == Horizontal then (length visibleChildren) else 1
rows = if direction == Horizontal then 1 else (length visibleChildren)
cols = if isHorizontal then (length visibleChildren) else 1
rows = if isHorizontal then 1 else (length visibleChildren)
foldHelper (accum, index) child = (index : accum, index + if _srVisible child then 1 else 0)
indices = reverse . fst $ foldl foldHelper ([], 0) children
newViewports = fmap resizeChild indices

18
src/Monomer/Widget/Widgets/Label.hs
View File

@ -4,21 +4,15 @@ module Monomer.Widget.Widgets.Label (label) where
import Control.Monad
import Monomer.Common.Core
import Monomer.Common.Style
import Monomer.Graphics.Drawing
import qualified Data.Text as T
{--
import Monomer.Common.Style
import Monomer.Common.Types
import Monomer.Graphics.Drawing
import Monomer.Widget.Types
import Monomer.Widget.Util
import Monomer.Widget.Widgets.Base
***********************************
Implement auto scalable label! Selects correct size to fit the given text
***********************************
--}
label :: (Monad m) => T.Text -> WidgetNode s e m
label caption = singleWidget (makeLabel caption)

13
src/Monomer/Widget/Widgets/Sandbox.hs
View File

@ -4,21 +4,20 @@
module Monomer.Widget.Widgets.Sandbox (sandbox) where
import Control.Monad
import Data.Typeable
import Debug.Trace
import GHC.Generics
import qualified Data.Text as T
import Monomer.Common.Core
import Monomer.Common.Style
import Monomer.Common.Types
import Monomer.Common.Util
import Monomer.Event.Types
import Monomer.Graphics.Drawing
import GHC.Generics
import qualified Data.Text as T
import Monomer.Widget.Types
import Monomer.Widget.Util
import Monomer.Widget.Widgets.Base
data SandboxData = SandboxData | SandboxData2 deriving (Eq, Show, Typeable)
data SandboxState = SandboxState {

8
src/Monomer/Widget/Widgets/Scroll.hs
View File

@ -4,11 +4,11 @@
module Monomer.Widget.Widgets.Scroll (scroll) where
import Control.Monad
import Data.Default
import Data.Typeable
import Control.Monad
import GHC.Generics
import Monomer.Common.Core
import Monomer.Common.Types
import Monomer.Common.Util
import Monomer.Event.Types
@ -16,8 +16,10 @@ import Monomer.Graphics.Color
import Monomer.Graphics.Drawing
import Monomer.Graphics.Renderer
import Monomer.Graphics.Types
import Monomer.Widget.Types
import Monomer.Widget.Util
import Monomer.Widget.Widgets.Base
import GHC.Generics
data ScrollState = ScrollState {
_scDeltaX :: !Double,

4
src/Monomer/Widget/Widgets/Spacer.hs
View File

@ -4,9 +4,11 @@ module Monomer.Widget.Widgets.Spacer (spacer) where
import Control.Monad
import Monomer.Common.Core
import Monomer.Common.Style
import Monomer.Common.Types
import Monomer.Widget.Types
import Monomer.Widget.Util
import Monomer.Widget.Widgets.Base
spacer :: (Monad m) => WidgetNode s e m
spacer = singleWidget makeSpacer

13
src/Monomer/Widget/Widgets/Stack.hs
View File

@ -4,30 +4,31 @@ module Monomer.Widget.Widgets.Stack (hstack, vstack) where
import Control.Monad
import Monomer.Common.Core
import Monomer.Common.Types
import Monomer.Widget.Types
import Monomer.Widget.Util
import Monomer.Widget.Widgets.Base
hstack :: (Monad m) => [WidgetNode s e m] -> WidgetNode s e m
hstack = parentWidget makeHStack
makeHStack :: (Monad m) => Widget s e m
makeHStack = makeStack "hstack" Horizontal
makeHStack = makeStack "hstack" True
vstack :: (Monad m) => [WidgetNode s e m] -> WidgetNode s e m
vstack = parentWidget makeVStack
makeVStack :: (Monad m) => Widget s e m
makeVStack = makeStack "vstack" Vertical
makeVStack = makeStack "vstack" False
makeStack :: (Monad m) => WidgetType -> Direction -> Widget s e m
makeStack widgetType direction = baseWidget {
makeStack :: (Monad m) => WidgetType -> Bool -> Widget s e m
makeStack widgetType isHorizontal = baseWidget {
_widgetType = widgetType,
_widgetHandleEvent = handleEvent,
_widgetPreferredSize = preferredSize,
_widgetResizeChildren = resizeChildren
}
where
isHorizontal = direction == Horizontal
focusable = False
handleEvent _ _ _ = Nothing
preferredSize _ _ _ children = return reqSize where

12
src/Monomer/Widget/Widgets/TextField.hs
View File

@ -5,12 +5,13 @@
module Monomer.Widget.Widgets.TextField where
import Control.Monad
import Data.Maybe
import Data.Typeable
import GHC.Generics
import Lens.Micro
import qualified Data.Text as T
import Monomer.Common.Core
import Monomer.Common.Style
import Monomer.Common.Types
import Monomer.Event.Core
@ -18,10 +19,9 @@ import Monomer.Event.Keyboard
import Monomer.Event.Types
import Monomer.Graphics.Drawing
import Monomer.Graphics.Types
import GHC.Generics
import Lens.Micro
import Monomer.Widget.Types
import Monomer.Widget.Util
import Monomer.Widget.Widgets.Base
caretWidth = 2

2
src/Monomer/Widgets.hs
View File

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

3
tasks.md
View File

@ -35,8 +35,9 @@
- What are good interfaces for the different parts of the system?
- Does it make sense that handleEvent is the only pure function in a widget?
- Based on the previous design, refactor modules
- Replace Default instances for Monoid, if possible
- Improve hstack/vstack
- If space is available space is greater than requested, do not apply resizing logic
- If available space is greater than requested, do not apply resizing logic
- Does a styling engine make sense or doing something similar to Flutter is simpler?
- Could container handle padding and centering?
- Implement styling engine. Think why Maybe Double instead of Maybe Dimension (to handle pixels, percent, etc)