{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE UndecidableInstances #-}

module Web.Hyperbole.HyperView.Input where

import Data.Aeson (FromJSON, ToJSON)
import Data.String.Conversions (cs)
import Data.Text (Text)
import GHC.Generics (Generic)
import Web.Atomic.Types
import Web.Hyperbole.Data.Argument (decodeArgument, encodeArgument)
import Web.Hyperbole.HyperView.Event (DelayMs, onChange, onClick, onInput)
import Web.Hyperbole.HyperView.Types (HyperView (..))
import Web.Hyperbole.Route (Route (..), routeUri)
import Web.Hyperbole.View


{- ! \<button\> HTML tag which sends the action when pressed

@
#EMBED Example.Simple messageView
@
-}

{- | \<button\> HTML tag which sends the action when pressed

@
messageView :: Text -> 'View' Message ()
messageView msg = do
  'button' (Louder msg) ~ border 1 $ text msg
@
-}
button :: (ViewAction (Action id)) => Action id -> View id () -> View id ()
button :: forall id.
ViewAction (Action id) =>
Action id -> View id () -> View id ()
button Action id
action View id ()
cnt = do
  Text -> View id () -> View id ()
forall c. Text -> View c () -> View c ()
tag Text
"button" View id ()
cnt View id ()
-> (Attributes (View id ()) -> Attributes (View id ()))
-> View id ()
forall h.
Attributable h =>
h -> (Attributes h -> Attributes h) -> h
@ Action id -> Attributes (View id ()) -> Attributes (View id ())
forall id a.
(ViewAction (Action id), Attributable a) =>
Action id -> Attributes a -> Attributes a
onClick Action id
action


{- ! Type-safe dropdown. Sends the action when selected. The default will be selected on load.

@
#EMBED Example.DataLists.Filter familyDropdown
@
-}

{- | Type-safe dropdown. Sends the action when selected. The default will be selected on load.

@
familyDropdown :: Filters -> 'View' Languages ()
familyDropdown filters =
  dropdown SetFamily filters.family ~ border 1 . pad 10 $ do
    option Nothing \"Any\"
    option (Just ObjectOriented) \"Object Oriented\"
    option (Just Functional) \"Functional\"
@
-}
dropdown
  :: forall opt id
   . (ViewAction (Action id), FromJSON opt)
  => Action id
  -> opt -- default option
  -> View (Option id opt) ()
  -> View id ()
dropdown :: forall opt id.
(ViewAction (Action id), FromJSON opt) =>
Action id -> opt -> View (Option id opt) () -> View id ()
dropdown Action id
act opt
defOpt View (Option id opt) ()
options = do
  st :: ViewState id <- View id (ViewState id)
forall c. View c (ViewState c)
viewState
  i :: id <- viewId
  tag "select" @ onChange act $ do
    runViewContext (Option i defOpt) st options


-- | An option for a 'dropdown' or 'select'
option
  :: forall opt id
   . (ViewAction (Action id), Eq opt, ToJSON opt)
  => opt
  -> Text
  -> View (Option id opt) ()
option :: forall opt id.
(ViewAction (Action id), Eq opt, ToJSON opt) =>
opt -> Text -> View (Option id opt) ()
option opt
opt Text
cnt = do
  os :: Option id opt <- View (Option id opt) (Option id opt)
forall {k} (m :: k -> *) (view :: k). HasViewId m view => m view
viewId
  tag "option" @ att "value" (encodeOption opt) @ selected (os.defaultOption == opt) $ text cnt


encodeOption :: (ToJSON opt) => opt -> Text
encodeOption :: forall opt. ToJSON opt => opt -> Text
encodeOption opt
opt =
  case opt -> Text
forall opt. ToJSON opt => opt -> Text
encodeArgument opt
opt of
    -- For options, an empty string makes much more sense than null for empty values
    Text
"null" -> Text
""
    Text
other -> Text
other


-- | sets selected = true if the 'dropdown' predicate returns True
selected :: (Attributable h) => Bool -> Attributes h -> Attributes h
selected :: forall h. Attributable h => Bool -> Attributes h -> Attributes h
selected Bool
b = if Bool
b then Text -> Text -> Attributes h -> Attributes h
forall h.
Attributable h =>
Text -> Text -> Attributes h -> Attributes h
att Text
"selected" Text
"true" else Attributes h -> Attributes h
forall a. a -> a
id


-- | The view context for an 'option'
data Option id opt = Option
  { forall id opt. Option id opt -> id
id :: id
  , forall id opt. Option id opt -> opt
defaultOption :: opt
  }
  deriving ((forall x. Option id opt -> Rep (Option id opt) x)
-> (forall x. Rep (Option id opt) x -> Option id opt)
-> Generic (Option id opt)
forall x. Rep (Option id opt) x -> Option id opt
forall x. Option id opt -> Rep (Option id opt) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall id opt x. Rep (Option id opt) x -> Option id opt
forall id opt x. Option id opt -> Rep (Option id opt) x
$cfrom :: forall id opt x. Option id opt -> Rep (Option id opt) x
from :: forall x. Option id opt -> Rep (Option id opt) x
$cto :: forall id opt x. Rep (Option id opt) x -> Option id opt
to :: forall x. Rep (Option id opt) x -> Option id opt
Generic)


instance (ToJSON id, ToJSON opt, FromJSON id, FromJSON opt) => ViewId (Option id opt) where
  type ViewState (Option id opt) = ViewState id


{- ! A live search field. Set a DelayMs to avoid hitting the server on every keystroke

@
#EMBED Example.Errors viewSearchUsers
@
-}

{- | A live search field. Set a DelayMs to avoid hitting the server on every keystroke

@
viewSearchUsers :: 'View' Users ()
viewSearchUsers = do
  'el' \"Search for a user by id\"
  search SearchUser 250 ~ border 1 . pad 10 @ placeholder \"2\"
@
-}
search :: (ViewAction (Action id)) => Action id -> DelayMs -> View id ()
search :: forall id.
ViewAction (Action id) =>
Action id -> DelayMs -> View id ()
search Action id
go DelayMs
delay = do
  Text -> View id () -> View id ()
forall c. Text -> View c () -> View c ()
tag Text
"input" View id ()
forall c. View c ()
none View id ()
-> (Attributes (View id ()) -> Attributes (View id ()))
-> View id ()
forall h.
Attributable h =>
h -> (Attributes h -> Attributes h) -> h
@ Action id
-> DelayMs -> Attributes (View id ()) -> Attributes (View id ())
forall id a.
(ViewAction (Action id), Attributable a) =>
Action id -> DelayMs -> Attributes a -> Attributes a
onInput Action id
go DelayMs
delay


-- | Set checkbox = checked via the client (VDOM doesn't work)
checked :: (Attributable a) => Bool -> Attributes a -> Attributes a
checked :: forall h. Attributable h => Bool -> Attributes h -> Attributes h
checked Bool
c =
  Text -> Text -> Attributes a -> Attributes a
forall h.
Attributable h =>
Text -> Text -> Attributes h -> Attributes h
att Text
"data-checked" (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> String
forall a. Show a => a -> String
show Bool
c)
    (Attributes a -> Attributes a)
-> (Attributes a -> Attributes a) -> Attributes a -> Attributes a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. if Bool
c then Text -> Text -> Attributes a -> Attributes a
forall h.
Attributable h =>
Text -> Text -> Attributes h -> Attributes h
att Text
"checked" Text
"" else Attributes a -> Attributes a
forall a. a -> a
id


{- | A hyperlink to another route

>>> route (User 100) id "View User"
<a href="/user/100">View User</a>
-}
route :: (Route a) => a -> View c () -> View c ()
route :: forall a c. Route a => a -> View c () -> View c ()
route a
r = URI -> View c () -> View c ()
forall c. URI -> View c () -> View c ()
link (a -> URI
forall a. Route a => a -> URI
routeUri a
r)


-- instance {-# OVERLAPPABLE #-} (FromJSON a) => UserInput (Maybe a) where
--   parseInput "" = pure Nothing
--   parseInput t = pure $ A.decode (cs t)
--
--
-- instance {-# OVERLAPS #-} UserInput (Maybe Text) where
--   parseInput = pure . Just

class InputValue a where
  parseInputValue :: Text -> Either String a
  default parseInputValue :: (FromJSON a) => Text -> Either String a
  parseInputValue = Text -> Either String a
forall a. FromJSON a => Text -> Either String a
decodeArgument


instance InputValue Text where
  parseInputValue :: Text -> Either String Text
parseInputValue = Text -> Either String Text
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance InputValue Int where
  parseInputValue :: Text -> Either String DelayMs
parseInputValue Text
"" = DelayMs -> Either String DelayMs
forall a b. b -> Either a b
Right DelayMs
0
  parseInputValue Text
t = Text -> Either String DelayMs
forall a. FromJSON a => Text -> Either String a
decodeArgument Text
t
instance InputValue Float where
  parseInputValue :: Text -> Either String Float
parseInputValue Text
"" = Float -> Either String Float
forall a b. b -> Either a b
Right Float
0
  parseInputValue Text
t = Text -> Either String Float
forall a. FromJSON a => Text -> Either String a
decodeArgument Text
t
instance InputValue Double where
  parseInputValue :: Text -> Either String Double
parseInputValue Text
"" = Double -> Either String Double
forall a b. b -> Either a b
Right Double
0
  parseInputValue Text
t = Text -> Either String Double
forall a. FromJSON a => Text -> Either String a
decodeArgument Text
t
instance InputValue Integer where
  parseInputValue :: Text -> Either String Integer
parseInputValue Text
"" = Integer -> Either String Integer
forall a b. b -> Either a b
Right Integer
0
  parseInputValue Text
t = Text -> Either String Integer
forall a. FromJSON a => Text -> Either String a
decodeArgument Text
t


instance {-# OVERLAPPABLE #-} (InputValue a) => InputValue (Maybe a) where
  parseInputValue :: Text -> Either String (Maybe a)
parseInputValue Text
"null" = Maybe a -> Either String (Maybe a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  parseInputValue Text
"" = Maybe a -> Either String (Maybe a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  parseInputValue Text
t = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Either String a -> Either String (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either String a
forall a. InputValue a => Text -> Either String a
parseInputValue Text
t


instance {-# OVERLAPS #-} InputValue (Maybe Text) where
  parseInputValue :: Text -> Either String (Maybe Text)
parseInputValue Text
t = Maybe Text -> Either String (Maybe Text)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Either String (Maybe Text))
-> Maybe Text -> Either String (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t


instance {-# OVERLAPS #-} InputValue (Maybe String) where
  parseInputValue :: Text -> Either String (Maybe String)
parseInputValue Text
t = Maybe String -> Either String (Maybe String)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> Either String (Maybe String))
-> Maybe String -> Either String (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
t)