{-# LANGUAGE RecursiveDo          #-}
{-# LANGUAGE UndecidableInstances #-}

module Reflex.Vty.Test.Monad.Host (
  module Reflex.Test.Monad.Host
  , ReflexVtyTestT
  , queueVtyEvent
  , vtyInputTriggerRefs
  , userInputTriggerRefs
  , userOutputs
  , vtyOutputs
  , queueMouseEvent
  , queueMouseEventInRegion
  , queueMouseEventInRegionGated
  , queueMouseDrag
  , queueMouseDragInRegion
  , runReflexVtyTestT
  , ReflexVtyTestApp(..)
  , runReflexVtyTestApp
  -- Reflex.Vty.Widget.Test
) where

import           Relude                   hiding (getFirst)

import           Control.Monad.Ref
import qualified Data.Map                 as Map

import qualified Graphics.Vty             as V
import           Potato.Reflex.Vty.Widget
import           Reflex
import           Reflex.Host.Class
import           Reflex.Test.Monad.Host   (MonadReflexTest (..), ReflexTestT,
                                           ReflexTriggerRef,
                                           TestGuestConstraints, TestGuestT,
                                           runReflexTestT)
import           Reflex.Vty


-- for debug layout/widget stuff
import           Control.Monad.Fix
import           Data.Bimap               (Bimap)
import qualified Data.Bimap               as Bimap
import           Data.Semigroup



-- | reflex-vty variant of 'ReflexTestT' which packages an 'VtyEvent' into the input and 'Behavior t [V.Image]' into the output
-- 'uintref' and 'uout' allow user to add their own inputs and outputs
-- 'uintref' will often just be some singleton type (e.g. '()') as the app being tested still has access to the input 'Event t VtyEvent' through the 'VtyWidget' monad
type ReflexVtyTestT t uintref uout m = ReflexTestT t (uintref, ReflexTriggerRef t m VtyEvent) (uout, Behavior t [V.Image]) m

-- | queue a 'VtyEvent'
queueVtyEvent :: (MonadRef m) => VtyEvent -> ReflexVtyTestT t uintref uout m ()
queueVtyEvent :: forall (m :: * -> *) t uintref uout.
MonadRef m =>
VtyEvent -> ReflexVtyTestT t uintref uout m ()
queueVtyEvent VtyEvent
vtyev = do
  (uintref
_, Ref m (Maybe (EventTrigger t VtyEvent))
vtytref) <- forall t (m :: * -> *).
MonadReflexTest t m =>
m (InputTriggerRefs m)
inputTriggerRefs
  forall t (m :: * -> *) a.
MonadReflexTest t m =>
Ref (InnerMonad m) (Maybe (EventTrigger t a)) -> a -> m ()
queueEventTriggerRef Ref m (Maybe (EventTrigger t VtyEvent))
vtytref VtyEvent
vtyev

-- | obtain vty inputs
vtyInputTriggerRefs :: (MonadRef m) => ReflexVtyTestT t uintref uout m (ReflexTriggerRef t m VtyEvent)
vtyInputTriggerRefs :: forall (m :: * -> *) t uintref uout.
MonadRef m =>
ReflexVtyTestT t uintref uout m (ReflexTriggerRef t m VtyEvent)
vtyInputTriggerRefs = do
  (uintref
_, Ref m (Maybe (EventTrigger t VtyEvent))
vtytrefs) <- forall t (m :: * -> *).
MonadReflexTest t m =>
m (InputTriggerRefs m)
inputTriggerRefs
  forall (m :: * -> *) a. Monad m => a -> m a
return Ref m (Maybe (EventTrigger t VtyEvent))
vtytrefs

-- | obtain user defined inputs
userInputTriggerRefs :: (MonadRef m) => ReflexVtyTestT t uintref uout m uintref
userInputTriggerRefs :: forall (m :: * -> *) t uintref uout.
MonadRef m =>
ReflexVtyTestT t uintref uout m uintref
userInputTriggerRefs = do
  (uintref
usertrefs, Ref m (Maybe (EventTrigger t VtyEvent))
_) <- forall t (m :: * -> *).
MonadReflexTest t m =>
m (InputTriggerRefs m)
inputTriggerRefs
  forall (m :: * -> *) a. Monad m => a -> m a
return uintref
usertrefs

-- | obtain user defined outputs
userOutputs :: (MonadRef m) => ReflexVtyTestT t uintref uout m uout
userOutputs :: forall (m :: * -> *) t uintref uout.
MonadRef m =>
ReflexVtyTestT t uintref uout m uout
userOutputs = do
  (uout
useroutputs, Behavior t [Image]
_) <- forall t (m :: * -> *). MonadReflexTest t m => m (OutputEvents m)
outputs
  forall (m :: * -> *) a. Monad m => a -> m a
return uout
useroutputs

-- | obtain vty outputs
vtyOutputs :: (MonadRef m) => ReflexVtyTestT t uintref uout m (Behavior t [V.Image])
vtyOutputs :: forall (m :: * -> *) t uintref uout.
MonadRef m =>
ReflexVtyTestT t uintref uout m (Behavior t [Image])
vtyOutputs = do
  (uout
_, Behavior t [Image]
vtyoutputs) <- forall t (m :: * -> *). MonadReflexTest t m => m (OutputEvents m)
outputs
  forall (m :: * -> *) a. Monad m => a -> m a
return Behavior t [Image]
vtyoutputs

-- | queue mouse event
queueMouseEvent :: (MonadRef m)
  => Either MouseDown MouseUp -- ^ mouse coordinates are LOCAL to the input region
  -> ReflexVtyTestT t uintref uout m ()
queueMouseEvent :: forall (m :: * -> *) t uintref uout.
MonadRef m =>
Either MouseDown MouseUp -> ReflexVtyTestT t uintref uout m ()
queueMouseEvent Either MouseDown MouseUp
mouse = case Either MouseDown MouseUp
mouse of
  Left (MouseDown Button
b (Int, Int)
c [Modifier]
mods) -> forall (m :: * -> *) t uintref uout.
MonadRef m =>
VtyEvent -> ReflexVtyTestT t uintref uout m ()
queueVtyEvent forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Button -> [Modifier] -> VtyEvent
V.EvMouseDown (Int, Int)
c Button
b [Modifier]
mods
  Right (MouseUp Maybe Button
b (Int, Int)
c)       -> forall (m :: * -> *) t uintref uout.
MonadRef m =>
VtyEvent -> ReflexVtyTestT t uintref uout m ()
queueVtyEvent forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Maybe Button -> VtyEvent
V.EvMouseUp (Int, Int)
c Maybe Button
b


-- | queue mouse event in a 'DynRegion'
queueMouseEventInRegion :: (Reflex t, MonadSample t m, MonadRef m)
  => Dynamic t Region
  -> Either MouseDown MouseUp -- ^ mouse coordinates are LOCAL to the input region
  -> ReflexVtyTestT t uintref uout m ()
queueMouseEventInRegion :: forall t (m :: * -> *) uintref uout.
(Reflex t, MonadSample t m, MonadRef m) =>
Dynamic t Region
-> Either MouseDown MouseUp -> ReflexVtyTestT t uintref uout m ()
queueMouseEventInRegion Dynamic t Region
dr Either MouseDown MouseUp
mouse = do
  let
    absCoords :: Region -> (Int, Int) -> (Int, Int)
absCoords (Region Int
l Int
t Int
_ Int
_) (Int
x,Int
y) = (Int
xforall a. Num a => a -> a -> a
+Int
l, Int
yforall a. Num a => a -> a -> a
+Int
t)
  Region
region <- forall {k} (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current forall a b. (a -> b) -> a -> b
$ Dynamic t Region
dr
  case Either MouseDown MouseUp
mouse of
    Left (MouseDown Button
b (Int, Int)
c [Modifier]
mods) -> forall (m :: * -> *) t uintref uout.
MonadRef m =>
VtyEvent -> ReflexVtyTestT t uintref uout m ()
queueVtyEvent forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Button -> [Modifier] -> VtyEvent
V.EvMouseDown (Region -> (Int, Int) -> (Int, Int)
absCoords Region
region (Int, Int)
c) Button
b [Modifier]
mods
    Right (MouseUp Maybe Button
b (Int, Int)
c) -> forall (m :: * -> *) t uintref uout.
MonadRef m =>
VtyEvent -> ReflexVtyTestT t uintref uout m ()
queueVtyEvent forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Maybe Button -> VtyEvent
V.EvMouseUp (Region -> (Int, Int) -> (Int, Int)
absCoords Region
region (Int, Int)
c) Maybe Button
b

-- | queue mouse event in a 'DynRegion'
-- if (local) mouse coordinates are outside of the (absolute) region, returns False and does not queue any event
queueMouseEventInRegionGated :: (Reflex t, MonadSample t m, MonadRef m)
  => Dynamic t Region
  -> Either MouseDown MouseUp -- ^ mouse coordinates are LOCAL to the input region
  -> ReflexVtyTestT t uintref uout m Bool
queueMouseEventInRegionGated :: forall t (m :: * -> *) uintref uout.
(Reflex t, MonadSample t m, MonadRef m) =>
Dynamic t Region
-> Either MouseDown MouseUp -> ReflexVtyTestT t uintref uout m Bool
queueMouseEventInRegionGated Dynamic t Region
dr Either MouseDown MouseUp
mouse = do
  Region
region <- forall {k} (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current forall a b. (a -> b) -> a -> b
$ Dynamic t Region
dr
  let
    absCoords :: Region -> (Int, Int) -> (Int, Int)
absCoords (Region Int
l Int
t Int
_ Int
_) (Int
x,Int
y) = (Int
xforall a. Num a => a -> a -> a
+Int
l, Int
yforall a. Num a => a -> a -> a
+Int
t)
    coordinates :: (Int, Int)
coordinates = case Either MouseDown MouseUp
mouse of
      Left (MouseDown Button
_ (Int, Int)
c [Modifier]
_) -> (Int, Int)
c
      Right (MouseUp Maybe Button
_ (Int, Int)
c)    -> (Int, Int)
c
    withinRegion :: Region -> (Int, Int) -> Bool
withinRegion (Region Int
_ Int
_ Int
w Int
h) (Int
x,Int
y) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Int
x forall a. Ord a => a -> a -> Bool
< Int
0, Int
y forall a. Ord a => a -> a -> Bool
< Int
0, Int
x forall a. Ord a => a -> a -> Bool
>= Int
w, Int
y forall a. Ord a => a -> a -> Bool
>= Int
h ]
  if Region -> (Int, Int) -> Bool
withinRegion Region
region (Int, Int)
coordinates
    then do
      case Either MouseDown MouseUp
mouse of
        Left (MouseDown Button
b (Int, Int)
c [Modifier]
mods) -> forall (m :: * -> *) t uintref uout.
MonadRef m =>
VtyEvent -> ReflexVtyTestT t uintref uout m ()
queueVtyEvent forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Button -> [Modifier] -> VtyEvent
V.EvMouseDown (Region -> (Int, Int) -> (Int, Int)
absCoords Region
region (Int, Int)
c) Button
b [Modifier]
mods
        Right (MouseUp Maybe Button
b (Int, Int)
c) -> forall (m :: * -> *) t uintref uout.
MonadRef m =>
VtyEvent -> ReflexVtyTestT t uintref uout m ()
queueVtyEvent forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Maybe Button -> VtyEvent
V.EvMouseUp (Region -> (Int, Int) -> (Int, Int)
absCoords Region
region (Int, Int)
c) Maybe Button
b
      return Bool
True
    else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | queue and fire a series of mouse events representing a mouse drag
-- returns collected outputs
queueMouseDrag :: (Reflex t, MonadSample t m, MonadRef m)
  => V.Button -- ^ button to press
  -> [V.Modifier] -- ^ modifier held during drag
  -> NonEmpty (Int,Int) -- ^ list of drag positions
  -- TODO add something like DragState to this
  -> ((Int,Int) -> ReadPhase m a) -- ^ ReadPhase to run after each normal drag
  -> ReflexVtyTestT t uintref uout m (NonEmpty [a]) -- ^ collected outputs
queueMouseDrag :: forall t (m :: * -> *) a uintref uout.
(Reflex t, MonadSample t m, MonadRef m) =>
Button
-> [Modifier]
-> NonEmpty (Int, Int)
-> ((Int, Int) -> ReadPhase m a)
-> ReflexVtyTestT t uintref uout m (NonEmpty [a])
queueMouseDrag = forall t (m :: * -> *) a uintref uout.
(Reflex t, MonadSample t m, MonadRef m) =>
Dynamic t Region
-> Button
-> [Modifier]
-> NonEmpty (Int, Int)
-> ((Int, Int) -> ReadPhase m a)
-> ReflexVtyTestT t uintref uout m (NonEmpty [a])
queueMouseDragInRegion (forall {k} (t :: k) a. Reflex t => a -> Dynamic t a
constDyn forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int -> Region
Region Int
0 Int
0 Int
0 Int
0)
{-queueMouseDrag b mods ps rps = do
  let
    dragPs' = init ps
    -- if there is only 1 elt in ps, then simulate a single click
    dragPs = fromMaybe (pure (head ps)) $ viaNonEmpty id dragPs'
    endP = last ps
  initas <- forM dragPs $ \p -> do
    queueVtyEvent (uncurry V.EvMouseDown p b mods)
    fireQueuedEventsAndRead (rps p)
  queueVtyEvent (uncurry V.EvMouseUp endP (Just b))
  lastas <- fireQueuedEventsAndRead (rps endP)
  return $ initas <> (lastas :| [])
-}

-- | same as queueMouseDrag but coordinates are translated to a region
queueMouseDragInRegion :: (Reflex t, MonadSample t m, MonadRef m)
  => Dynamic t Region

  -> V.Button -- ^ button to press
  -> [V.Modifier] -- ^ modifier held during drag
  -> NonEmpty (Int,Int) -- ^ list of drag positions
  -- TODO add something like DragState to this
  -> ((Int,Int) -> ReadPhase m a) -- ^ ReadPhase to run after each normal drag
  -> ReflexVtyTestT t uintref uout m (NonEmpty [a]) -- ^ collected outputs
queueMouseDragInRegion :: forall t (m :: * -> *) a uintref uout.
(Reflex t, MonadSample t m, MonadRef m) =>
Dynamic t Region
-> Button
-> [Modifier]
-> NonEmpty (Int, Int)
-> ((Int, Int) -> ReadPhase m a)
-> ReflexVtyTestT t uintref uout m (NonEmpty [a])
queueMouseDragInRegion Dynamic t Region
region Button
b [Modifier]
mods NonEmpty (Int, Int)
ps (Int, Int) -> ReadPhase m a
rps = do
  let
    dragPs' :: [(Int, Int)]
dragPs' = forall (f :: * -> *) a. IsNonEmpty f a [a] "init" => f a -> [a]
init NonEmpty (Int, Int)
ps
    -- if there is only 1 elt in ps, then simulate a single click
    dragPs :: NonEmpty (Int, Int)
dragPs = forall a. a -> Maybe a -> a
fromMaybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head NonEmpty (Int, Int)
ps)) forall a b. (a -> b) -> a -> b
$ forall a b. (NonEmpty a -> b) -> [a] -> Maybe b
viaNonEmpty forall a. a -> a
id [(Int, Int)]
dragPs'
    endP :: (Int, Int)
endP = forall (f :: * -> *) a. IsNonEmpty f a a "last" => f a -> a
last NonEmpty (Int, Int)
ps
  NonEmpty [a]
initas <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty (Int, Int)
dragPs forall a b. (a -> b) -> a -> b
$ \(Int, Int)
p -> do
    forall t (m :: * -> *) uintref uout.
(Reflex t, MonadSample t m, MonadRef m) =>
Dynamic t Region
-> Either MouseDown MouseUp -> ReflexVtyTestT t uintref uout m ()
queueMouseEventInRegion Dynamic t Region
region forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (Button -> (Int, Int) -> [Modifier] -> MouseDown
MouseDown Button
b (Int, Int)
p [Modifier]
mods)
    forall t (m :: * -> *) a.
MonadReflexTest t m =>
ReadPhase (InnerMonad m) a -> m [a]
fireQueuedEventsAndRead ((Int, Int) -> ReadPhase m a
rps (Int, Int)
p)
  forall t (m :: * -> *) uintref uout.
(Reflex t, MonadSample t m, MonadRef m) =>
Dynamic t Region
-> Either MouseDown MouseUp -> ReflexVtyTestT t uintref uout m ()
queueMouseEventInRegion Dynamic t Region
region forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Maybe Button -> (Int, Int) -> MouseUp
MouseUp (forall a. a -> Maybe a
Just Button
b) (Int, Int)
endP)
  [a]
