-- | Shared helpers for integration tests: input gestures, spans, scroll checks.
module NanoUI.Testing.Harness
  ( clickPair
  , rightClickPair
  , pressAt
  , releaseAt
  , keyInp
  , tabInp
  , withInputOff
  , withDelta
  , centerOf
  , warmup
  , warmup2
  , warmupDraw
  , held
  , runClick
  , assertSpansHas
  , spanYOf
  , spanXOf
  , assertScrollGutterPad
  , assertWheelTitlePinned
  , findGrabHover
  , dragWindowEdge
  , vertUv
  , checkLabelAlignEndInk
  , checkIdleFullDamage
  , windowTitleGrab
  , runDragFrom
  , DemoSpan
  , spanCenter
  , hasText
  , spanLabel
  , findExact
  , findHeader
  , findRightmost
  , requireSpan
  , expectText
  , clickPos
  , clickTab
  , dragPos
  , drawQuads
  ) where

import Control.Monad (forM, unless, void, when)
import Data.IORef (IORef, readIORef, writeIORef)
import Data.Text qualified as T
import Data.Word (Word32, Word8)
import Foreign.C.Types (CSize (..))
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Ptr (Ptr, plusPtr)
import Foreign.Storable (peekByteOff)
import GHC.Stack (HasCallStack)
import NanoUI
import NanoUI.Font (alignedTextPen, textInkEnd)
import NanoUI.Testing
import NanoUI.Testing.Assert (assert, assertEq, assertLt, bump, withInput)

type DemoSpan = (Rect, T.Text, Color, Color, Rect)

foreign import ccall unsafe "string.h memcpy" c_memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO ()

-- | Decode the quads a frame actually rasterised: one @(rect, color)@ per
-- six-index quad, in draw order. Span and arena queries cannot see chrome
-- (scroller wells, scrollbar lanes); this can. Every rasterised op in the
-- draw arena is emitted as 4 vertices / 6 indices; a command that breaks
-- that packing fails loudly here instead of decoding garbage.
drawQuads :: DrawData -> IO [(Rect, Color)]
drawQuads :: DrawData -> IO [(Rect, Color)]
drawQuads DrawData
dd =
  ([[(Rect, Color)]] -> [(Rect, Color)])
-> IO [[(Rect, Color)]] -> IO [(Rect, Color)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(Rect, Color)]] -> [(Rect, Color)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[(Rect, Color)]] -> IO [(Rect, Color)])
-> IO [[(Rect, Color)]] -> IO [(Rect, Color)]
forall a b. (a -> b) -> a -> b
$
    [DrawCmd]
