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

Remove Util/Misc module, refactor other Widget Util modules

Browse Source
This commit is contained in:
Francisco Vallarino 2020-11-14 19:14:02 -03:00
parent 3e8e33b499
commit 0ea1ad2131
13 changed files with 102 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
src/Monomer/Core/Util.hs
View File

@ -9,11 +9,8 @@ import Monomer.Core.WidgetTypes
import qualified Monomer.Lens as L
createMoveFocusReq :: WidgetEnv s e -> WidgetRequest s
createMoveFocusReq wenv = MoveFocus direction where
direction
| wenv ^. L.inputStatus . L.keyMod . L.leftShift = FocusBwd
| otherwise = FocusFwd
isMacOS :: WidgetEnv s e -> Bool
isMacOS wenv = _weOS wenv == "Mac OS X"
widgetTreeDesc :: Int -> WidgetInstance s e -> String
widgetTreeDesc level inst = desc where
@ -28,3 +25,16 @@ instanceDesc level inst = instDesc inst where
spaces ++ "vp: " ++ rectDesc (_wiViewport inst) ++ "\n" ++
spaces ++ "req: " ++ show (_wiSizeReqW inst, _wiSizeReqH inst) ++ "\n"
rectDesc r = show (_rX r, _rY r, _rW r, _rH r)
maxNumericValue :: (RealFloat a) => a
maxNumericValue = x where
n = floatDigits x
b = floatRadix x
(_, u) = floatRange x
x = encodeFloat (b^n - 1) (u - n)
numberInBounds :: (Ord a, Num a) => Maybe a -> Maybe a -> a -> Bool
numberInBounds Nothing Nothing _ = True
numberInBounds (Just minVal) Nothing val = val >= minVal
numberInBounds Nothing (Just maxVal) val = val <= maxVal
numberInBounds (Just minVal) (Just maxVal) val = val >= minVal && val <= maxVal

4
src/Monomer/Event.hs
View File

@ -2,10 +2,12 @@ module Monomer.Event (
module Monomer.Event.Core,
module Monomer.Event.Keyboard,
module Monomer.Event.Mouse,
module Monomer.Event.Types
module Monomer.Event.Types,
module Monomer.Event.Util
) where
import Monomer.Event.Core
import Monomer.Event.Keyboard
import Monomer.Event.Mouse
import Monomer.Event.Types
import Monomer.Event.Util

5
src/Monomer/Event/Core.hs
View File

@ -53,8 +53,3 @@ isOnEnter _ = False
isOnLeave :: SystemEvent -> Bool
isOnLeave Leave{} = True
isOnLeave _ = False
isButtonPressed :: InputStatus -> Button -> Bool
isButtonPressed inputStatus button = status == PressedBtn where
currentStatus = M.lookup button (_ipsButtons inputStatus)
status = fromMaybe ReleasedBtn currentStatus

33
src/Monomer/Event/Util.hs Normal file
View File

@ -0,0 +1,33 @@
module Monomer.Event.Util where
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
import Monomer.Core
import Monomer.Event.Core
import Monomer.Event.Keyboard
import Monomer.Event.Types
isButtonPressed :: InputStatus -> Button -> Bool
isButtonPressed inputStatus button = status == PressedBtn where
currentStatus = M.lookup button (_ipsButtons inputStatus)
status = fromMaybe ReleasedBtn currentStatus
getKeyStatus :: InputStatus -> KeyCode -> KeyStatus
getKeyStatus inputStatus code = status where
keys = _ipsKeys inputStatus
status = fromMaybe KeyReleased (M.lookup code keys)
isShortCutControl :: WidgetEnv s e -> KeyMod -> Bool
isShortCutControl wenv mod = isControl || isCommand where
isControl = not (isMacOS wenv) && _kmLeftCtrl mod
isCommand = isMacOS wenv && _kmLeftGUI mod
isClipboardCopy :: WidgetEnv s e -> SystemEvent -> Bool
isClipboardCopy wenv event = checkKeyboard event testFn where
testFn mod code motion = isShortCutControl wenv mod && isKeyC code
isClipboardPaste :: WidgetEnv s e -> SystemEvent -> Bool
isClipboardPaste wenv event = checkKeyboard event testFn where
testFn mod code motion = isShortCutControl wenv mod && isKeyV code

3
src/Monomer/Widgets/Composite.hs
View File