lastas <- forall t (m :: * -> *) a.
MonadReflexTest t m =>
ReadPhase (InnerMonad m) a -> m [a]
fireQueuedEventsAndRead ((Int, Int) -> ReadPhase m a
rps (Int, Int)
endP)
  return $ NonEmpty [a]
initas forall a. Semigroup a => a -> a -> a
<> ([a]
lastas forall a. a -> [a] -> NonEmpty a
:| [])



{-
deriving instance (MonadSubscribeEvent t m) => MonadSubscribeEvent t (Input t m)
deriving instance (MonadReflexHost t m) => MonadReflexHost t (Input t m)
deriving instance (MonadSubscribeEvent t m) => MonadSubscribeEvent t (ThemeReader t m)
deriving instance (MonadReflexHost t m) => MonadReflexHost t (ThemeReader t m)
deriving instance (MonadSubscribeEvent t m) => MonadSubscribeEvent t (FocusReader t m)
deriving instance (MonadReflexHost t m) => MonadReflexHost t (FocusReader t m)
deriving instance (MonadSubscribeEvent t m) => MonadSubscribeEvent t (DisplayRegion t m)
deriving instance (MonadReflexHost t m) => MonadReflexHost t (DisplayRegion t m)


instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ImageWriter t m) where
  subscribeEvent = lift . subscribeEvent