-> (DrawCmd -> IO [(Rect, Color)]) -> IO [[(Rect, Color)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (DrawData -> [DrawCmd]
drawCmdElems DrawData
dd) ((DrawCmd -> IO [(Rect, Color)]) -> IO [[(Rect, Color)]])
-> (DrawCmd -> IO [(Rect, Color)]) -> IO [[(Rect, Color)]]
forall a b. (a -> b) -> a -> b
$ \DrawCmd
c -> do
      let ioff :: Int
ioff = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DrawCmd -> Word32
cmdIndexOffset DrawCmd
c)
          icnt :: Int
icnt = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DrawCmd -> Word32
cmdIndexCount DrawCmd
c)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
icnt Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
6 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall a. HasCallStack => String -> a
error (String
"drawQuads: draw command packs " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
icnt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" indices; not quad-packed")
      [IO (Rect, Color)] -> IO [(Rect, Color)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
        [ Int -> IO (Rect, Color)
decodeQuad (Int
ioff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
q)
        | Int
q <- [Int
0, Int
6 .. Int
icnt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
        ]
  where
    verts :: ForeignPtr Word8
verts = DrawData -> ForeignPtr Word8
drawVertices DrawData
dd
    idxs :: ForeignPtr Word8
idxs = DrawData -> ForeignPtr Word8
drawIndices DrawData
dd
    peekWord32 :: Ptr Word8 -> IO Word32
    peekWord32 :: Ptr Word8 -> IO Word32
peekWord32 Ptr Word8
off = Int -> (Ptr Word8 -> IO Word32) -> IO Word32
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
4 ((Ptr Word8 -> IO Word32) -> IO Word32)
-> (Ptr Word8 -> IO Word32) -> IO Word32
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
tmp -> do
      Ptr Word8 -> Ptr Word8 -> CSize -> IO ()
c_memcpy Ptr Word8
tmp Ptr Word8
off CSize
4
      Ptr Word8 -> Int -> IO Word32
forall b. Ptr b -> Int -> IO Word32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
tmp Int
0
    peekVertex :: Ptr Word8 -> Int -> IO (Float, Float, Float, Float, Float, Float)
    peekVertex :: Ptr Word8 -> Int -> IO (Float, Float, Float, Float, Float, Float)
peekVertex Ptr Word8
vp Int
vi =
      Int
-> (Ptr Word8 -> IO (Float, Float, Float, Float, Float, Float))
-> IO (Float, Float, Float, Float, Float, Float)
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
vertexSize ((Ptr Word8 -> IO (Float, Float, Float, Float, Float, Float))
 -> IO (Float, Float, Float, Float, Float, Float))
-> (Ptr Word8 -> IO (Float, Float, Float, Float, Float, Float))
-> IO (Float, Float, Float, Float, Float, Float)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
tmp -> do
        Ptr Word8 -> Ptr Word8 -> CSize -> IO ()
c_memcpy Ptr Word8
tmp (Ptr Word8
vp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
vi Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
vertexSize)) (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
vertexSize)
        x <- Ptr Word8 -> Int -> IO Float
forall b. Ptr b -> Int -> IO Float
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
tmp Int
0
        y <- peekByteOff tmp 4
        r <- peekByteOff tmp 8
        g <- peekByteOff tmp 12
        b <- peekByteOff tmp 16
        a <- peekByteOff tmp 20
        pure (x, y, r, g, b, a)
    decodeQuad :: Int -> IO (Rect, Color)
decodeQuad Int
iStart =
      ForeignPtr Word8
-> (Ptr Word8 -> IO (Rect, Color)) -> IO (Rect, Color)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
verts ((Ptr Word8 -> IO (Rect, Color)) -> IO (Rect, Color))
-> (Ptr Word8 -> IO (Rect, Color)) -> IO (Rect, Color)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
vp ->
        ForeignPtr Word8
-> (Ptr Word8 -> IO (Rect, Color)) -> IO (Rect, Color)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
idxs ((Ptr Word8 -> IO (Rect, Color)) -> IO (Rect, Color))
-> (Ptr Word8 -> IO (Rect, Color)) -> IO (Rect, Color)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ip -> do
          vis <-
            [Int]
-> (Int -> IO (Float, Float, Float, Float, Float, Float))
-> IO [(Float, Float, Float, Float, Float, Float)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
iStart .. Int
iStart Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3] ((Int -> IO (Float, Float, Float, Float, Float, Float))
 -> IO [(Float, Float, Float, Float, Float, Float)])
-> (Int -> IO (Float, Float, Float, Float, Float, Float))
-> IO [(Float, Float, Float, Float, Float, Float)]
forall a b. (a -> b) -> a -> b
$ \Int
ii -> do
              vi <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> IO Word32 -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> IO Word32
peekWord32 (Ptr Word8
ip Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
ii Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
indexSize))
              peekVertex vp vi
          case vis of
            [] -> (Rect, Color) -> IO (Rect, Color)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> Float -> Rect
Rect Float
0 Float
0 Float
0 Float
0, Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
0 Word8
0 Word8
0)
            (Float
x0, Float
y0, Float
r0, Float
g0, Float
b0, Float
a0) : [(Float, Float, Float, Float, Float, Float)]
rest -> do
              let xs :: [Float]
xs = Float
x0 Float -> [Float] -> [Float]
forall a. a -> [a] -> [a]
: ((Float, Float, Float, Float, Float, Float) -> Float)
-> [(Float, Float, Float, Float, Float, Float)] -> [Float]
forall a b. (a -> b) -> [a] -> [b]
map (\(Float
x, Float
_, Float
_, Float
_, Float
_, Float
_) -> Float
x) [(Float, Float, Float, Float, Float, Float)]
rest
                  ys :: [Float]
ys = Float
y0 Float -> [Float] -> [Float]
forall a. a -> [a] -> [a]
: ((Float, Float, Float, Float, Float, Float) -> Float)
-> [(Float, Float, Float, Float, Float, Float)] -> [Float]
forall a b. (a -> b) -> [a] -> [b]
map (\(Float
_, Float
y, Float
_, Float
_, Float
_, Float
_) -> Float
y) [(Float, Float, Float, Float, Float, Float)]
rest
                  toW8 :: a -> a
