{-# LANGUAGE LambdaCase #-}

module Web.Hyperbole.View.Event where

import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Text qualified as T
import Text.Casing (kebab)
import Web.Hyperbole.HyperView
import Web.View (Mod, View, addContext, att, parent)
import Web.View.Types (Content (Node), Element (..))
import Web.View.View (viewModContents)


type DelayMs = Int


{- | Send the action after N milliseconds. Can be used to implement lazy loading or polling. See [Example.Page.Concurrent](https://docs.hyperbole.live/concurrent)

@
viewUpdating :: Int -> 'View' Progress ()
viewUpdating prg = do
  let pct = fromIntegral prg / 100
  Progress taskId _ <- 'viewId'
  col (onLoad (CheckProgress prg) 0) $ do
    progressBar pct $ do
      'el' grow $ text $ \"Task\" <> pack (show taskId)
@
-}
onLoad :: (ViewAction (Action id)) => Action id -> DelayMs -> Mod id
onLoad :: forall id. ViewAction (Action id) => Action id -> DelayMs -> Mod id
onLoad Action id
a DelayMs
delay = do
  Name -> Name -> Mod id
forall c. Name -> Name -> Mod c
att Name
"data-on-load" (Action id -> Name
forall a. ViewAction a => a -> Name
toAction Action id
a) Mod id -> Mod id -> Mod id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name -> Mod id
forall c. Name -> Name -> Mod c
att Name
"data-delay" (String -> Name
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ DelayMs -> String
forall a. Show a => a -> String
show DelayMs
delay)


onClick :: (ViewAction (Action id)) => Action id -> Mod id
onClick :: forall id. ViewAction (Action id) => Action id -> Mod id
onClick Action id
a = do
  Name -> Name -> Mod id
forall c. Name -> Name -> Mod c
att Name
"data-on-click" (Action id -> Name
forall a. ViewAction a => a -> Name
toAction Action id
a)


onDblClick :: (ViewAction (Action id)) => Action id -> Mod id
onDblClick :: forall id. ViewAction (Action id) => Action id -> Mod id
onDblClick Action id
a = do
  Name -> Name -> Mod id
forall c. Name -> Name -> Mod c
att Name
"data-on-dblclick" (Action id -> Name
forall a. ViewAction a => a -> Name
toAction Action id
a)


{- | Run an action when the user types into an 'input' or 'textarea'.

WARNING: a short delay can result in poor performance. It is not recommended to set the 'value' of the input

> input (onInput OnSearch) 250 id
-}
onInput :: (ViewAction (Action id)) => (Text -> Action id) -> DelayMs -> Mod id
onInput :: forall id.
ViewAction (Action id) =>
(Name -> Action id) -> DelayMs -> Mod id
onInput Name -> Action id
a DelayMs
delay = do
  Name -> Name -> Mod id
forall c. Name -> Name -> Mod c
att Name
"data-on-input" ((Name -> Action id) -> Name
forall a. ViewAction a => (Name -> a) -> Name
toActionInput Name -> Action id
a) Mod id -> Mod id -> Mod id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name -> Mod id
forall c. Name -> Name -> Mod c
att Name
"data-delay" (String -> Name
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ DelayMs -> String
forall a. Show a => a -> String
show DelayMs
delay)


onSubmit :: (ViewAction (Action id)) => Action id -> Mod id
onSubmit :: forall id. ViewAction (Action id) => Action id -> Mod id
onSubmit Action id
act = do
  Name -> Name -> Mod id
forall c. Name -> Name -> Mod c
att Name
"data-on-submit" (Action id -> Name
forall a. ViewAction a => a -> Name
toAction Action id
act)


onKeyDown :: (ViewAction (Action id)) => Key -> Action id -> Mod id
onKeyDown :: forall id. ViewAction (Action id) => Key -> Action id -> Mod id
onKeyDown Key
key Action id
act = do
  Name -> Name -> Mod id
forall c. Name -> Name -> Mod c
att (Name
"data-on-keydown-" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Key -> Name
keyDataAttribute Key
key) (Action id -> Name
forall a. ViewAction a => a -> Name
toAction Action id
act)


onKeyUp :: (ViewAction (Action id)) => Key -> Action id -> Mod id
onKeyUp :: forall id. ViewAction (Action id) => Key -> Action id -> Mod id
onKeyUp Key
key Action id
act = do
  Name -> Name -> Mod id
forall c. Name -> Name -> Mod c
att (Name
"data-on-keyup-" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Key -> Name
keyDataAttribute Key
key) (Action id -> Name
forall a. ViewAction a => a -> Name
toAction Action id
act)


keyDataAttribute :: Key -> Text
keyDataAttribute :: Key -> Name
keyDataAttribute = String -> Name
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Name) -> (Key -> String) -> Key -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
kebab (String -> String) -> (Key -> String) -> Key -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> String
showKey
 where
  showKey :: Key -> String
showKey (OtherKey Name
t) = Name -> String
forall a b. ConvertibleStrings a b => a -> b
cs Name
t
  showKey Key
k = Key -> String
forall a. Show a => a -> String
show Key
k


-- https://developer.mozilla.org/en-US/docs/Web/API/UI_Events/Keyboard_event_key_values
data Key
  = ArrowDown
  | ArrowUp
  | ArrowLeft
  | ArrowRight
  | Enter
  | Space
  | Escape
  | Alt
  | CapsLock
  | Control
  | Fn
  | Meta
  | Shift
  | OtherKey Text
  deriving (DelayMs -> Key -> String -> String
[Key] -> String -> String
Key -> String
(DelayMs -> Key -> String -> String)
-> (Key -> String) -> ([Key] -> String -> String) -> Show Key
forall a.
(DelayMs -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: DelayMs -> Key -> String -> String
showsPrec :: DelayMs -> Key -> String -> String
$cshow :: Key -> String
show :: Key -> String
$cshowList :: [Key] -> String -> String
showList :: [Key] -> String -> String
Show, ReadPrec [Key]
ReadPrec Key
DelayMs -> ReadS Key
ReadS [Key]
(DelayMs -> ReadS Key)
-> ReadS [Key] -> ReadPrec Key -> ReadPrec [Key] -> Read Key
forall a.
(DelayMs -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: DelayMs -> ReadS Key
readsPrec :: DelayMs -> ReadS Key
$creadList :: ReadS [Key]
readList :: ReadS [Key]
$creadPrec :: ReadPrec Key
readPrec :: ReadPrec Key
$creadListPrec :: ReadPrec [Key]
readListPrec :: ReadPrec [Key]
Read)


-- | Serialize a constructor that expects a single 'Text', like `data MyAction = GoSearch Text`
toActionInput :: (ViewAction a) => (Text -> a) -> Text
toActionInput :: forall a. ViewAction a => (Name -> a) -> Name
toActionInput Name -> a
con =
  -- remove the ' ""' at the end of the constructor
  DelayMs -> Name -> Name
T.dropEnd DelayMs
3 (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ a -> Name
forall a. ViewAction a => a -> Name
toAction (a -> Name) -> a -> Name
forall a b. (a -> b) -> a -> b
$ Name -> a
con Name
""


{- | Apply a Mod only when a request is in flight. See [Example.Page.Contact](https://docs.hyperbole.live/contacts/1)

@
contactEditView :: User -> 'View' Contact ()
contactEditView u = do
  'el' (hide . onRequest flexCol) contactLoading
  'el' (onRequest hide) $ contactEdit 'View' Save u
@
-}
onRequest :: Mod id -> Mod id
onRequest :: forall id. Mod id -> Mod id
onRequest Mod id
f = do
  Name -> Mod id -> Mod id
forall c. Name -> Mod c -> Mod c
parent Name
"hyp-loading" Mod id
f


-- | Internal
dataTarget :: (ViewId a) => a -> Mod x
dataTarget :: forall a x. ViewId a => a -> Mod x
dataTarget = Name -> Name -> Mod x
forall c. Name -> Name -> Mod c
att Name
"data-target" (Name -> Mod x) -> (a -> Name) -> a -> Mod x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
forall a. ViewId a => a -> Name
toViewId


-- | Allow inputs to trigger actions for a different view
target :: forall id ctx. (HyperViewHandled id ctx, ViewId id) => id -> View id () -> View ctx ()
target :: forall id ctx.
(HyperViewHandled id ctx, ViewId id) =>
id -> View id () -> View ctx ()
target id
newId View id ()
view = do
  id -> View id () -> View ctx ()
forall context c. context -> View context () -> View c ()
addContext id
newId (View id () -> View ctx ()) -> View id () -> View ctx ()
forall a b. (a -> b) -> a -> b
$ do
    View id ()
view
    ([Content] -> [Content]) -> View id ()
forall context. ([Content] -> [Content]) -> View context ()
viewModContents ((Content -> Content) -> [Content] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Content -> Content
addDataTarget)
 where
  addDataTarget :: Content -> Content
  addDataTarget :: Content -> Content
addDataTarget = \case
    Node Element
elm ->
      Element -> Content
Node (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$
        let atts :: Attributes ()
atts = Element
elm.attributes
         in Element
elm{attributes = dataTarget newId atts}
    Content
cnt -> Content
cnt