@ -506,3 +506,6 @@ getUpdateModelReqs :: (Traversable t) => t (WidgetRequest s) -> Seq (s -> s)
getUpdateModelReqs reqs = foldl' foldHelper Seq.empty reqs where
foldHelper acc (UpdateModel fn) = acc |> fn
foldHelper acc _ = acc
firstChildPath :: WidgetInstance s e -> Path
firstChildPath inst = _wiPath inst |> 0

8
src/Monomer/Widgets/Container.hs
View File

@ -562,3 +562,11 @@ cascadeCtx parent child idx = newChild where
_wiVisible = _wiVisible child && parentVisible,
_wiEnabled = _wiEnabled child && parentEnabled
}
isIgnoreChildrenEvents :: WidgetRequest s -> Bool
isIgnoreChildrenEvents IgnoreChildrenEvents = True
isIgnoreChildrenEvents _ = False
isIgnoreParentEvents :: WidgetRequest s -> Bool
isIgnoreParentEvents IgnoreParentEvents = True
isIgnoreParentEvents _ = False

6
src/Monomer/Widgets/Dropdown.hs
View File

@ -378,3 +378,9 @@ makeListView wenv value items makeRow config path = listViewInst where
]
lvStyle = collectTheme wenv L.dropdownListStyle
listViewInst = listViewD_ value items makeRow lvConfig & L.style .~ lvStyle
createMoveFocusReq :: WidgetEnv s e -> WidgetRequest s
createMoveFocusReq wenv = MoveFocus direction where
direction
| wenv ^. L.inputStatus . L.keyMod . L.leftShift = FocusBwd
| otherwise = FocusFwd

2
src/Monomer/Widgets/Util.hs
View File