toW8 a
f = a -> a -> a
forall a. Ord a => a -> a -> a
max a
0 (a -> a -> a
forall a. Ord a => a -> a -> a
min a
255 (a -> a
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a
f a -> a -> a
forall a. Num a => a -> a -> a
* a
255)))
              (Rect, Color) -> IO (Rect, Color)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( Float -> Float -> Float -> Float -> Rect
Rect ([Float] -> Float
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Float]
xs) ([Float] -> Float
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Float]
ys) ([Float] -> Float
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Float]
xs Float -> Float -> Float
forall a. Num a => a -> a -> a
- [Float] -> Float
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Float]
xs) ([Float] -> Float
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Float]
ys Float -> Float -> Float
forall a. Num a => a -> a -> a
- [Float] -> Float
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Float]
ys)
                , Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA (Float -> Word8
forall {a} {a}. (RealFrac a, Integral a) => a -> a
toW8 Float
r0) (Float -> Word8
forall {a} {a}. (RealFrac a, Integral a) => a -> a
toW8 Float
g0) (Float -> Word8
forall {a} {a}. (RealFrac a, Integral a) => a -> a
toW8 Float
b0) (Float -> Word8
forall {a} {a}. (RealFrac a, Integral a) => a -> a
toW8 Float
a0)
                )

spanCenter :: Rect -> V2
spanCenter :: Rect -> V2
spanCenter (Rect Float
x Float
y Float
w Float
h) = Float -> Float -> V2
V2 (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)

hasText :: T.Text -> [(Rect, T.Text, a, b, c)] -> Bool
hasText :: forall a b c. Text -> [(Rect, Text, a, b, c)] -> Bool
hasText Text
needle = ((Rect, Text, a, b, c) -> Bool) -> [(Rect, Text, a, b, c)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Rect
_, Text
txt, a
_, b
_, c
_) -> Text
needle Text -> Text -> Bool
`T.isInfixOf` Text
txt)

-- Blank-glyph markers some span labels carry in front of their text (blanked
-- sort arrows, flags, sort-reserve padding).
dropSpanMarkers :: T.Text -> T.Text
dropSpanMarkers :: Text -> Text
dropSpanMarkers = (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\x01', Char
'\x02', Char
'\x05'])

spanLabel :: T.Text -> T.Text
spanLabel :: Text -> Text
spanLabel Text
txt = Text -> Text
dropSpanMarkers (Text -> Text
T.strip Text
txt)

findExact :: T.Text -> [DemoSpan] -> Maybe V2
findExact :: Text -> [DemoSpan] -> Maybe V2
findExact Text
needle [DemoSpan]
spans =
  [(Float, V2)] -> Maybe V2
pickRight
    [ (Float
x, Rect -> V2
spanCenter Rect
r)
    | (r :: Rect
r@(Rect Float
x Float
_ Float
w Float
h), Text
txt, Color
_, Color
_, Rect
_) <- [DemoSpan]
spans
    , Float
w Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
1 Bool -> Bool -> Bool
&& Float
h Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
1
    , Text -> Text
spanLabel Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
needle
    ]

findHeader :: T.Text -> [DemoSpan] -> Maybe V2
findHeader :: Text -> [DemoSpan] -> Maybe V2
findHeader Text
needle [DemoSpan]
spans =
  -- Header spans keep their sort-reserve padding ("Name   " with the arrow
  -- glyph blanked when unsorted), while every other "Name" label is trimmed.
  -- Match the raw, untrimmed text so the header wins over right-aligned kv
  -- values that happen to repeat the column name.
  let marked :: [(Float, V2)]
marked =
        [ (Float
x, Rect -> V2
spanCenter Rect
r)
        | (r :: Rect
r@(Rect Float
x Float
_ Float
w Float
h), Text
txt, Color
_, Color
_, Rect
_) <- [DemoSpan]
spans
        , Float
w Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
1 Bool -> Bool -> Bool
&& Float
h Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
1
        , Text -> Text -> Bool
T.isPrefixOf (Text
needle Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ") (Text -> Text
dropSpanMarkers Text
txt)
        ]
      exact :: [(Float, V2)]
exact =
        [ (Float
x, Rect -> V2
spanCenter Rect
r)
        | (r :: Rect
r@(Rect Float
x Float
_ Float
w Float
h), Text
txt, Color
_, Color
_, Rect
_) <- [DemoSpan]
spans
        , Float
w Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
1 Bool -> Bool -> Bool
&& Float
h Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
1
        , Text -> Text
spanLabel Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
needle
        ]
   in [(Float, V2)] -> Maybe V2
pickRight (if [(Float, V2)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Float, V2)]
marked then [(Float, V2)]
exact else [(Float, V2)]
marked)

findRightmost :: T.Text -> [DemoSpan] -> Maybe V2
findRightmost :: Text -> [DemoSpan] -> Maybe V2
findRightmost Text
needle [DemoSpan]
spans =
  [(Float, V2)] -> Maybe V2
