{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE RecursiveDo           #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE AllowAmbiguousTypes   #-}

{-# OPTIONS_GHC -threaded #-}

module Potato.Reflex.Vty.Helpers (
  MonadWidget
  , MonadLayoutWidget
  , debugFocus
  , debugInput
  , debugSize
  , dragTest
  , richTextConfig_simpleForeColorAttr
  , debugStreamBeh
  , debugStream
  , fmapLabelShow
  , countEv
  , vLayoutPad
  , drag2AttachOnStart
) where


import           Relude

import           Potato.Reflex.Vty.Widget
import Reflex.Potato.Helpers (simultaneous)

import           Control.Monad.Fix
import           Control.Monad.NodeId
import qualified Data.Text                as T
import qualified Graphics.Vty             as V
import           Reflex
import           Reflex.Vty

type MonadWidget t m = (Reflex t, MonadHold t m, MonadFix m, NotReady t m, Adjustable t m, PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadNodeId m, MonadIO (Performable m), MonadSample t m, MonadIO m
      , HasImageWriter t m
      , MonadNodeId m
      , HasDisplayRegion t m
      , HasFocusReader t m
      , HasInput t m
      , HasTheme t m)

type MonadLayoutWidget t m = (MonadWidget t m, HasFocus t m, HasLayout t m)

debugFocus :: (HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => m ()
debugFocus :: forall t (m :: * -> *).
(HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
m ()
debugFocus = do
  Dynamic t Bool
f <- forall {k} (t :: k) (m :: * -> *).
HasFocusReader t m =>
m (Dynamic t Bool)
focus
  forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
Behavior t Text -> m ()
text forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (Show a, IsString b) => a -> b
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Bool
f

debugInput :: (MonadHold t m, HasInput t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => m ()
debugInput :: forall t (m :: * -> *).
(MonadHold t m, HasInput t m, HasDisplayRegion t m,
 HasImageWriter t m, HasTheme t m) =>
m ()
debugInput = do
  Behavior t String
lastEvent <- forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Behavior t a)
hold String
"No event yet" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b a. (Show a, IsString b) => a -> b
show forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {k} (t :: k) (m :: * -> *).
HasInput t m =>
m (Event t VtyEvent)
input
  forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
Behavior t Text -> m ()
text forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t String
lastEvent

debugSize ::  (MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => m ()
debugSize :: forall t (m :: * -> *).
(MonadHold t m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
m ()
debugSize = do
  Dynamic t Int
ldw <- forall {k} (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayWidth
  Dynamic t Int
ldh <- forall {k} (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayHeight
  let combine :: a -> a -> a
combine a
w a
h = a
"w: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show a
w forall a. Semigroup a => a -> a -> a
<> a
" h: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show a
h
  forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
Behavior t Text -> m ()
text forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Int -> Int -> Text
combine (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
ldw) (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
ldh)

dragTest :: (MonadHold t m, MonadFix m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasTheme t m) => m ()
dragTest :: forall t (m :: * -> *).
(MonadHold t m, MonadFix m, HasDisplayRegion t m,
 HasImageWriter t m, HasInput t m, HasTheme t m) =>
m ()
dragTest = do
  Behavior t String
lastEvent <- forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Behavior t a)
hold String
"No event yet" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b a. (Show a, IsString b) => a -> b
show forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {k} (t :: k) (m :: * -> *).
(Reflex t, MonadFix m, MonadHold t m, HasInput t m) =>
Button -> m (Event t Drag)
drag Button
V.BLeft
  forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
Behavior t Text -> m ()
text forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t String
lastEvent

richTextConfig_simpleForeColorAttr :: (Reflex t) => RichTextConfig t
richTextConfig_simpleForeColorAttr :: forall t. Reflex t => RichTextConfig t
richTextConfig_simpleForeColorAttr = forall {k} (t :: k). Behavior t Attr -> RichTextConfig t
RichTextConfig forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) a. Reflex t => a -> Behavior t a
constant (Attr
V.defAttr { attrForeColor :: MaybeDefault Color
V.attrForeColor = forall v. v -> MaybeDefault v
V.SetTo Color
V.yellow})

fmapLabelShow :: (Functor f, Show a) => Text -> f a -> f Text
fmapLabelShow :: forall (f :: * -> *) a.
(Functor f, Show a) =>
Text -> f a -> f Text
fmapLabelShow Text
t = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
x -> Text
t forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show a
x)

-- TODO rename to debugStreamEv
debugStream :: (MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => [Event t Text] -> m ()
debugStream :: forall t (m :: * -> *).
(MonadHold t m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
[Event t Text] -> m ()
debugStream [Event t Text]
evs = do
  Dynamic t Text
t <- forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
holdDyn Text
"" forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith (\Text
a Text
b -> Text
a forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
b) [Event t Text]
evs
  forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
RichTextConfig t -> Behavior t Text -> m ()
richText forall t. Reflex t => RichTextConfig t
richTextConfig_simpleForeColorAttr (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Text
t)

debugStreamBeh :: (MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => [Behavior t Text] -> m ()
debugStreamBeh :: forall t (m :: * -> *).
(MonadHold t m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
[Behavior t Text] -> m ()
debugStreamBeh [Behavior t Text]
behs = forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
Behavior t Text -> m ()
text forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\Text
t1 Text
t2 -> Text
t1 forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
t2)) Behavior t Text
"" [Behavior t Text]
behs

countEv :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Dynamic t Int)
countEv :: forall t (m :: * -> *) a.
(Reflex t, MonadHold t m, MonadFix m) =>
Event t a -> m (Dynamic t Int)
countEv Event t a
ev = forall {k} (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn (\a
_ Int
b -> Int
bforall a. Num a => a -> a -> a
+Int
1) Int
0 Event t a
ev

vLayoutPad :: (PostBuild t m, MonadHold t m, MonadFix m, MonadNodeId m, HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m) => Int -> m a -> m a
vLayoutPad :: forall t (m :: * -> *) a.
(PostBuild t m, MonadHold t m, MonadFix m, MonadNodeId m,
 HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m,
 HasInput t m) =>
Int -> m a -> m a
vLayoutPad Int
n m a
w = forall t (m :: * -> *) a.
(HasDisplayRegion t m, MonadFix m) =>
Layout t m a -> m a
initLayout forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) (m :: * -> *) a.
(Reflex t, MonadFix m, HasLayout t m) =>
m a -> m a
col forall a b. (a -> b) -> a -> b
$ do
  (forall {k} (m :: * -> *) (t :: k) a.
(MonadFix m, MonadHold t m, HasLayout t m, HasInput t m,
 HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m) =>
Dynamic t Constraint -> m a -> m a
grout forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (t :: k).
Reflex t =>
Dynamic t Int -> Dynamic t Constraint
fixed) (forall {k} (t :: k) a. Reflex t => a -> Dynamic t a
constDyn Int
n) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
  (forall {k} (m :: * -> *) (t :: k) a.
(MonadFix m, MonadHold t m, HasLayout t m, HasInput t m,
 HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m) =>
Dynamic t Constraint -> m a -> m a
grout forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (t :: k).
Reflex t =>
Dynamic t Int -> Dynamic t Constraint
stretch) Dynamic t Int
0 (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
w)

{-
dragAttachOnStart
  :: forall t m a. (Reflex t, MonadFix m, MonadHold t m)
  => V.Button
  -> Behavior t a
  -> m (Event t (a, Drag))
dragAttachOnStart btn beh = mdo
  inp <- input
  let
    f :: (Maybe (a, Drag), V.Event) -> PushM t (Maybe (a, Drag))
    f (Nothing, inp) = case inp of
      V.EvMouseDown x y btn' mods
        | btn == btn' -> do
          a <- sample beh
          return . Just $ (a, Drag (x,y) (x,y) btn' mods False)
        | otherwise -> return Nothing
      _ -> return Nothing
    f (Just (a, Drag from _ _ mods end), inp) = case inp of
      V.EvMouseDown x y btn' mods'
        | end && btn == btn' -> do
          newa <- sample beh
          return . Just $ (newa, Drag (x,y) (x,y) btn' mods' False)
        | btn == btn' -> return . Just $ (a, Drag from (x,y) btn mods' False)
        | otherwise   -> return Nothing -- Ignore other buttons.
      V.EvMouseUp x y (Just btn')
        | end         -> return Nothing
        | btn == btn' -> return . Just $ (a, Drag from (x,y) btn mods True)
        | otherwise   -> return Nothing
      V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button,
                              -- assume it's the right one.
        | end       -> return Nothing
        | otherwise -> return . Just $ (a, Drag from (x,y) btn mods True)
      _ -> return Nothing
    newDrag :: Event t (a, Drag)
    newDrag = push f (attach (current dragD) inp)
  dragD <- holdDyn Nothing $ Just <$> newDrag
  return (fmapMaybe id $ updated dragD)
-}


drag2AttachOnStart
  :: forall t m a. (Reflex t, MonadFix m, MonadHold t m, HasInput t m)
  => V.Button
  -> Behavior t a
  -> m (Event t (a, Drag2))
drag2AttachOnStart :: forall t (m :: * -> *) a.
(Reflex t, MonadFix m, MonadHold t m, HasInput t m) =>
Button -> Behavior t a -> m (Event t (a, Drag2))
drag2AttachOnStart Button
btn Behavior t a
beh = do
  Event t Drag2
dragEv <- forall t (m :: * -> *).
(Reflex t, MonadFix m, MonadHold t m, HasInput t m) =>
Button -> m (Event t Drag2)
drag2 Button
V.BLeft
  let
    foldfn :: Drag2 -> Maybe (a, Drag2) -> PushM t (Maybe (a, Drag2))
foldfn Drag2
d Maybe (a, Drag2)
ma = do
      a
anew <- case Maybe (a, Drag2)
ma of
        Maybe (a, Drag2)
Nothing                                   -> forall {k} (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample Behavior t a
beh
        Just (a
a, Drag2
_) | Drag2 -> DragState
_drag2_state Drag2
d forall a. Eq a => a -> a -> Bool
== DragState
DragStart -> forall {k} (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample Behavior t a
beh
        Just (a
a, Drag2
_)                               -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
      return $ forall a. a -> Maybe a
Just (a
anew, Drag2
d)
  Dynamic t (Maybe (a, Drag2))
dragBeh <- forall {k} (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
foldDynM Drag2 -> Maybe (a, Drag2) -> PushM t (Maybe (a, Drag2))
foldfn forall a. Maybe a
Nothing Event t Drag2
dragEv
  return $ forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
fmapMaybe forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t (Maybe (a, Drag2))
dragBeh