{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}

-- | The 'Ui' effect and the 'NanoUI' view type: running a view, widget id
-- scopes and keys, theme scopes, and damage requests from inside a view.
module NanoUI.Monad
  ( NanoUI
  , Ui
  , runNanoUI
  , runUi
  , uiIO
  , emit
  , withKey
  , keyed
  , keyedTag
  , scope
  , withIdFrame
  , nextId
  , burstNextIds
  , currentId
  , askContext
  , askInput
  , askDefaultLayout
  , withDefaultLayout
  , askHost
  , uiFontMetrics
  , uiTime
  , uiTheme
  , setUiTheme
  , styled
  , themed
  , disabledWhen
  , uiMousePos
  , windowSize
  , windowWidth
  , windowHeight
  , damageWidgetNow
  , damageKeyNow
  , damageRectNow
  , damageGroupNow
  , damageFullNow
  , FrameMsg (..)
  , decodeMessages
  , reduceMessages
  , reduceUpdates
  , whenM
  , unlessM
  , ifM
  )
where


import Control.Exception (bracket)
import Control.Monad (unless, when)
import Data.Bits (shiftL, (.&.), (.|.))
import Data.Hashable (Hashable, hash)
import Data.IORef (modifyIORef', readIORef, writeIORef)
import Data.Typeable (Typeable)
import Data.Word (Word64)
import Effectful
  ( Dispatch (Static)
  , DispatchOf
  , Eff
  , Effect
  , IOE
  , runEff
  , type (:>)
  )
import Effectful.Dispatch.Static
  ( SideEffects (WithSideEffects)
  , StaticRep
  , evalStaticRep
  , getStaticRep
  , localStaticRep
  , unEff
  , unsafeEff
  , unsafeEff_
  )
import GHC.Clock (getMonotonicTime)
import NanoUI.Context
  ( Context (..)
  , FrameMsg (..)
  , askHostIO
  , damageFull
  , damageKey
  , damagePeers
  , damageRect
  , damageWidget
  , decodeMessages
  , currentTheme
  , pushMessage
  , pushThemeScope
  , scopeRawTheme
  , setTheme
  , reduceMessages
  , reduceUpdates
  )
import NanoUI.Font (FontMetrics)
import NanoUI.Id
  ( IdContext (siblingId)
  , WidgetId
  , enterKeyed
  , enterScope
  , idContextWidgetId
  , scopeTag
  )
import NanoUI.Layout.Arena (getArenaScope, setArenaScope)
import NanoUI.Style (Layout, Theme, disabledTheme)
import NanoUI.Input (Input (..), inputMousePos, inputWindowSize, stripInteractionInput)
import NanoUI.Types (DamageBounds, Rect, Size (..), V2)

type NanoUI = Eff '[Ui, IOE]

data Ui :: Effect

type instance DispatchOf Ui = Static WithSideEffects

data instance StaticRep Ui = UiRep !Context !Input !Layout

{-# INLINE runUi #-}
runUi :: IOE :> es => Context -> Input -> Eff (Ui : es) a -> Eff es a
runUi :: forall (es :: [Effect]) a.
(IOE :> es) =>
Context -> Input -> Eff (Ui : es) a -> Eff es a
runUi Context
ctx Input
inp Eff (Ui : es) a
ui = do
  lay <- IO Layout -> Eff es Layout
forall a (es :: [Effect]). IO a -> Eff es a
unsafeEff_ (IORef Layout -> IO Layout
forall a. IORef a -> IO a
readIORef (Context -> IORef Layout
ctxDefaultLayout Context
ctx))
  evalStaticRep (UiRep ctx inp lay) ui

{-# INLINE runNanoUI #-}
runNanoUI :: Context -> Input -> NanoUI a -> IO a
runNanoUI :: forall a. Context -> Input -> NanoUI a -> IO a
runNanoUI Context
ctx Input
inp = Eff '[IOE] a -> IO a
forall a. HasCallStack => Eff '[IOE] a -> IO a
runEff (Eff '[IOE] a -> IO a)
-> (NanoUI a -> Eff '[IOE] a) -> NanoUI a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Input -> NanoUI a -> Eff '[IOE] a
forall (es :: [Effect]) a.
(IOE :> es) =>
Context -> Input -> Eff (Ui : es) a -> Eff es a
runUi Context
ctx Input
inp

{-# INLINE uiIO #-}
uiIO :: Ui :> es => IO a -> Eff es a
uiIO :: forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO IO a
m = do
  UiRep {} <- Eff es (StaticRep Ui)
forall (e :: Effect) (sideEffects :: SideEffects) (es :: [Effect]).
(HasCallStack, DispatchOf e ~ 'Static sideEffects, e :> es) =>
Eff es (StaticRep e)
getStaticRep
  unsafeEff_ m

{-# INLINE emit #-}
emit :: (Typeable msg, Ui :> es) => msg -> Eff es ()
emit :: forall msg (es :: [Effect]).
(Typeable msg, Ui :> es) =>
msg -> Eff es ()
emit msg
msg = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  uiIO (pushMessage ctx (FrameMsg msg))

-- | The id 'nextId' would issue, without consuming it.
{-# INLINE currentId #-}
currentId :: Ui :> es => Eff es WidgetId
currentId :: forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
currentId = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  ic <- uiIO (readIORef (ctxIdContext ctx))
  pure (idContextWidgetId ic)

{-# INLINE nextId #-}
nextId :: Ui :> es => Eff es WidgetId
nextId :: forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  uiIO $ do
    ic <- readIORef (ctxIdContext ctx)
    writeIORef (ctxIdContext ctx) $! ic {siblingId = siblingId ic + 1}
    pure (idContextWidgetId ic)

-- | Issue many widget ids in one IO loop (avoids deep Eff bind chains).
{-# INLINE burstNextIds #-}
burstNextIds :: Ui :> es => Int -> Eff es ()
burstNextIds :: forall (es :: [Effect]). (Ui :> es) => Int -> Eff es ()
burstNextIds Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = () -> Eff es ()
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = do
      ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
      uiIO $ modifyIORef' (ctxIdContext ctx) $ \IdContext
ic ->
        let !sid :: Word64
sid = IdContext -> Word64
siblingId IdContext
ic Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
         in IdContext
ic {siblingId = sid}

-- Run @m@ in the child context from @enter@, then restore the advanced parent
-- (also on exceptions).
{-# INLINE withIdFrame #-}
withIdFrame ::
  Ui :> es => (IdContext -> (IdContext, IdContext)) -> Eff es a -> Eff es a
withIdFrame :: forall (es :: [Effect]) a.
(Ui :> es) =>
(IdContext -> (IdContext, IdContext)) -> Eff es a -> Eff es a
withIdFrame IdContext -> (IdContext, IdContext)
enter Eff es a
m = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  unsafeEff $ \Env es
es ->
    IO IdContext -> (IdContext -> IO ()) -> (IdContext -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
      (do
        old <- IORef IdContext -> IO IdContext
forall a. IORef a -> IO a
readIORef (Context -> IORef IdContext
ctxIdContext Context
ctx)
        let !(!p, !c) = enter old
        writeIORef (ctxIdContext ctx) c
        pure p)
      (\IdContext
parent' -> IORef IdContext -> IdContext -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef IdContext
ctxIdContext Context
ctx) IdContext
parent')
      (\IdContext
_ -> Eff es a -> Env es -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff Eff es a
m Env es
es)

{-# INLINE scope #-}
scope :: Ui :> es => Eff es a -> Eff es a
scope :: forall (es :: [Effect]) a. (Ui :> es) => Eff es a -> Eff es a
scope = (IdContext -> (IdContext, IdContext)) -> Eff es a -> Eff es a
forall (es :: [Effect]) a.
(Ui :> es) =>
(IdContext -> (IdContext, IdContext)) -> Eff es a -> Eff es a
withIdFrame (Word64 -> IdContext -> (IdContext, IdContext)
enterScope Word64
scopeTag)

{-# INLINE keyed #-}

-- | Stable child path from @tag@. Keys must be unique among siblings in the same scope.
keyed :: (Hashable k, Ui :> es) => k -> Eff es a -> Eff es a
keyed :: forall k (es :: [Effect]) a.
(Hashable k, Ui :> es) =>
k -> Eff es a -> Eff es a
keyed k
k = Word64 -> Eff es a -> Eff es a
forall (es :: [Effect]) a.
(Ui :> es) =>
Word64 -> Eff es a -> Eff es a
keyedTag (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (k -> Int
forall a. Hashable a => a -> Int
hash k
k))

{-# INLINE keyedTag #-}
keyedTag :: Ui :> es => Word64 -> Eff es a -> Eff es a
keyedTag :: forall (es :: [Effect]) a.
(Ui :> es) =>
Word64 -> Eff es a -> Eff es a
keyedTag Word64
tag = (IdContext -> (IdContext, IdContext)) -> Eff es a -> Eff es a
forall (es :: [Effect]) a.
(Ui :> es) =>
(IdContext -> (IdContext, IdContext)) -> Eff es a -> Eff es a
withIdFrame (Word64 -> IdContext -> (IdContext, IdContext)
enterKeyed Word64
tag)

{-# INLINE withKey #-}
withKey :: (Hashable k, Ui :> es) => k -> Eff es a -> Eff es a
withKey :: forall k (es :: [Effect]) a.
(Hashable k, Ui :> es) =>
k -> Eff es a -> Eff es a
withKey = k -> Eff es a -> Eff es a
forall k (es :: [Effect]) a.
(Hashable k, Ui :> es) =>
k -> Eff es a -> Eff es a
keyed

{-# INLINE askContext #-}
askContext :: Ui :> es => Eff es Context
askContext :: forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext = do
  UiRep ctx _ _ <- Eff es (StaticRep Ui)
forall (e :: Effect) (sideEffects :: SideEffects) (es :: [Effect]).
(HasCallStack, DispatchOf e ~ 'Static sideEffects, e :> es) =>
Eff es (StaticRep e)
getStaticRep
  pure ctx

{-# INLINE askDefaultLayout #-}
askDefaultLayout :: Ui :> es => Eff es Layout
askDefaultLayout :: forall (es :: [Effect]). (Ui :> es) => Eff es Layout
askDefaultLayout = do
  UiRep _ _ l <- Eff es (StaticRep Ui)
forall (e :: Effect) (sideEffects :: SideEffects) (es :: [Effect]).
(HasCallStack, DispatchOf e ~ 'Static sideEffects, e :> es) =>
Eff es (StaticRep e)
getStaticRep
  pure l

{-# INLINE withDefaultLayout #-}
withDefaultLayout :: Ui :> es => (Layout -> Layout) -> Eff es a -> Eff es a
withDefaultLayout :: forall (es :: [Effect]) a.
(Ui :> es) =>
(Layout -> Layout) -> Eff es a -> Eff es a
withDefaultLayout Layout -> Layout
f = (StaticRep Ui -> StaticRep Ui) -> Eff es a -> Eff es a
forall (e :: Effect) (sideEffects :: SideEffects) (es :: [Effect])
       a.
(HasCallStack, DispatchOf e ~ 'Static sideEffects, e :> es) =>
(StaticRep e -> StaticRep e) -> Eff es a -> Eff es a
localStaticRep (\(UiRep Context
ctx Input
inp Layout
l) -> Context -> Input -> Layout -> StaticRep Ui
UiRep Context
ctx Input
inp (Layout -> Layout
f Layout
l))

{-# INLINE uiFontMetrics #-}
uiFontMetrics :: Ui :> es => Eff es FontMetrics
uiFontMetrics :: forall (es :: [Effect]). (Ui :> es) => Eff es FontMetrics
uiFontMetrics = (Context -> FontMetrics) -> Eff es Context -> Eff es FontMetrics
forall a b. (a -> b) -> Eff es a -> Eff es b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Context -> FontMetrics
ctxFontMetrics Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext

{-# INLINE uiTime #-}
-- | Monotonic seconds since some fixed epoch (process boot), as a 'Double'.
-- Use it for time-based animation math inside the UI effect. It stays in
-- 'Double' on purpose: converting wall-clock seconds to 'Float' loses ~3 ms
-- of resolution at 8 h uptime (worse longer), which is coarser than a frame
-- and quantizes animation sweeps into visible steps.
uiTime :: Ui :> es => Eff es Double
uiTime :: forall (es :: [Effect]). (Ui :> es) => Eff es Double
uiTime = IO Double -> Eff es Double
forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO IO Double
getMonotonicTime

-- | The theme the view is drawn with where this is called: the context theme
-- as modified by the enclosing 'styled' and 'disabledWhen' scopes.
{-# INLINE uiTheme #-}
uiTheme :: Ui :> es => Eff es Theme
uiTheme :: forall (es :: [Effect]). (Ui :> es) => Eff es Theme
uiTheme = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  uiIO (currentTheme ctx)

-- | Draw a part of the view with a modified theme. Widgets declared inside
-- take their colours, borders and corner radii from it, and 'styled' scopes
-- nest, each modifying the theme of the scope around it:
--
-- > styled (buttonStyle (cornerRadius 8)) $ do
-- >   styled primary (button "Save")
-- >   button "Cancel"
--
-- The modifier runs once per scope per frame. The theme only affects how
-- widgets look, never their layout.
{-# INLINE styled #-}
styled :: Ui :> es => (Theme -> Theme) -> Eff es a -> Eff es a
styled :: forall (es :: [Effect]) a.
(Ui :> es) =>
(Theme -> Theme) -> Eff es a -> Eff es a
styled Theme -> Theme
f = (Context -> Int -> IO Int) -> Eff es a -> Eff es a
forall (es :: [Effect]) a.
(Ui :> es) =>
(Context -> Int -> IO Int) -> Eff es a -> Eff es a
withPaintScope ((Context -> Int -> IO Int) -> Eff es a -> Eff es a)
-> (Context -> Int -> IO Int) -> Eff es a -> Eff es a
forall a b. (a -> b) -> a -> b
$ \Context
ctx Int
outer -> do
  raw <- Theme -> Theme
f (Theme -> Theme) -> IO Theme -> IO Theme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Int -> IO Theme
scopeRawTheme Context
ctx Int
outer
  let !disabled = Int
outer Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
1
  ti <- pushThemeScope ctx (disabled /= 0) raw (if disabled /= 0 then disabledTheme raw else raw)
  pure ((ti `shiftL` 1) .|. disabled)

-- | Draw a part of the view with another theme, whatever the theme around it.
{-# INLINE themed #-}
themed :: Ui :> es => Theme -> Eff es a -> Eff es a
themed :: forall (es :: [Effect]) a.
(Ui :> es) =>
Theme -> Eff es a -> Eff es a
themed Theme
theme = (Theme -> Theme) -> Eff es a -> Eff es a
forall (es :: [Effect]) a.
(Ui :> es) =>
(Theme -> Theme) -> Eff es a -> Eff es a
styled (Theme -> Theme -> Theme
forall a b. a -> b -> a
const Theme
theme)

-- | Disable every widget declared inside when the condition holds. Disabled
-- widgets keep their place, state and layout, but take no pointer or
-- keyboard input, cannot be focused, and are drawn with 'disabledTheme'.
--
-- > disabledWhen (T.null name) $ whenM (button "Save") save
{-# INLINE disabledWhen #-}
disabledWhen :: Ui :> es => Bool -> Eff es a -> Eff es a
disabledWhen :: forall (es :: [Effect]) a.
(Ui :> es) =>
Bool -> Eff es a -> Eff es a
disabledWhen Bool
False Eff es a
m = Eff es a
m
disabledWhen Bool
True Eff es a
m =
  -- The view inside sees no presses, keys or wheel, so no widget's own input
  -- handling can fire; the frame's focus and click passes check the scope.
  (StaticRep Ui -> StaticRep Ui) -> Eff es a -> Eff es a
forall (e :: Effect) (sideEffects :: SideEffects) (es :: [Effect])
       a.
(HasCallStack, DispatchOf e ~ 'Static sideEffects, e :> es) =>
(StaticRep e -> StaticRep e) -> Eff es a -> Eff es a
localStaticRep
    (\(UiRep Context
ctx Input
inp Layout
l) -> Context -> Input -> Layout -> StaticRep Ui
UiRep Context
ctx (Input -> Input
stripInteractionInput Input
inp) {inputMouseDown = False, inputMouseRightDown = False} Layout
l)
    ((Context -> Int -> IO Int) -> Eff es a -> Eff es a
forall (es :: [Effect]) a.
(Ui :> es) =>
(Context -> Int -> IO Int) -> Eff es a -> Eff es a
withPaintScope Context -> Int -> IO Int
enter Eff es a
m)
  where
    enter :: Context -> Int -> IO Int
enter Context
ctx Int
outer
      | Int
outer Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
outer
      | Bool
otherwise = do
          raw <- Context -> Int -> IO Theme
scopeRawTheme Context
ctx Int
outer
          ti <- pushThemeScope ctx True raw (disabledTheme raw)
          pure ((ti `shiftL` 1) .|. 1)

-- Run @m@ with the arena scope @enter@ picks, then restore the scope around it
-- (also on exceptions).
{-# INLINE withPaintScope #-}
withPaintScope :: Ui :> es => (Context -> Int -> IO Int) -> Eff es a -> Eff es a
withPaintScope :: forall (es :: [Effect]) a.
(Ui :> es) =>
(Context -> Int -> IO Int) -> Eff es a -> Eff es a
withPaintScope Context -> Int -> IO Int
enter Eff es a
m = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  let na = Context -> NodeArena
ctxNodeArena Context
ctx
  unsafeEff $ \Env es
es ->
    IO Int -> (Int -> IO ()) -> (Int -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
      (do
        old <- NodeArena -> IO Int
getArenaScope NodeArena
na
        setArenaScope na =<< enter ctx old
        pure old)
      (NodeArena -> Int -> IO ()
setArenaScope NodeArena
na)
      (\Int
_ -> Eff es a -> Env es -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff Eff es a
m Env es
es)

{-# INLINE setUiTheme #-}
setUiTheme :: Ui :> es => Theme -> Eff es ()
setUiTheme :: forall (es :: [Effect]). (Ui :> es) => Theme -> Eff es ()
setUiTheme Theme
th = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  uiIO (setTheme ctx th)

{-# INLINE uiMousePos #-}
uiMousePos :: Ui :> es => Eff es V2
uiMousePos :: forall (es :: [Effect]). (Ui :> es) => Eff es V2
uiMousePos = (Input -> V2) -> Eff es Input -> Eff es V2
forall a b. (a -> b) -> Eff es a -> Eff es b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Input -> V2
inputMousePos Eff es Input
forall (es :: [Effect]). (Ui :> es) => Eff es Input
askInput

{-# INLINE askInput #-}
askInput :: Ui :> es => Eff es Input
askInput :: forall (es :: [Effect]). (Ui :> es) => Eff es Input
askInput = do
  UiRep _ inp _ <- Eff es (StaticRep Ui)
forall (e :: Effect) (sideEffects :: SideEffects) (es :: [Effect]).
(HasCallStack, DispatchOf e ~ 'Static sideEffects, e :> es) =>
Eff es (StaticRep e)
getStaticRep
  pure inp

{-# INLINE windowSize #-}
windowSize :: Ui :> es => Eff es Size
windowSize :: forall (es :: [Effect]). (Ui :> es) => Eff es Size
windowSize = (Input -> Size) -> Eff es Input -> Eff es Size
forall a b. (a -> b) -> Eff es a -> Eff es b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Input -> Size
inputWindowSize Eff es Input
forall (es :: [Effect]). (Ui :> es) => Eff es Input
askInput

{-# INLINE windowWidth #-}
windowWidth :: Ui :> es => Eff es Float
windowWidth :: forall (es :: [Effect]). (Ui :> es) => Eff es Float
windowWidth = (Input -> Float) -> Eff es Input -> Eff es Float
forall a b. (a -> b) -> Eff es a -> Eff es b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Size -> Float
sizeW (Size -> Float) -> (Input -> Size) -> Input -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Size
inputWindowSize) Eff es Input
forall (es :: [Effect]). (Ui :> es) => Eff es Input
askInput

{-# INLINE windowHeight #-}
windowHeight :: Ui :> es => Eff es Float
windowHeight :: forall (es :: [Effect]). (Ui :> es) => Eff es Float
windowHeight = (Input -> Float) -> Eff es Input -> Eff es Float
forall a b. (a -> b) -> Eff es a -> Eff es b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Size -> Float
sizeH (Size -> Float) -> (Input -> Size) -> Input -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Size
inputWindowSize) Eff es Input
forall (es :: [Effect]). (Ui :> es) => Eff es Input
askInput

{-# INLINE askHost #-}
askHost :: (Typeable a, Ui :> es) => Eff es (Maybe a)
askHost :: forall a (es :: [Effect]).
(Typeable a, Ui :> es) =>
Eff es (Maybe a)
askHost = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  uiIO (askHostIO ctx)

{-# INLINE damageWidgetNow #-}
damageWidgetNow :: (Ui :> es) => WidgetId -> DamageBounds -> Eff es ()
damageWidgetNow :: forall (es :: [Effect]).
(Ui :> es) =>
WidgetId -> DamageBounds -> Eff es ()
damageWidgetNow WidgetId
wid DamageBounds
bounds = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  uiIO (damageWidget ctx wid bounds)

{-# INLINE damageKeyNow #-}
damageKeyNow :: (Ui :> es) => Int -> DamageBounds -> Eff es ()
damageKeyNow :: forall (es :: [Effect]).
(Ui :> es) =>
Int -> DamageBounds -> Eff es ()
damageKeyNow Int
k DamageBounds
bounds = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  uiIO (damageKey ctx k bounds)

{-# INLINE damageRectNow #-}
damageRectNow :: (Ui :> es) => Rect -> Eff es ()
damageRectNow :: forall (es :: [Effect]). (Ui :> es) => Rect -> Eff es ()
damageRectNow Rect
r = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  uiIO (damageRect ctx r)

{-# INLINE damageGroupNow #-}
damageGroupNow :: (Ui :> es) => [WidgetId] -> DamageBounds -> Eff es ()
damageGroupNow :: forall (es :: [Effect]).
(Ui :> es) =>
[WidgetId] -> DamageBounds -> Eff es ()
damageGroupNow [WidgetId]
wids DamageBounds
bounds = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  uiIO (damagePeers ctx wids bounds)

{-# INLINE damageFullNow #-}
damageFullNow :: (Ui :> es) => Eff es ()
damageFullNow :: forall (es :: [Effect]). (Ui :> es) => Eff es ()
damageFullNow = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  uiIO (damageFull ctx)

-- | Monadic variant of 'when'. Runs the second action if the first returns 'True'.
--
-- Example:
--
-- @
-- whenM (button "Save") saveDocument
-- @
{-# INLINE whenM #-}
whenM :: Monad m => m Bool -> m () -> m ()
whenM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
mb m ()
ma = m Bool
mb m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b m ()
ma

-- | Monadic variant of 'unless'. Runs the second action if the first returns 'False'.
{-# INLINE unlessM #-}
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM m Bool
mb m ()
ma = m Bool
mb m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b m ()
ma

-- | Monadic conditional selection.
{-# INLINE ifM #-}
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
mb m a
t m a
f = m Bool
mb m Bool -> (Bool -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b then m a
t else m a
f