pickRight [(Float
x, Rect -> V2
spanCenter Rect
r) | (r :: Rect
r@(Rect Float
x Float
_ Float
_ Float
_), Text
txt, Color
_, Color
_, Rect
_) <- [DemoSpan]
spans, Text
needle Text -> Text -> Bool
`T.isInfixOf` Text
txt]

pickRight :: [(Float, V2)] -> Maybe V2
pickRight :: [(Float, V2)] -> Maybe V2
pickRight [] = Maybe V2
forall a. Maybe a
Nothing
pickRight ((Float, V2)
p : [(Float, V2)]
ps) = V2 -> Maybe V2
forall a. a -> Maybe a
Just ((Float, V2) -> [(Float, V2)] -> V2
forall {a} {b}. Ord a => (a, b) -> [(a, b)] -> b
go (Float, V2)
p [(Float, V2)]
ps)
 where
  go :: (a, b) -> [(a, b)] -> b
go (a, b)
acc [] = (a, b) -> b
forall a b. (a, b) -> b
snd (a, b)
acc
  go acc :: (a, b)
acc@(a
ax, b
_) (q :: (a, b)
q@(a
qx, b
_) : [(a, b)]
qs) = (a, b) -> [(a, b)] -> b
go (if a
qx a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
ax then (a, b)
q else (a, b)
acc) [(a, b)]
qs

requireSpan :: String -> Maybe V2 -> IO V2
requireSpan :: String -> Maybe V2 -> IO V2
requireSpan String
msg = IO V2 -> (V2 -> IO V2) -> Maybe V2 -> IO V2
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO V2
forall a. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
msg) V2 -> IO V2
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Fail with @msg@ unless a span contains @needle@.
expectText :: String -> T.Text -> [(Rect, T.Text, a, b, c)] -> IO ()
expectText :: forall a b c. String -> Text -> [(Rect, Text, a, b, c)] -> IO ()
expectText String
msg Text
needle [(Rect, Text, a, b, c)]
spans = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> [(Rect, Text, a, b, c)] -> Bool
forall a b c. Text -> [(Rect, Text, a, b, c)] -> Bool
hasText Text
needle [(Rect, Text, a, b, c)]
spans) (String -> IO ()
forall a. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
msg)

-- | Press, hold and release at @pos@, then two idle frames.
clickPos :: (Input -> IO ()) -> Input -> V2 -> IO ()
clickPos :: (Input -> IO ()) -> Input -> V2 -> IO ()
clickPos Input -> IO ()
drawFrame Input
base V2
pos = (Input -> IO ()) -> Input -> V2 -> V2 -> IO ()
dragPos Input -> IO ()
drawFrame Input
base V2
pos V2
pos

clickTab :: (Context -> IO [DemoSpan]) -> (Input -> IO ()) -> Context -> Input -> T.Text -> IO ()
clickTab :: (Context -> IO [DemoSpan])
-> (Input -> IO ()) -> Context -> Input -> Text -> IO ()
clickTab Context -> IO [DemoSpan]
getSpans Input -> IO ()
drawFrame Context
ctx Input
base Text
name = do
  spans <- Context -> IO [DemoSpan]
getSpans Context
ctx
  pos <- requireSpan ("selftest: tab " <> T.unpack name) (findExact name spans)
  clickPos drawFrame base pos

-- | Press at @from@, hold at @to@ and release there, then two idle frames.
dragPos :: (Input -> IO ()) -> Input -> V2 -> V2 -> IO ()
dragPos :: (Input -> IO ()) -> Input -> V2 -> V2 -> IO ()
dragPos Input -> IO ()
drawFrame Input
base V2
from V2
to = do
  let press :: Input
press = Input -> V2 -> Input
pressAt Input
base V2
from
      hold :: Input
hold = Input
press {inputMousePressed = False, inputMousePos = to}
  (Input -> IO ()) -> [Input] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Input -> IO ()
drawFrame [Input
press, Input
hold, Input -> Input
releaseAt Input
hold, Input
base, Input
base]

clickPair :: Input -> V2 -> (Input, Input)
clickPair :: Input -> V2 -> (Input, Input)
clickPair Input
inp V2
pos =
  let
    press :: Input
press = Input -> V2 -> Input
pressAt Input
inp V2
pos
    release :: Input
release = Input -> Input
releaseAt Input
press
   in
    (Input
press, Input
release)

rightClickPair :: Input -> V2 -> (Input, Input)
rightClickPair :: Input -> V2 -> (Input, Input)
rightClickPair Input
inp V2
pos =
  let
    press :: Input
press =
      Input
inp
        { inputMousePos = pos
        , inputMouseRightDown = True
        , inputMouseRightPressed = True
        }
    release :: Input