@ -1,6 +1,5 @@
module Monomer.Widgets.Util (
module Monomer.Widgets.Util.Focus,
module Monomer.Widgets.Util.Misc,
module Monomer.Widgets.Util.SizeReq,
module Monomer.Widgets.Util.Style,
module Monomer.Widgets.Util.Text,
@ -9,7 +8,6 @@ module Monomer.Widgets.Util (
) where
import Monomer.Widgets.Util.Focus
import Monomer.Widgets.Util.Misc
import Monomer.Widgets.Util.SizeReq
import Monomer.Widgets.Util.Style
import Monomer.Widgets.Util.Text

14
src/Monomer/Widgets/Util/Focus.hs
View File

@ -1,4 +1,13 @@
module Monomer.Widgets.Util.Focus where
module Monomer.Widgets.Util.Focus (
parentPath,
nextTargetStep,
isFocusCandidate,
isTargetReached,
isTargetValid,
isWidgetParentOfPath,
isWidgetBeforePath,
isWidgetAfterPath
) where
import Data.Sequence (Seq, (|>))
@ -10,9 +19,6 @@ parentPath :: WidgetInstance s e -> Path
parentPath inst = Seq.take (Seq.length path - 1) path where
path = _wiPath inst
firstChildPath :: WidgetInstance s e -> Path
firstChildPath inst = _wiPath inst |> 0
nextTargetStep :: Path -> WidgetInstance s e -> Maybe PathStep
nextTargetStep target inst = nextStep where
currentPath = _wiPath inst

56
src/Monomer/Widgets/Util/Misc.hs
View File

@ -1,56 +0,0 @@
module Monomer.Widgets.Util.Misc where
import Control.Lens ((^.))
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
import Monomer.Core
import Monomer.Event
import qualified Monomer.Lens as L
maxNumericValue :: (RealFloat a) => a
maxNumericValue = x where
n = floatDigits x
b = floatRadix x
(_, u) = floatRange x
x = encodeFloat (b^n - 1) (u - n)
pointInViewport :: Point -> WidgetInstance s e -> Bool
pointInViewport p inst = pointInRect p (_wiViewport inst)
getKeyStatus :: InputStatus -> KeyCode -> KeyStatus
getKeyStatus inputStatus code = status where
keys = _ipsKeys inputStatus
status = fromMaybe KeyReleased (M.lookup code keys)
isShortCutControl :: WidgetEnv s e -> KeyMod -> Bool
isShortCutControl wenv mod = isControl || isCommand where
isControl = not (isMacOS wenv) && _kmLeftCtrl mod
isCommand = isMacOS wenv && _kmLeftGUI mod
isClipboardCopy :: WidgetEnv s e -> SystemEvent -> Bool
isClipboardCopy wenv event = checkKeyboard event testFn where
testFn mod code motion = isShortCutControl wenv mod && isKeyC code
isClipboardPaste :: WidgetEnv s e -> SystemEvent -> Bool
isClipboardPaste wenv event = checkKeyboard event testFn where
testFn mod code motion = isShortCutControl wenv mod && isKeyV code
isIgnoreChildrenEvents :: WidgetRequest s -> Bool
isIgnoreChildrenEvents IgnoreChildrenEvents = True
isIgnoreChildrenEvents _ = False
isIgnoreParentEvents :: WidgetRequest s -> Bool
isIgnoreParentEvents IgnoreParentEvents = True
isIgnoreParentEvents _ = False
isMacOS :: WidgetEnv s e -> Bool
isMacOS wenv = _weOS wenv == "Mac OS X"
numberInBounds :: (Ord a, Num a) => Maybe a -> Maybe a -> a -> Bool
numberInBounds Nothing Nothing _ = True
numberInBounds (Just minVal) Nothing val = val >= minVal
numberInBounds Nothing (Just maxVal) val = val <= maxVal
numberInBounds (Just minVal) (Just maxVal) val = val >= minVal && val <= maxVal

1
src/Monomer/Widgets/Util/Style.hs
View File

@ -18,7 +18,6 @@ import qualified Data.Sequence as Seq
import Monomer.Core
import Monomer.Event
import Monomer.Graphics
import Monomer.Widgets.Util.Misc
import Monomer.Widgets.Util.Widget
import qualified Monomer.Lens as L

1
src/Monomer/Widgets/Util/Text.hs
View File

@ -26,7 +26,6 @@ import qualified Data.Text as T
import Monomer.Core
import Monomer.Graphics
import Monomer.Widgets.Util.Misc
import Monomer.Widgets.Util.Style
type GlyphGroup = Seq GlyphPos

30
src/Monomer/Widgets/Util/Widget.hs
View File

@ -1,4 +1,19 @@
module Monomer.Widgets.Util.Widget where
module Monomer.Widgets.Util.Widget (
pointInViewport,
defaultWidgetInstance,
isWidgetVisible,
isFocused,
isHovered,
widgetDataGet,
widgetDataSet,
resultWidget,
resultEvents,
resultReqs,
resultReqsEvents,
makeState,
useState,
instanceMatches
) where
import Control.Lens ((&), (^#), (#~), (^.))
import Data.Default
@ -13,6 +28,9 @@ import Monomer.Graphics.Types
import qualified Monomer.Lens as L
pointInViewport :: Point -> WidgetInstance s e -> Bool
pointInViewport p inst = pointInRect p (_wiViewport inst)
defaultWidgetInstance :: WidgetType -> Widget s e -> WidgetInstance s e
defaultWidgetInstance widgetType widget = WidgetInstance {
_wiWidgetType = widgetType,
@ -36,11 +54,6 @@ isWidgetVisible inst vp = _wiVisible inst && rectsOverlap vp (_wiViewport inst)
isFocused :: WidgetEnv s e -> WidgetInstance s e -> Bool
isFocused wenv inst = _weFocusedPath wenv == _wiPath inst
isTopLevel :: WidgetEnv s e -> WidgetInstance s e -> Bool
isTopLevel wenv inst = maybe True isPrefix (wenv ^. L.overlayPath) where
path = _wiPath inst
isPrefix parent = Seq.take (Seq.length parent) path == parent
isHovered :: WidgetEnv s e -> WidgetInstance s e -> Bool
isHovered wenv inst = validPos && isTopLevel wenv inst where
viewport = inst ^. L.viewport
@ -83,3 +96,8 @@ instanceMatches :: WidgetInstance s e -> WidgetInstance s e -> Bool
instanceMatches newInstance oldInstance = typeMatches && keyMatches where
typeMatches = _wiWidgetType oldInstance == _wiWidgetType newInstance
keyMatches = _wiKey oldInstance == _wiKey newInstance
isTopLevel :: WidgetEnv s e -> WidgetInstance s e -> Bool
isTopLevel wenv inst = maybe True isPrefix (wenv ^. L.overlayPath) where
path = _wiPath inst
isPrefix parent = Seq.take (Seq.length parent) path == parent