instance MonadReflexHost t m => MonadReflexHost t (ImageWriter t m) where
  type ReadPhase (ImageWriter t m) = ReadPhase m
  fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
  runHostFrame = lift . runHostFrame

instance MonadSubscribeEvent t m => MonadSubscribeEvent t (NodeIdT m) where
  subscribeEvent = lift . subscribeEvent
instance MonadReflexHost t m => MonadReflexHost t (NodeIdT m) where
  type ReadPhase (NodeIdT m) = ReadPhase m
  fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
  runHostFrame = lift . runHostFrame
-}

type InnerWidgetConstraints t widget = (
  MonadVtyApp t widget
  , HasImageWriter t widget
  , MonadNodeId widget
  , HasDisplayRegion t widget
  , HasFocusReader t widget
  , HasInput t widget
  , HasTheme t widget
  )

-- | run a 'ReflexVtyTestT'
-- analogous to runReflexTestT
runReflexVtyTestT :: forall uintref uinev uout t m a. (MonadVtyApp t (TestGuestT t m), TestGuestConstraints t m)
   -- ^ the reason for this constraint is that we need explicit access to both inner (m) and outer (TestGuestT m) monads
  => (Int, Int) -- ^ initial screen size
  -> (uinev, uintref) -- ^ make sure uintref match uinev, i.e. return values of newEventWithTriggerRef

  -- TODO extract widget constraints
  -> (forall widget. (InnerWidgetConstraints t widget) => uinev -> widget uout) -- ^ VtyWidget to test
  -> ReflexVtyTestT t uintref uout m a -- ^ test monad to run
  -> m ()