release =
      Input
press
        { inputMouseRightDown = False
        , inputMouseRightPressed = False
        , inputMouseRightReleased = True
        }
   in
    (Input
press, Input
release)

pressAt :: Input -> V2 -> Input
pressAt :: Input -> V2 -> Input
pressAt Input
inp V2
pos =
  Input
inp
    { inputMousePos = pos
    , inputMouseDown = True
    , inputMousePressed = True
    , inputMouseReleased = False
    }

releaseAt :: Input -> Input
releaseAt :: Input -> Input
releaseAt Input
press =
  Input
press
    { inputMouseDown = False
    , inputMousePressed = False
    , inputMouseReleased = True
    }

-- | A single key-down frame.
keyInp :: Key -> Input -> Input
keyInp :: Key -> Input -> Input
keyInp Key
k Input
inp = Input
inp {inputKeys = inputKeysFromList [k]}

-- | Step the tab focus to the next focusable.
tabInp :: Input -> Input
tabInp :: Input -> Input
tabInp = Key -> Input -> Input
keyInp Key
KeyTab

withInputOff :: Float -> Float -> Input
withInputOff :: Float -> Float -> Input
withInputOff Float
w Float
h =
  let inp :: Input
inp = Float -> Float -> Input
withInput Float
w Float
h
   in Input
inp {inputMousePos = V2 (-10) (-10)}

withDelta :: Float -> Float -> Float -> Input
withDelta :: Float -> Float -> Float -> Input
withDelta Float
w Float
h Float
dt =
  let inp :: Input
inp = Float -> Float -> Input
withInput Float
w Float
h
   in Input
inp {inputDeltaTime = dt}

centerOf :: Response -> V2
centerOf :: Response -> V2
centerOf = Rect -> V2
spanCenter (Rect -> V2) -> (Response -> Rect) -> Response -> V2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Rect
forall r. HasResponse r => r -> Rect
respRect

warmup :: Context -> Input -> NanoUI a -> IO ()
warmup :: forall a. Context -> Input -> NanoUI a -> IO ()
warmup Context
ctx Input
inp NanoUI a
ui = IO (a, [FrameMsg], DrawData, Bool) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
forall a.
Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
runFrame Context
ctx Input
inp NanoUI a
ui)

warmup2 :: Context -> Input -> NanoUI a -> IO a
warmup2 :: forall a. Context -> Input -> NanoUI a -> IO a
warmup2 Context
ctx Input
inp NanoUI a
ui = do
  _ <- Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
forall a.
Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
runFrame Context
ctx Input
inp NanoUI a
ui
  (a, _, _, _) <- runFrame ctx inp ui
  pure a

warmupDraw :: Context -> Input -> NanoUI a -> IO (a, DrawData)
warmupDraw :: forall a. Context -> Input -> NanoUI a -> IO (a, DrawData)
warmupDraw Context
ctx Input
inp NanoUI a
ui = do
  _ <- Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
forall a.
Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
runFrame Context
ctx Input
inp NanoUI a
ui
  (a, _, draw, _) <- runFrame ctx inp ui
  pure (a, draw)

-- | Drive a controlled input the way an application does: pass the value held
-- in the test's 'IORef' and store the widget's result for the next frame. Not
-- a hook: a hook write makes the frame run the view again without input, and
-- the frame then returns that pass's result without its click or change flags.
held :: Ui :> es => IORef a -> (a -> Eff es (r, a)) -> Eff es (r, a)
held :: forall (es :: [Effect]) a r.
(Ui :> es) =>
IORef a -> (a -> Eff es (r, a)) -> Eff es (r, a)
held IORef a
ref a -> Eff es (r, a)
widget = do
  result <- a -> Eff es (r, a)