runReflexVtyTestT :: forall uintref uinev uout t (m :: * -> *) a.
(MonadVtyApp t (TestGuestT t m), TestGuestConstraints t m) =>
(Int, Int)
-> (uinev, uintref)
-> (forall (widget :: * -> *).
    InnerWidgetConstraints t widget =>
    uinev -> widget uout)
-> ReflexVtyTestT t uintref uout m a
-> m ()
runReflexVtyTestT (Int, Int)
r0 (uinev
uinput, uintref
uinputtrefs) forall (widget :: * -> *).
InnerWidgetConstraints t widget =>
uinev -> widget uout
app ReflexVtyTestT t uintref uout m a
rtm = do

  -- generate vty events trigger
  (Event t VtyEvent
vinev, IORef (Maybe (EventTrigger t VtyEvent))
vintref) <- forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
newEventWithTriggerRef

  Dynamic t (Int, Int)
size <- forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
holdDyn (Int, Int)
r0 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b.
Filterable f =>
f a -> (a -> Maybe b) -> f b
fforMaybe Event t VtyEvent
vinev forall a b. (a -> b) -> a -> b
$ \case
      V.EvResize Int
w Int
h -> forall a. a -> Maybe a
Just (Int
w, Int
h)
      VtyEvent
_ -> forall a. Maybe a
Nothing

  -- unwrap VtyWidget and pass to runReflexTestT
  forall intref inev out t (m :: * -> *) a.