widget (a -> Eff es (r, a)) -> Eff es a -> Eff es (r, a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a -> Eff es a
forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO (IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
ref)
  uiIO (writeIORef ref (snd result))
  pure result

-- | Run a press frame and a release frame at @pos@ ('clickPair'), returning
-- the release frame's result.
runClick :: Context -> Input -> NanoUI a -> V2 -> IO a
runClick :: forall a. Context -> Input -> NanoUI a -> V2 -> IO a
runClick Context
ctx Input
inp0 NanoUI a
ui V2
pos = do
  let
    (Input
press, Input
release) = Input -> V2 -> (Input, Input)
clickPair Input
inp0 V2
pos
  _ <- Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
forall a.
Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
runFrame Context
ctx Input
press NanoUI a
ui
  (a, _, _, _) <- runFrame ctx release ui
  pure a

assertSpansHas :: HasCallStack => IORef Int -> T.Text -> [(Rect, T.Text, a, b, c)] -> IO ()
assertSpansHas :: forall a b c.
HasCallStack =>
IORef Int -> Text -> [(Rect, Text, a, b, c)] -> IO ()
assertSpansHas IORef Int
failed Text
needle [(Rect, Text, a, b, c)]
spans = HasCallStack => IORef Int -> Bool -> IO ()
IORef Int -> Bool -> IO ()
assert IORef Int
failed (Text -> [(Rect, Text, a, b, c)] -> Bool
forall a b c. Text -> [(Rect, Text, a, b, c)] -> Bool
hasText Text
needle [(Rect, Text, a, b, c)]
spans)

spanYOf :: T.Text -> [(Rect, T.Text, a, b, c)] -> [Float]
spanYOf :: forall a b c. Text -> [(Rect, Text, a, b, c)] -> [Float]
spanYOf Text
lbl [(Rect, Text, a, b, c)]
spans = [Float
y | (Rect Float
_ Float
y Float
_ Float
_, Text
txt, a
_, b
_, c
_) <- [(Rect, Text, a, b, c)]
spans, Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
lbl]

spanXOf :: T.Text -> [(Rect, T.Text, a, b, c)] -> [Float]
spanXOf :: forall a b c. Text -> [(Rect, Text, a, b, c)] -> [Float]
spanXOf Text
lbl [(Rect, Text, a, b, c)]
spans = [Float
x | (Rect Float
x Float
_ Float
_ Float
_, Text
txt, a
_, b
_, c
_) <- [(Rect, Text, a, b, c)]
spans, Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
lbl]

assertScrollGutterPad ::
  HasCallStack
  => IORef Int
  -> Context
  -> WidgetId
  -> Response
  -> Float
  -> Float
  -> IO ()
assertScrollGutterPad :: HasCallStack =>
IORef Int
-> Context -> WidgetId -> Response -> Float -> Float -> IO ()
assertScrollGutterPad IORef Int
failed Context
ctx WidgetId
sid Response
child Float
gutter Float
endPad = do
  mrect <- Context -> WidgetId -> IO (Maybe Rect)
getPrevRect Context
ctx WidgetId
sid
  case mrect of
    Maybe Rect
Nothing -> HasCallStack => IORef Int -> Bool -> IO ()
IORef Int -> Bool -> IO ()
assert IORef Int
failed Bool
False
    Just (Rect Float
sx Float
_ Float
sw Float
_) -> do
      let
        Rect Float
cx Float
_ Float
cw Float
_ = Response -> Rect
forall r. HasResponse r => r -> Rect
respRect Response
child
        contentRight :: Float
contentRight = Float
sx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
sw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
endPad Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
gutter
      HasCallStack => IORef Int -> Bool -> IO ()
IORef Int -> Bool -> IO ()
assert IORef Int
failed (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
cw Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
contentRight Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
0.5)
      HasCallStack => IORef Int -> Bool -> IO ()
IORef Int -> Bool -> IO ()
assert IORef Int
failed (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
cw Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
contentRight Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
0.01)

assertWheelTitlePinned ::
  HasCallStack
  => IORef Int
  -> Context
  -> Input
  -> NanoUI a
  -> T.Text
  -> T.Text
  -> V2
  -> Maybe Float
  -> IO ()
assertWheelTitlePinned :: forall a.
HasCallStack =>
IORef Int
-> Context
-> Input
-> NanoUI a
-> Text
-> Text
-> V2
-> Maybe Float
-> IO ()
assertWheelTitlePinned IORef Int
failed Context
ctx Input
inp0 NanoUI a
ui Text
title Text
line1 V2
wheelAt Maybe Float
mClipMax = do
  spans0 <- Context -> Input -> IO [DemoSpan]
collectOverlayTextSpans Context
ctx Input
inp0
  let
    titleYs0 = Text -> [DemoSpan] -> [Float]
forall a b c. Text -> [(Rect, Text, a, b, c)] -> [Float]
spanYOf Text
title [DemoSpan]
spans0
    line1Ys0 = Text -> [DemoSpan] -> [Float]
forall a b c. Text -> [(Rect, Text, a, b, c)] -> [Float]
spanYOf Text
line1 [DemoSpan]
spans0
  assert failed (not (null titleYs0))
  case line1Ys0 of
    [] -> HasCallStack => IORef Int -> Bool -> IO ()
IORef Int -> Bool -> IO ()
assert IORef Int
failed Bool
False
    Float
b0 : [Float]
_ -> do
      let
        wheel :: Input
wheel = Input
inp0 {inputMousePos = wheelAt, inputScroll = V2 0 1}
      _ <- Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
forall a.
Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
runFrame Context
ctx Input
wheel NanoUI a
ui
      spans1 <- collectOverlayTextSpans ctx wheel
      let
        titleYs1 = Text -> [DemoSpan] -> [Float]
forall a b c. Text -> [(Rect, Text, a, b, c)] -> [Float]
spanYOf Text
title [DemoSpan]
spans1
        line1Ys1 = Text -> [DemoSpan] -> [Float]
forall a b c. Text -> [(Rect, Text, a, b, c)] -> [Float]
spanYOf Text
line1 [DemoSpan]
spans1
      case (titleYs0, titleYs1) of
        (Float
y0 : [Float]
_, Float
y1 : [Float]
_) -> IORef Int -> Float -> Float -> IO ()
forall a.
(HasCallStack, Eq a, Show a) =>
IORef Int -> a -> a -> IO ()
assertEq IORef Int
failed Float
y1 Float
y0
        ([Float], [Float])
_ -> HasCallStack => IORef Int -> Bool -> IO ()
IORef Int -> Bool -> IO ()
assert IORef Int
failed Bool
False
      case line1Ys1 of
        [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Float
b1 : [Float]
_ -> IORef Int -> Float -> Float -> IO ()
forall a.
(HasCallStack, Ord a, Show a) =>
IORef Int -> a -> a -> IO ()
assertLt IORef Int
failed Float
b1 Float
b0
      case mClipMax of
        Maybe Float
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Float
maxY ->
          HasCallStack => IORef Int -> Bool -> IO ()
IORef Int -> Bool -> IO ()
assert IORef Int
failed (Bool -> Bool
not ((DemoSpan -> Bool) -> [DemoSpan] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Rect Float
_ Float
y Float
_ Float
h, Text
_, Color
_, Color
_, Rect
_) -> Float
y Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0 Bool -> Bool -> Bool
|| Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
maxY) [DemoSpan]
spans1))

findGrabHover ::
  Context -> NanoUI a -> Input -> Float -> [Float] -> IO (Maybe Input)
findGrabHover :: forall a.
Context
-> NanoUI a -> Input -> Float -> [Float] -> IO (Maybe Input)
findGrabHover Context
ctx NanoUI a
ui Input
inp0 Float
thumbX = [Float] -> IO (Maybe Input)
go
 where
  go :: [Float] -> IO (Maybe Input)
go [] = Maybe Input -> IO (Maybe Input)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Input
forall a. Maybe a
Nothing
  go (Float
y : [Float]
ys) = do
    let
      hover :: Input
hover = Input
inp0 {inputMousePos = V2 thumbX y}
    _ <- Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
forall a.
Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
runFrame Context
ctx Input
hover NanoUI a
ui
    kind <- uiCursorKind ctx hover
    if kind == UiCursorGrab then pure (Just hover) else go ys

dragWindowEdge ::
  Context
  -> Input
  -> NanoUI Response
  -> V2
  -> V2
  -> IO (Maybe Rect)
dragWindowEdge :: Context -> Input -> NanoUI Response -> V2 -> V2 -> IO (Maybe Rect)
dragWindowEdge Context
ctx Input
inp0 NanoUI Response
ui V2
grab V2
dest = do
  let
    press :: Input
press = Input -> V2 -> Input
pressAt Input
inp0 V2
grab
  _ <- Context
-> Input
-> NanoUI Response
-> IO (Response, [FrameMsg], DrawData, Bool)
forall a.
Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
runFrame Context
ctx Input
press NanoUI Response
ui
  let
    dragged =
      Input
press
        { inputMousePos = dest
        , inputMousePressed = False
        }
  _ <- runFrame ctx dragged ui
  let
    idle = Input
inp0 {inputMousePos = dest}
  _ <- runFrame ctx idle ui
  (win, _, _, _) <- runFrame ctx idle ui
  getPrevRect ctx (respId win)

vertUv :: DrawData -> Int -> IO (Float, Float)
vertUv :: DrawData -> Int -> IO (Float, Float)
vertUv DrawData
dd Int
i =
  ForeignPtr Word8
-> (Ptr Word8 -> IO (Float, Float)) -> IO (Float, Float)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (DrawData -> ForeignPtr Word8
drawVertices DrawData
dd) ((Ptr Word8 -> IO (Float, Float)) -> IO (Float, Float))
-> (Ptr Word8 -> IO (Float, Float)) -> IO (Float, Float)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> do
    let
      off :: Int
off = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
vertexSize
    u <- Ptr Word8 -> Int -> IO Float
forall b. Ptr b -> Int -> IO Float
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
p (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
24) :: IO Float
    v <- peekByteOff p (off + 28) :: IO Float
    pure (u, v)