TestGuestConstraints t m =>
(inev, intref)
-> (inev -> TestGuestT t m out)
-> ReflexTestT t intref out m a
-> m ()
runReflexTestT
    ((uinev
uinput, Event t VtyEvent
vinev), (uintref
uinputtrefs, IORef (Maybe (EventTrigger t VtyEvent))
vintref))
    -- TODO need ta add runVtyApp in here
    (\(uinev
uinput',Event t VtyEvent
_) -> forall {k} (t :: k) (m :: * -> *) a.
(Reflex t, Monad m) =>
Behavior t Attr -> ThemeReader t m a -> m a
runThemeReader (forall {k} (t :: k) a. Reflex t => a -> Behavior t a
constant Attr
V.defAttr) forall a b. (a -> b) -> a -> b
$
      forall {k} (t :: k) (m :: * -> *) a.
(Reflex t, Monad m) =>
Dynamic t Bool -> FocusReader t m a -> m a
runFocusReader (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) forall a b. (a -> b) -> a -> b
$
        forall {k} (t :: k) (m :: * -> *) a.
(Reflex t, Monad m) =>
Dynamic t Region -> DisplayRegion t m a -> m a
runDisplayRegion (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Int
w, Int
h) -> Int -> Int -> Int -> Int -> Region
Region Int
0 Int
0 Int
w Int
h) Dynamic t (Int, Int)
size) forall a b. (a -> b) -> a -> b
$
          forall t (m :: * -> *) a.