checkIdleFullDamage ::
  HasCallStack => IORef Int -> Context -> Input -> Input -> NanoUI a -> IO ()
checkIdleFullDamage :: forall a.
HasCallStack =>
IORef Int -> Context -> Input -> Input -> NanoUI a -> IO ()
checkIdleFullDamage IORef Int
failed Context
ctx Input
inpAfter Input
inpIdle NanoUI a
ui = do
  need <- Context -> Input -> Input -> IO Bool
needsRedraw Context
ctx Input
inpAfter Input
inpIdle
  assert failed need
  _ <- runFrame ctx inpIdle ui
  dmg <- takeDamage ctx
  assert failed (dmg == DamageFull)

-- AlignEnd pins last-glyph ink, so "10" / "1i" / "1." share one right edge.
-- Lives here rather than with its test case because the pen and ink helpers
-- are internal to the library.
checkLabelAlignEndInk :: IORef Int -> IO ()
checkLabelAlignEndInk :: IORef Int -> IO ()
checkLabelAlignEndInk IORef Int
failed = do
  let
    gq :: Float -> Float -> GlyphQuad
gq Float
xoff Float
gw =
      GlyphQuad
        { gqX :: Float
gqX = Float
xoff
        , gqY :: Float
gqY = Float
0
        , gqW :: Float
gqW = Float
gw
        , gqH :: Float
gqH = Float
10
        , gqU0 :: Float
gqU0 = Float
0
        , gqV0 :: Float
gqV0 = Float
0
        , gqU1 :: Float
gqU1 = Float
1
        , gqV1 :: Float
gqV1 = Float
1
        }
    fm :: FontMetrics
fm =
      (Float -> FontMetrics
monospaceMetrics Float
10)
        { fmAdvance = \Char
c -> case Char
c of
            Char
'i' -> Float
4
            Char
'.' -> Float
4
            Char
_ -> Float
10
        , fmGlyph = \Char
c -> case Char
c of
            Char
'i' -> GlyphQuad -> Maybe GlyphQuad
forall a. a -> Maybe a
Just (Float -> Float -> GlyphQuad
gq Float
0.5 Float
3)
            Char
'.' -> GlyphQuad -> Maybe GlyphQuad
forall a. a -> Maybe a
Just (Float -> Float -> GlyphQuad
gq Float
1 Float
1)
            Char
_ -> GlyphQuad -> Maybe GlyphQuad
forall a. a -> Maybe a
Just (Float -> Float -> GlyphQuad
gq Float
1 Float
8)
        }
    boxW :: Float
boxW = Float
100
    visualRight :: Text -> Float
visualRight Text
txt =
      let (Float
tx, Float
_) = AlignX
-> Float -> Float -> Float -> FontMetrics -> Text -> (Float, Float)
alignedTextPen AlignX
AlignEnd Float
0 Float
boxW Float
0 FontMetrics
fm Text
txt
       in Float
tx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ FontMetrics -> Text -> Float
textInkEnd FontMetrics
fm Text
txt
    r0 :: Float
r0 = Text -> Float
visualRight Text
"10"
    ri :: Float
ri = Text -> Float
visualRight Text
"1i"
    rd :: Float
rd = Text -> Float
visualRight Text
"1."
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float -> Float
forall a. Num a => a -> a
abs (Float
r0 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
boxW) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0.01) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
bump IORef Int
failed
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float -> Float
forall a. Num a => a -> a
abs (Float
ri Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
boxW) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0.01) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
bump IORef Int
failed
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float -> Float
forall a. Num a => a -> a
abs (Float
rd Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
boxW) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0.01) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
bump IORef Int
failed

windowTitleGrab :: Rect -> V2
windowTitleGrab :: Rect -> V2
windowTitleGrab (Rect Float
x0 Float
y0 Float
_ Float
_) = Float -> Float -> V2
V2 (Float
x0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
24) (Float
y0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Padding -> Float
padT Padding
windowPad Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
19.5)

runDragFrom :: Context -> Input -> NanoUI a -> V2 -> V2 -> IO ()
runDragFrom :: forall a. Context -> Input -> NanoUI a -> V2 -> V2 -> IO ()
runDragFrom Context
ctx Input
inp0 NanoUI a
ui V2
grab V2
dest = do
  let
    press :: Input
press = Input -> V2 -> Input
pressAt Input
inp0 V2
grab
  _ <- Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
forall a.
Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
runFrame Context
ctx Input
press NanoUI a
ui
  let
    moved = Input
press {inputMousePos = dest, inputMousePressed = False}
  void (runFrame ctx moved ui)