(Reflex t, Monad m) =>
ImageWriter t m a -> m (a, Behavior t [Image])
runImageWriter forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a. MonadIO m => NodeIdT m a -> m a
runNodeIdT forall a b. (a -> b) -> a -> b
$
              forall {k} (t :: k) (m :: * -> *) a.
Reflex t =>
Event t VtyEvent -> Input t m a -> m a
runInput Event t VtyEvent
vinev forall a b. (a -> b) -> a -> b
$ do
                forall {k} (t :: k) (m :: * -> *).
HasImageWriter t m =>
Behavior t [Image] -> m ()
tellImages forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t (Int, Int)
size) forall a b. (a -> b) -> a -> b
$ \(Int
w, Int
h) -> [forall d. Integral d => Attr -> Char -> d -> d -> Image
V.charFill Attr
V.defAttr Char
' ' Int
w Int
h]
                (forall (widget :: * -> *).
InnerWidgetConstraints t widget =>
uinev -> widget uout
app uinev
uinput'))
    ReflexVtyTestT t uintref uout m a
rtm


-- | class to help bind network and types to a 'ReflexVtyTestT'
-- analogous to ReflexTestApp
class ReflexVtyTestApp app t m | app -> t m where

  data VtyAppInputTriggerRefs app :: Type
  data VtyAppInputEvents app :: Type

  data VtyAppOutput app :: Type
  getApp :: (InnerWidgetConstraints t widget)
    => VtyAppInputEvents app -> widget (VtyAppOutput app)
  makeInputs :: m (VtyAppInputEvents app, VtyAppInputTriggerRefs app)

runReflexVtyTestApp :: (ReflexVtyTestApp app t m, MonadVtyApp t (TestGuestT t m), TestGuestConstraints t m)
  => (Int, Int) -- ^ initial screen size
  -> ReflexVtyTestT t (VtyAppInputTriggerRefs app) (VtyAppOutput app) m ()
  -> m ()
runReflexVtyTestApp :: forall app t (m :: * -> *).
(ReflexVtyTestApp app t m, MonadVtyApp t (TestGuestT t m),
 TestGuestConstraints t m) =>
(Int, Int)
-> ReflexVtyTestT
     t (VtyAppInputTriggerRefs app) (VtyAppOutput app) m ()
-> m ()
runReflexVtyTestApp (Int, Int)
r0 ReflexVtyTestT
  t (VtyAppInputTriggerRefs app) (VtyAppOutput app) m ()
rtm = do
  (VtyAppInputEvents app, VtyAppInputTriggerRefs app)
inp <- forall app t (m :: * -> *).
ReflexVtyTestApp app t m =>
m (VtyAppInputEvents app, VtyAppInputTriggerRefs app)
makeInputs
  forall uintref uinev uout t (m :: * -> *) a.
(MonadVtyApp t (TestGuestT t m), TestGuestConstraints t m) =>
(Int, Int)
-> (uinev, uintref)
-> (forall (widget :: * -> *).
    InnerWidgetConstraints t widget =>
    uinev -> widget uout)
-> ReflexVtyTestT t uintref uout m a
-> m ()
runReflexVtyTestT (Int, Int)
r0 (VtyAppInputEvents app, VtyAppInputTriggerRefs app)
inp forall app t (m :: * -> *) (widget :: * -> *).
(ReflexVtyTestApp app t m, InnerWidgetConstraints t widget) =>
VtyAppInputEvents app -> widget (VtyAppOutput app)
getApp ReflexVtyTestT
  t (VtyAppInputTriggerRefs app) (VtyAppOutput app) m ()
rtm

-- Reflex.Vty.Widget.Test
integralFractionalDivide :: (Integral a, Fractional b) => a -> a -> b
integralFractionalDivide :: forall a b. (Integral a, Fractional b) => a -> a -> b
integralFractionalDivide a
n a
d = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
d




-- TODO DELETE I don't really remember what I did here and testing Layout seems to be more a less a mistake
-- Reflex.Vty.Widget.Layout.Test
-- | same as 'RunLayout' except returns DynRegions for each of the queries in the layout
-- NOTE this method recreates the 'DynRegion's inside each 'Tile' of the layout so is not very performant
-- a better implementation is to have Layout hold its own 'DynRegion' but I'm avoid invasive changes for now.
{-
runLayout_debug
  :: (MonadFix m, MonadHold t m, PostBuild t m, Monad m, MonadNodeId m)
  => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout'
  -> Int -- ^ The positional index of the initially focused tile
  -> Event t Int -- ^ An event that shifts focus by a given number of tiles
  -> Layout t m a -- ^ The 'Layout' widget
  -> m (a, Dynamic t (Map NodeId (DynRegion t)))
runLayout_debug ddir focus0 focusShift (Layout child) = mdo
  dw <- displayWidth
  dh <- displayHeight
  let main = ffor3 ddir dw dh $ \d w h -> case d of
        Orientation_Column -> h
        Orientation_Row    -> w
  pb <- getPostBuild
  ((a, focusReq), queriesEndo) <- runReaderT (runDynamicWriterT $ runEventWriterT child) $ LayoutCtx solutionMap focusDemux ddir
  let
    queries = flip appEndo [] <$> queriesEndo
    solution = ffor2 main queries $ \sz qs -> Map.fromList
      . Map.elems
      . computeEdges
      . computeSizes sz
      . fmap (fmap snd)
      . Map.fromList
      . zip [0::Integer ..]
      $ qs
    solutionMap = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment
      { _layoutSegment_offset = offset
      , _layoutSegment_size = sz
      }
    solutionReg = ffor2 solution ddir $ \ss dir -> ffor ss $ \(offset, sz) -> DynRegion
      { _dynRegion_top = case dir of
          Orientation_Column -> constDyn offset
          Orientation_Row    -> 0
      , _dynRegion_left = case dir of
          Orientation_Column -> 0
          Orientation_Row    -> constDyn offset
      , _dynRegion_width = case dir of
          Orientation_Column -> dw
          Orientation_Row    -> constDyn sz
      , _dynRegion_height = case dir of
          Orientation_Column -> constDyn sz
          Orientation_Row    -> dh
      }
    focusable = fmap (Bimap.fromList . zip [0..]) $
      ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) ->
        if f then Just nodeId else Nothing
    adjustFocus
      :: (Bimap Int NodeId, (Int, Maybe NodeId))
      -> Either Int NodeId
      -> (Int, Maybe NodeId)
    adjustFocus (fm, (cur, _)) (Left shift) =
      let ix = (cur + shift) `mod` (max 1 $ Bimap.size fm)
      in (ix, Bimap.lookup ix fm)
    adjustFocus (fm, (cur, _)) (Right goto) =
      let ix = fromMaybe cur $ Bimap.lookupR goto fm
      in (ix, Just goto)
    focusChange = attachWith
      adjustFocus
      (current $ (,) <$> focusable <*> focussed)
      $ leftmost [Left <$> focusShift, Left 0 <$ pb, Right . getFirst <$> focusReq]
  -- A pair (Int, Maybe NodeId) which represents the index
  -- that we're trying to focus, and the node that actually gets
  -- focused (at that index) if it exists
  focussed <- holdDyn (focus0, Nothing) focusChange
  let
    focusDemux = demux $ snd <$> focussed
  return (a, solutionReg)
-}













{-
-- class variant which I couldn't figure out how to get working...

class MonadReflexVtyTest t m | m -> t where
  type UserInputTriggerRefs m :: Type
  type UserOutputEvents m :: Type
  queueVtyEvent :: VtyEvent -> m ()

newtype ReflexVtyTestT t uintref uout m a = ReflexVtyTestT { unReflexVtyTestT :: ReflexTestT t (uintref, ReflexTriggerRef t m VtyEvent) uout m a }
  deriving (Functor, Applicative, Monad, MonadIO, MonadState (AppState t m))

instance MonadTrans (ReflexVtyTestT t uintref uout) where
  lift = ReflexVtyTestT . lift

instance (r ~ ReflexTriggerRef t m VtyEvent, Monad m) => MonadReader ((uintref, r), uout) (ReflexVtyTestT t uintref uout m) where
  ask :: ReflexVtyTestT t uintref uout m ((uintref, r), uout)
  ask = ReflexVtyTestT ask --(ask :: ReflexTestT t (uintref,r) uout m (uintref,r))
--deriving instance (r ~ ReflexTriggerRef t m VtyEvent) => MonadReader (uintref,r) (ReflexVtyTestT t uintref uout m) --via ReflexTestT t (uintref,r) uout m

instance MonadReflexVtyTest t (ReflexVtyTestT t uintref uout m) where
  type UserInputTriggerRefs (ReflexVtyTestT t uintref uout m) = uintref
  type UserOutputEvents (ReflexVtyTestT t uintref uout m) = uout
  queueVtyEvent vtyev = do
    ((_, vtytref),_)  :: ((uintref, ReflexTriggerRef t m VtyEvent), uout) <- ask
    queueEventTriggerRef vtytref vtyev
-}