-----------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE CPP                        #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Types
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Core types for Miso applications.
----------------------------------------------------------------------------
module Miso.Types
  ( -- ** Types
    App
  , Component     (..)
  , ComponentId
  , SomeComponent (..)
  , View          (..)
  , Key           (..)
  , Attribute     (..)
  , NS            (..)
  , CSS           (..)
  , JS            (..)
  , LogLevel      (..)
  , VTree         (..)
  , VTreeType     (..)
  , MountPoint
  , DOMRef
  , ROOT
  , Transition
  , Events
  , Phase         (..)
  , URI           (..)
  -- ** Classes
  , ToKey         (..)
  -- ** Data Bindings
  , Binding       (..)
  -- ** Smart Constructors
  , emptyURI
  , component
  , (-->)
  , (<--)
  , (<-->)
  , (<--->)
  , (--->)
  , (<---)
  -- ** Component mounting
  , (+>)
  , mount
  , mount_
  -- ** Utils
  , getMountPoint
  , optionalAttrs
  , optionalChildren
  , prettyURI
  , prettyQueryString
  -- *** Combinators
  , node
  , text
  , text_
  , textRaw
  , textKey
  , textKey_
  , htmlEncode
  -- *** MisoString
  , MisoString
  , toMisoString
  , fromMisoString
  , ms
  ) where
-----------------------------------------------------------------------------
import qualified Data.Map.Strict as M
import           Data.Maybe (fromMaybe, isJust)
import           Data.String (IsString, fromString)
import qualified Data.Text as T
import           GHC.Generics
import           Prelude
-----------------------------------------------------------------------------
import           Miso.Binding ((<--), (-->), (<-->), (<---), (--->), (<--->), Binding(..))
import           Miso.Concurrent (Mail)
import           Miso.DSL
import           Miso.Effect (Effect, Sub, Sink, DOMRef, ComponentId)
import           Miso.Event.Types
import           Miso.JSON (Value, ToJSON(..), encode)
import qualified Miso.String as MS
import           Miso.String (ToMisoString, MisoString, toMisoString, ms, fromMisoString)
import           Miso.CSS.Types (StyleSheet)
-----------------------------------------------------------------------------
-- | Application entry point
data Component parent model action
  = Component
  { forall parent model action. Component parent model action -> model
model :: model
  -- ^ Initial model
#ifdef SSR
  , hydrateModel :: Maybe (IO model)
#else
  , forall parent model action.
Component parent model action -> Maybe (IO model)
hydrateModel :: Maybe (IO model)
#endif
  -- ^ Action to load component state, such as reading data from page.
  --   The resulting model is only used during initial hydration, not on remounts.
  , forall parent model action.
Component parent model action
-> action -> Effect parent model action
update :: action -> Effect parent model action
  -- ^ Updates model, optionally providing effects.
  , forall parent model action.
Component parent model action -> model -> View model action
view :: model -> View model action
  -- ^ Draws 'View'
  , forall parent model action.
Component parent model action -> [Sub action]
subs :: [ Sub action ]
  -- ^ Subscriptions to run during application lifetime
  , forall parent model action. Component parent model action -> [CSS]
styles :: [CSS]
  -- ^ CSS styles expressed as either a URL ('Href') or as 'Style' text.
  -- These styles are appended dynamically to the \<head\> section of your HTML page
  -- before the initial draw on \<body\> occurs.
  --
  -- @since 1.9.0.0
  , forall parent model action. Component parent model action -> [JS]
scripts :: [JS]
  -- ^ JavaScript scripts expressed as either a URL ('Src') or raw JS text.
  -- These scripts are appended dynamically to the \<head\> section of your HTML page
  -- before the initial draw on \<body\> occurs.
  --
  -- @since 1.9.0.0
  , forall parent model action.
Component parent model action -> Maybe action
initialAction :: Maybe action
  -- ^ Initial action run after the application has loaded, optional
  --
  -- @since 1.9.0.0
  , forall parent model action.
Component parent model action -> Maybe MisoString
mountPoint :: Maybe MountPoint
  -- ^ ID of the root element for DOM diff.
  -- If 'Nothing' is provided, the entire document body is used as a mount point.
  , forall parent model action.
Component parent model action -> LogLevel
logLevel :: LogLevel
  -- ^ Debugging configuration for prerendering and event delegation
  , forall parent model action.
Component parent model action -> Mail -> Maybe action
mailbox :: Mail -> Maybe action
  -- ^ Receives mail from other components
  --
  -- @since 1.9.0.0
  , forall parent model action.
Component parent model action -> [Binding parent model]
bindings :: [ Binding parent model ]
  -- ^ Data bindings between parent and child t'Miso.Types.Component's
  --
  -- @since 1.9.0.0
  , forall parent model action. Component parent model action -> Bool
eventPropagation :: Bool
  -- ^ Should events bubble up past the t'Miso.Types.Component' barrier.
  --
  -- Defaults to False
  --
  -- @since 1.9.0.0
  }
-----------------------------------------------------------------------------
-- | @mountPoint@ for t'Miso.Types.Component', e.g "body"
type MountPoint = MisoString
-----------------------------------------------------------------------------
-- | Allow users to express CSS and append it to \<head\> before the first draw
--
-- > Href "http://domain.com/style.css"
-- > Style "body { background-color: red; }"
--
data CSS
  = Href MisoString
  -- ^ URL linking to hosted CSS
  | Style MisoString
  -- ^ Raw CSS content in a 'Miso.Html.Element.style_' tag
  | Sheet StyleSheet
  -- ^ CSS built with 'Miso.CSS'
  deriving (Int -> CSS -> ShowS
[CSS] -> ShowS
CSS -> String
(Int -> CSS -> ShowS)
-> (CSS -> String) -> ([CSS] -> ShowS) -> Show CSS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CSS -> ShowS
showsPrec :: Int -> CSS -> ShowS
$cshow :: CSS -> String
show :: CSS -> String
$cshowList :: [CSS] -> ShowS
showList :: [CSS] -> ShowS
Show, CSS -> CSS -> Bool
(CSS -> CSS -> Bool) -> (CSS -> CSS -> Bool) -> Eq CSS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CSS -> CSS -> Bool
== :: CSS -> CSS -> Bool
$c/= :: CSS -> CSS -> Bool
/= :: CSS -> CSS -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Allow users to express JS and append it to <head> before the first draw
--
-- This is meant to be useful in development only.
--
-- @
--   Src \"http:\/\/example.com\/script.js\"
--   Script "alert(\"hi\");"
--   ImportMap [ "key" =: "value" ]
-- @
--
data JS
  = Src MisoString
  -- ^ URL linking to hosted JS
  | Script MisoString
  -- ^ Raw JS content that you would enter in a \<script\> tag
  | Module MisoString
  -- ^ Raw JS module content that you would enter in a \<script type="module"\> tag.
  -- See [script type](https://developer.mozilla.org/en-US/docs/Web/HTML/Reference/Elements/script/type)
  | ImportMap [(MisoString,MisoString)]
  -- ^ Import map content in a \<script type="importmap"\> tag.
  -- See [importmap](https://developer.mozilla.org/en-US/docs/Web/HTML/Reference/Elements/script/type/importmap)
  deriving (Int -> JS -> ShowS
[JS] -> ShowS
JS -> String
(Int -> JS -> ShowS)
-> (JS -> String) -> ([JS] -> ShowS) -> Show JS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JS -> ShowS
showsPrec :: Int -> JS -> ShowS
$cshow :: JS -> String
show :: JS -> String
$cshowList :: [JS] -> ShowS
showList :: [JS] -> ShowS
Show, JS -> JS -> Bool
(JS -> JS -> Bool) -> (JS -> JS -> Bool) -> Eq JS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JS -> JS -> Bool
== :: JS -> JS -> Bool
$c/= :: JS -> JS -> Bool
/= :: JS -> JS -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Convenience for extracting mount point
getMountPoint :: Maybe MisoString -> MisoString
getMountPoint :: Maybe MisoString -> MisoString
getMountPoint = MisoString -> Maybe MisoString -> MisoString
forall a. a -> Maybe a -> a
fromMaybe MisoString
"body"
-----------------------------------------------------------------------------
-- | Smart constructor for t'Miso.Types.Component' with sane defaults.
component
  :: model
  -> (action -> Effect parent model action)
  -> (model -> View model action)
  -> Component parent model action
component :: forall model action parent.
model
-> (action -> Effect parent model action)
-> (model -> View model action)
-> Component parent model action
component model
m action -> Effect parent model action
u model -> View model action
v = Component
  { model :: model
model = model
m
  , hydrateModel :: Maybe (IO model)
hydrateModel = Maybe (IO model)
forall a. Maybe a
Nothing
  , update :: action -> Effect parent model action
update = action -> Effect parent model action
u
  , view :: model -> View model action
view = model -> View model action
v
  , subs :: [Sub action]
subs = []
  , styles :: [CSS]
styles = []
  , scripts :: [JS]
scripts = []
  , mountPoint :: Maybe MisoString
mountPoint = Maybe MisoString
forall a. Maybe a
Nothing
  , logLevel :: LogLevel
logLevel = LogLevel
Off
  , initialAction :: Maybe action
initialAction = Maybe action
forall a. Maybe a
Nothing
  , mailbox :: Mail -> Maybe action
mailbox = Maybe action -> Mail -> Maybe action
forall a b. a -> b -> a
const Maybe action
forall a. Maybe a
Nothing
  , bindings :: [Binding parent model]
bindings = []
  , eventPropagation :: Bool
eventPropagation = Bool
False
  }
-----------------------------------------------------------------------------
-- | A top-level t'Miso.Types.Component' can have no @parent@.
--
-- The 'ROOT' type is for disallowing a top-level mounted t'Miso.Types.Component' access
-- into its parent state. It has no inhabitants (spiritually 'Data.Void.Void')
--
data ROOT
-----------------------------------------------------------------------------
-- | 'Eq' instance for 'ROOT'
instance Eq ROOT where ROOT
_ == :: ROOT -> ROOT -> Bool
== ROOT
_ = Bool
True
-----------------------------------------------------------------------------
-- | A miso application is a top-level t'Miso.Types.Component', which has no @parent@.
-- This is enforced by specializing the @parent@ type parameter to 'ROOT'.
--
type App model action = Component ROOT model action
-----------------------------------------------------------------------------
-- | A specialized version of 'Effect' that can be used in the type of application 'update' function,
-- when t'Miso.Types.Component's are not in use. Also for pre-1.9 'Miso.miso' applications.
type Transition model action = Effect ROOT model action
-----------------------------------------------------------------------------
-- | Logging configuration for debugging Miso internals (useful to see if prerendering is successful)
data LogLevel
  = Off
  -- ^ No debug logging, the default value used in 'component'
  | DebugHydrate
  -- ^ Will warn if the structure or properties of the
  -- DOM vs. Virtual DOM differ during prerendering.
  | DebugEvents
  -- ^ Will warn if an event cannot be routed to the Haskell event
  -- handler that raised it. Also will warn if an event handler is
  -- being used, yet it's not being listened for by the event
  -- delegator mount point.
  | DebugAll
  -- ^ Logs on all of the above
  deriving (Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> String
(Int -> LogLevel -> ShowS)
-> (LogLevel -> String) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogLevel -> ShowS
showsPrec :: Int -> LogLevel -> ShowS
$cshow :: LogLevel -> String
show :: LogLevel -> String
$cshowList :: [LogLevel] -> ShowS
showList :: [LogLevel] -> ShowS
Show, LogLevel -> LogLevel -> Bool
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
/= :: LogLevel -> LogLevel -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Core type for constructing a virtual DOM in Haskell
data View model action
  = VNode NS MisoString [Attribute action] [View model action]
  | VText (Maybe Key) MisoString
  | VComp [Attribute action] (SomeComponent model)
  deriving (forall a b. (a -> b) -> View model a -> View model b)
-> (forall a b. a -> View model b -> View model a)
-> Functor (View model)
forall a b. a -> View model b -> View model a
forall a b. (a -> b) -> View model a -> View model b
forall model a b. a -> View model b -> View model a
forall model a b. (a -> b) -> View model a -> View model b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall model a b. (a -> b) -> View model a -> View model b
fmap :: forall a b. (a -> b) -> View model a -> View model b
$c<$ :: forall model a b. a -> View model b -> View model a
<$ :: forall a b. a -> View model b -> View model a
Functor
-----------------------------------------------------------------------------
-- | Existential wrapper allowing nesting of t'Miso.Types.Component' in t'Miso.Types.Component'
data SomeComponent parent
   = forall model action . Eq model
  => SomeComponent (Component parent model action)
-----------------------------------------------------------------------------
-- | t'Miso.Types.Component' mounting combinator
--
-- Used in the @view@ function to mount a t'Miso.Types.Component' on any 'VNode'.
--
-- @
--   "component-id" +> component model noop $ \\m ->
--     div_ [ id_ "foo" ] [ text (ms m) ]
-- @
--
-- @since 1.9.0.0
(+>)
  :: forall child model action a . Eq child
  => MisoString
  -> Component model child action
  -> View model a
infixr 0 +>
MisoString
key +> :: forall child model action a.
Eq child =>
MisoString -> Component model child action -> View model a
+> Component model child action
vcomp = [Attribute a] -> SomeComponent model -> View model a
forall model action.
[Attribute action] -> SomeComponent model -> View model action
VComp [ MisoString -> Mail -> Attribute a
forall action. MisoString -> Mail -> Attribute action
Property MisoString
"key" (MisoString -> Mail
forall a. ToJSON a => a -> Mail
toJSON MisoString
key) ] (Component model child action -> SomeComponent model
forall parent model action.
Eq model =>
Component parent model action -> SomeComponent parent
SomeComponent Component model child action
vcomp)
-----------------------------------------------------------------------------
-- | t'Miso.Types.Component' mounting combinator. Takes '[Attribute a]' as arguments.
--
-- @
--   mount_ [ key_ "foo", onMounted Mounted ] $ component model noop $ \\m ->
--     div_ [ id_ "foo" ] [ text (ms m) ]
-- @
--
-- @since 1.9.0.0
mount_
  :: Eq m
  => [Attribute action]
  -> Component p m a
  -> View p action
mount_ :: forall m action p a.
Eq m =>
[Attribute action] -> Component p m a -> View p action
mount_ [Attribute action]
attrs Component p m a
vcomp = [Attribute action] -> SomeComponent p -> View p action
forall model action.
[Attribute action] -> SomeComponent model -> View model action
VComp [Attribute action]
attrs (Component p m a -> SomeComponent p
forall parent model action.
Eq model =>
Component parent model action -> SomeComponent parent
SomeComponent Component p m a
vcomp)
-----------------------------------------------------------------------------
-- | t'Miso.Types.Component' mounting combinator.
--
-- Note: only use this if you're certain you won't be diffing two t'Miso.Types.Component'
-- against each other. Otherwise, you will need a key to distinguish between
-- the two t'Miso.Types.Component', to ensure unmounting and mounting occurs.
--
-- @
--   mount $ component model noop $ \\m ->
--     div_ [ id_ "foo" ] [ text (ms m) ]
-- @
--
-- @since 1.9.0.0
mount
  :: Eq m
  => Component p m a
  -> View p action
mount :: forall m p a action. Eq m => Component p m a -> View p action
mount = [Attribute action] -> Component p m a -> View p action
forall m action p a.
Eq m =>
[Attribute action] -> Component p m a -> View p action
mount_ []
-----------------------------------------------------------------------------
-- | DOM element namespace.
data NS
  = HTML
  -- ^ HTML Namespace
  | SVG
  -- ^ SVG Namespace
  | MATHML
  -- ^ MATHML Namespace
  deriving (Int -> NS -> ShowS
[NS] -> ShowS
NS -> String
(Int -> NS -> ShowS)
-> (NS -> String) -> ([NS] -> ShowS) -> Show NS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NS -> ShowS
showsPrec :: Int -> NS -> ShowS
$cshow :: NS -> String
show :: NS -> String
$cshowList :: [NS] -> ShowS
showList :: [NS] -> ShowS
Show, NS -> NS -> Bool
(NS -> NS -> Bool) -> (NS -> NS -> Bool) -> Eq NS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NS -> NS -> Bool
== :: NS -> NS -> Bool
$c/= :: NS -> NS -> Bool
/= :: NS -> NS -> Bool
Eq)
-----------------------------------------------------------------------------
instance ToJSVal NS where
  toJSVal :: NS -> IO JSVal
toJSVal = \case
    NS
SVG -> MisoString -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (MisoString
"svg" :: MisoString)
    NS
HTML -> MisoString -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (MisoString
"html" :: MisoString)
    NS
MATHML -> MisoString -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (MisoString
"mathml" :: MisoString)
-----------------------------------------------------------------------------
-- | Unique key for a DOM node.
--
-- This key is only used to speed up diffing the children of a DOM
-- node, the actual content is not important. The keys of the children
-- of a given DOM node must be unique. Failure to satisfy this
-- invariant gives undefined behavior at runtime.
newtype Key = Key MisoString
  deriving newtype (Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
(Int -> Key -> ShowS)
-> (Key -> String) -> ([Key] -> ShowS) -> Show Key
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Key -> ShowS
showsPrec :: Int -> Key -> ShowS
$cshow :: Key -> String
show :: Key -> String
$cshowList :: [Key] -> ShowS
showList :: [Key] -> ShowS
Show, Key -> Key -> Bool
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
/= :: Key -> Key -> Bool
Eq, String -> Key
(String -> Key) -> IsString Key
forall a. (String -> a) -> IsString a
$cfromString :: String -> Key
fromString :: String -> Key
IsString, Key -> Mail
(Key -> Mail) -> ToJSON Key
forall a. (a -> Mail) -> ToJSON a
$ctoJSON :: Key -> Mail
toJSON :: Key -> Mail
ToJSON, Key -> MisoString
(Key -> MisoString) -> ToMisoString Key
forall str. (str -> MisoString) -> ToMisoString str
$ctoMisoString :: Key -> MisoString
toMisoString :: Key -> MisoString
ToMisoString)
-----------------------------------------------------------------------------
-- | ToJSVal instance for t'Key'
instance ToJSVal Key where
  toJSVal :: Key -> IO JSVal
toJSVal (Key MisoString
x) = MisoString -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal MisoString
x
-----------------------------------------------------------------------------
-- | Convert custom key types to t'Key'.
--
-- Instances of this class do not have to guarantee uniqueness of the
-- generated keys, it is up to the user to do so. @toKey@ must be an
-- injective function (different inputs must map to different outputs).
class ToKey key where
  -- | Converts any key into t'Key'
  toKey :: key -> Key
-----------------------------------------------------------------------------
-- | Identity instance
instance ToKey Key where toKey :: Key -> Key
toKey = Key -> Key
forall a. a -> a
id
-----------------------------------------------------------------------------
#ifndef VANILLA
-- | Convert 'MisoString' to t'Key'
instance ToKey MisoString where toKey = Key
#endif
-----------------------------------------------------------------------------
-- | Convert 'T.Text' to t'Key'
instance ToKey T.Text where toKey :: MisoString -> Key
toKey = MisoString -> Key
Key (MisoString -> Key)
-> (MisoString -> MisoString) -> MisoString -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString
-----------------------------------------------------------------------------
-- | Convert 'String' to t'Key'
instance ToKey String where toKey :: String -> Key
toKey = MisoString -> Key
Key (MisoString -> Key) -> (String -> MisoString) -> String -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString
-----------------------------------------------------------------------------
-- | Convert 'Int' to t'Key'
instance ToKey Int where toKey :: Int -> Key
toKey = MisoString -> Key
Key (MisoString -> Key) -> (Int -> MisoString) -> Int -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString
-----------------------------------------------------------------------------
-- | Convert 'Double' to t'Key'
instance ToKey Double where toKey :: Double -> Key
toKey = MisoString -> Key
Key (MisoString -> Key) -> (Double -> MisoString) -> Double -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString
-----------------------------------------------------------------------------
-- | Convert 'Float' to t'Key'
instance ToKey Float where toKey :: Float -> Key
toKey = MisoString -> Key
Key (MisoString -> Key) -> (Float -> MisoString) -> Float -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString
-----------------------------------------------------------------------------
-- | Convert 'Word' to t'Key'
instance ToKey Word where toKey :: Word -> Key
toKey = MisoString -> Key
Key (MisoString -> Key) -> (Word -> MisoString) -> Word -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString
-----------------------------------------------------------------------------
-- | Attribute of a vnode in a t'View'.
--
data Attribute action
  = Property MisoString Value
  | ClassList [MisoString]
  | On (Sink action -> VTree -> LogLevel -> Events -> IO ())
  -- ^ The @Sink@ callback can be used to dispatch actions which are fed back to
  -- the @update@ function. This is especially useful for event handlers
  -- like the @onclick@ attribute. The second argument represents the
  -- vnode the attribute is attached to.
  | Styles (M.Map MisoString MisoString)
  deriving (forall a b. (a -> b) -> Attribute a -> Attribute b)
-> (forall a b. a -> Attribute b -> Attribute a)
-> Functor Attribute
forall a b. a -> Attribute b -> Attribute a
forall a b. (a -> b) -> Attribute a -> Attribute b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Attribute a -> Attribute b
fmap :: forall a b. (a -> b) -> Attribute a -> Attribute b
$c<$ :: forall a b. a -> Attribute b -> Attribute a
<$ :: forall a b. a -> Attribute b -> Attribute a
Functor
-----------------------------------------------------------------------------
instance Eq (Attribute action) where
  Property MisoString
k1 Mail
v1 == :: Attribute action -> Attribute action -> Bool
== Property MisoString
k2 Mail
v2 = MisoString
k1 MisoString -> MisoString -> Bool
forall a. Eq a => a -> a -> Bool
== MisoString
k2 Bool -> Bool -> Bool
&& Mail
v1 Mail -> Mail -> Bool
forall a. Eq a => a -> a -> Bool
== Mail
v2
  ClassList [MisoString]
x == ClassList [MisoString]
y = [MisoString]
x [MisoString] -> [MisoString] -> Bool
forall a. Eq a => a -> a -> Bool
== [MisoString]
y
  Styles Map MisoString MisoString
x == Styles Map MisoString MisoString
y = Map MisoString MisoString
x Map MisoString MisoString -> Map MisoString MisoString -> Bool
forall a. Eq a => a -> a -> Bool
== Map MisoString MisoString
y
  Attribute action
_ == Attribute action
_ = Bool
False
-----------------------------------------------------------------------------
instance Show (Attribute action) where
  show :: Attribute action -> String
show = \case
    Property MisoString
key Mail
value ->
      MisoString -> String
MS.unpack MisoString
key String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> MisoString -> String
MS.unpack (MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Mail -> MisoString
forall a. ToJSON a => a -> MisoString
encode Mail
value))
    ClassList [MisoString]
classes ->
      MisoString -> String
MS.unpack (MisoString -> [MisoString] -> MisoString
MS.intercalate MisoString
" " [MisoString]
classes)
    On Sink action -> VTree -> LogLevel -> Events -> IO ()
_ ->
      String
"<event-handler>"
    Styles Map MisoString MisoString
styles ->
      MisoString -> String
MS.unpack (MisoString -> String) -> MisoString -> String
forall a b. (a -> b) -> a -> b
$ [MisoString] -> MisoString
MS.concat
        [ MisoString
k MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"=" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
v MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
";"
        | (MisoString
k, MisoString
v) <- Map MisoString MisoString -> [(MisoString, MisoString)]
forall k a. Map k a -> [(k, a)]
M.toList Map MisoString MisoString
styles
        ]
-----------------------------------------------------------------------------
-- | 'IsString' instance
instance IsString (View model action) where
  fromString :: String -> View model action
fromString = Maybe Key -> MisoString -> View model action
forall model action. Maybe Key -> MisoString -> View model action
VText Maybe Key
forall a. Maybe a
Nothing (MisoString -> View model action)
-> (String -> MisoString) -> String -> View model action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MisoString
forall a. IsString a => String -> a
fromString
-----------------------------------------------------------------------------
-- | Virtual DOM implemented as a JavaScript t'Object'.
--   Used for diffing, patching and event delegation.
--   Not meant to be constructed directly, see t'Miso.Types.View' instead.
newtype VTree = VTree { VTree -> Object
getTree :: Object }
  deriving newtype (VTree -> IO Object
(VTree -> IO Object) -> ToObject VTree
forall a. (a -> IO Object) -> ToObject a
$ctoObject :: VTree -> IO Object
toObject :: VTree -> IO Object
ToObject, VTree -> IO JSVal
(VTree -> IO JSVal) -> ToJSVal VTree
forall a. (a -> IO JSVal) -> ToJSVal a
$ctoJSVal :: VTree -> IO JSVal
toJSVal :: VTree -> IO JSVal
ToJSVal)
-----------------------------------------------------------------------------
-- | Create a new 'Miso.Types.VNode'.
--
-- @node ns tag attrs children@ creates a new node with tag @tag@
-- in the namespace @ns@. All @attrs@ are called when
-- the node is created and its children are initialized to @children@.
node
  :: NS
  -> MisoString
  -> [Attribute action]
  -> [View model action]
  -> View model action
node :: forall action model.
NS
-> MisoString
-> [Attribute action]
-> [View model action]
-> View model action
node = NS
-> MisoString
-> [Attribute action]
-> [View model action]
-> View model action
forall model action.
NS
-> MisoString
-> [Attribute action]
-> [View model action]
-> View model action
VNode
-----------------------------------------------------------------------------
-- | Create a new v'VText' with the given content.
text :: MisoString -> View model action
#ifdef SSR
text = VText Nothing . htmlEncode
#else
text :: forall model action. MisoString -> View model action
text = Maybe Key -> MisoString -> View model action
forall model action. Maybe Key -> MisoString -> View model action
VText Maybe Key
forall a. Maybe a
Nothing
#endif
----------------------------------------------------------------------------
-- | Create a new v'VText', not subject to HTML escaping.
--
-- Like 'text', except will not escape HTML when used on the server.
--
textRaw :: MisoString -> View model action
textRaw :: forall model action. MisoString -> View model action
textRaw = Maybe Key -> MisoString -> View model action
forall model action. Maybe Key -> MisoString -> View model action
VText Maybe Key
forall a. Maybe a
Nothing
----------------------------------------------------------------------------
-- |
-- HTML-encodes text.
--
-- Useful for escaping HTML when delivering on the server. Naive usage
-- of 'text' will ensure this as well.
--
-- >>> Data.Text.IO.putStrLn $ text "<a href=\"\">"
-- &lt;a href=&quot;&quot;&gt;
htmlEncode :: MisoString -> MisoString
htmlEncode :: MisoString -> MisoString
htmlEncode = (Char -> MisoString) -> MisoString -> MisoString
MS.concatMap ((Char -> MisoString) -> MisoString -> MisoString)
-> (Char -> MisoString) -> MisoString -> MisoString
forall a b. (a -> b) -> a -> b
$ \case
  Char
'<' -> MisoString
"&lt;"
  Char
'>' -> MisoString
"&gt;"
  Char
'&' -> MisoString
"&amp;"
  Char
'"' -> MisoString
"&quot;"
  Char
'\'' -> MisoString
"&#39;"
  Char
x -> Char -> MisoString
MS.singleton Char
x
-----------------------------------------------------------------------------
-- | Create a new v'VText' containing concatenation of the given strings.
--
-- @
--   view :: View model action
--   view = div_
--     [ className "container" ]
--     [ text_
--       [ "foo"
--       , "bar"
--       ]
--     ]
-- @
--
-- Renders as @<div class="container">foo bar</div>@
--
-- A single additional space is added between elements.
--
text_ :: [MisoString] -> View model action
text_ :: forall model action. [MisoString] -> View model action
text_ = Maybe Key -> MisoString -> View model action
forall model action. Maybe Key -> MisoString -> View model action
VText Maybe Key
forall a. Maybe a
Nothing (MisoString -> View model action)
-> ([MisoString] -> MisoString)
-> [MisoString]
-> View model action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> [MisoString] -> MisoString
MS.intercalate MisoString
" "
-----------------------------------------------------------------------------
-- | Like 'text', but allow the node to be keyed for efficient diffing.
--
-- @
-- view :: model -> View model action
-- view = \x -> div_ [] [ textKey (1 :: Int) "text here" ]
-- @
--
-- @since 1.9.0.0
textKey :: ToKey key => key -> MisoString -> View model action
textKey :: forall key model action.
ToKey key =>
key -> MisoString -> View model action
textKey key
k = Maybe Key -> MisoString -> View model action
forall model action. Maybe Key -> MisoString -> View model action
VText (Key -> Maybe Key
forall a. a -> Maybe a
Just (key -> Key
forall key. ToKey key => key -> Key
toKey key
k))
-----------------------------------------------------------------------------
-- | Like 'text_', but allow the node to be keyed for efficient diffing.
--
-- @
-- view :: model -> View model action
-- view = \x -> div_ [] [ textKey_ (1 :: Int) [ "text", "goes", "here" ] ]
-- @
--
-- @since 1.9.0.0
textKey_ :: ToKey key => key -> [MisoString] -> View model action
textKey_ :: forall key model action.
ToKey key =>
key -> [MisoString] -> View model action
textKey_ key
k [MisoString]
xs = Maybe Key -> MisoString -> View model action
forall model action. Maybe Key -> MisoString -> View model action
VText (Key -> Maybe Key
forall a. a -> Maybe a
Just (key -> Key
forall key. ToKey key => key -> Key
toKey key
k)) (MisoString -> [MisoString] -> MisoString
MS.intercalate MisoString
" " [MisoString]
xs)
-----------------------------------------------------------------------------
-- | Utility function to make it easy to specify conditional attributes
--
-- @
-- view :: Bool -> View model action
-- view danger = optionalAttrs textarea_ [ id_ "txt" ] danger [ class_ "danger" ] ["child"]
-- @
--
-- @since 1.9.0.0
optionalAttrs
  :: ([Attribute action] -> [View model action] -> View model action)
  -> [Attribute action] -- ^ Attributes to be added unconditionally
  -> Bool -- ^ A condition
  -> [Attribute action] -- ^ Additional attributes to add if the condition is True
  -> [View model action] -- ^ Children
  -> View model action
optionalAttrs :: forall action model.
([Attribute action] -> [View model action] -> View model action)
-> [Attribute action]
-> Bool
-> [Attribute action]
-> [View model action]
-> View model action
optionalAttrs [Attribute action] -> [View model action] -> View model action
element [Attribute action]
attrs Bool
condition [Attribute action]
opts [View model action]
kids =
  case [Attribute action] -> [View model action] -> View model action
element [Attribute action]
attrs [View model action]
kids of
    VNode NS
ns MisoString
name [Attribute action]
_ [View model action]
_ -> do
      let newAttrs :: [Attribute action]
newAttrs = [[Attribute action]] -> [Attribute action]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Attribute action]
opts | Bool
condition ] [Attribute action] -> [Attribute action] -> [Attribute action]
forall a. [a] -> [a] -> [a]
++ [Attribute action]
attrs
      NS
-> MisoString
-> [Attribute action]
-> [View model action]
-> View model action
forall model action.
NS
-> MisoString
-> [Attribute action]
-> [View model action]
-> View model action
VNode NS
ns MisoString
name [Attribute action]
newAttrs [View model action]
kids
    View model action
x -> View model action
x
----------------------------------------------------------------------------
-- | Conditionally adds children.
--
-- @
-- view :: Bool -> View model action
-- view withChild = optionalChildren div_ [ id_ "txt" ] [] withChild [ "foo" ]
-- @
--
-- @since 1.9.0.0
optionalChildren
  :: ([Attribute action] -> [View model action] -> View model action)
  -> [Attribute action] -- ^ Attributes to be added unconditionally
  -> [View model action] -- ^ Children to be added unconditionally
  -> Bool -- ^ A condition
  -> [View model action] -- ^ Additional children to add if the condition is True
  -> View model action
optionalChildren :: forall action model.
([Attribute action] -> [View model action] -> View model action)
-> [Attribute action]
-> [View model action]
-> Bool
-> [View model action]
-> View model action
optionalChildren [Attribute action] -> [View model action] -> View model action
element [Attribute action]
attrs [View model action]
kids Bool
condition [View model action]
opts =
  case [Attribute action] -> [View model action] -> View model action
element [Attribute action]
attrs [View model action]
kids of
    VNode NS
ns MisoString
name [Attribute action]
_ [View model action]
_ -> do
      let newKids :: [View model action]
newKids = [View model action]
kids [View model action] -> [View model action] -> [View model action]
forall a. [a] -> [a] -> [a]
++ [[View model action]] -> [View model action]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [View model action]
opts | Bool
condition ]
      NS
-> MisoString
-> [Attribute action]
-> [View model action]
-> View model action
forall model action.
NS
-> MisoString
-> [Attribute action]
-> [View model action]
-> View model action
VNode NS
ns MisoString
name [Attribute action]
attrs [View model action]
newKids
    View model action
x -> View model action
x
----------------------------------------------------------------------------
-- | URI type. See the official [specification](https://www.rfc-editor.org/rfc/rfc3986)
--
data URI
  = URI
  { URI -> MisoString
uriPath, URI -> MisoString
uriFragment :: MisoString
  , URI -> Map MisoString (Maybe MisoString)
uriQueryString :: M.Map MisoString (Maybe MisoString)
  } deriving stock (Int -> URI -> ShowS
[URI] -> ShowS
URI -> String
(Int -> URI -> ShowS)
-> (URI -> String) -> ([URI] -> ShowS) -> Show URI
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> URI -> ShowS
showsPrec :: Int -> URI -> ShowS
$cshow :: URI -> String
show :: URI -> String
$cshowList :: [URI] -> ShowS
showList :: [URI] -> ShowS
Show, URI -> URI -> Bool
(URI -> URI -> Bool) -> (URI -> URI -> Bool) -> Eq URI
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: URI -> URI -> Bool
== :: URI -> URI -> Bool
$c/= :: URI -> URI -> Bool
/= :: URI -> URI -> Bool
Eq, (forall x. URI -> Rep URI x)
-> (forall x. Rep URI x -> URI) -> Generic URI
forall x. Rep URI x -> URI
forall x. URI -> Rep URI x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. URI -> Rep URI x
from :: forall x. URI -> Rep URI x
$cto :: forall x. Rep URI x -> URI
to :: forall x. Rep URI x -> URI
Generic)
    deriving anyclass (URI -> IO JSVal
(URI -> IO JSVal) -> ToJSVal URI
forall a. (a -> IO JSVal) -> ToJSVal a
$ctoJSVal :: URI -> IO JSVal
toJSVal :: URI -> IO JSVal
ToJSVal, URI -> IO Object
(URI -> IO Object) -> ToObject URI
forall a. (a -> IO Object) -> ToObject a
$ctoObject :: URI -> IO Object
toObject :: URI -> IO Object
ToObject)
----------------------------------------------------------------------------
-- | Empty t'URI'.
emptyURI :: URI
emptyURI :: URI
emptyURI = MisoString
-> MisoString -> Map MisoString (Maybe MisoString) -> URI
URI MisoString
forall a. Monoid a => a
mempty MisoString
forall a. Monoid a => a
mempty Map MisoString (Maybe MisoString)
forall a. Monoid a => a
mempty
----------------------------------------------------------------------------
instance ToMisoString URI where
  toMisoString :: URI -> MisoString
toMisoString = URI -> MisoString
prettyURI
----------------------------------------------------------------------------
-- | Pretty-prints a t'URI'.
prettyURI :: URI -> MisoString
prettyURI :: URI -> MisoString
prettyURI uri :: URI
uri@URI {Map MisoString (Maybe MisoString)
MisoString
uriPath :: URI -> MisoString
uriFragment :: URI -> MisoString
uriQueryString :: URI -> Map MisoString (Maybe MisoString)
uriPath :: MisoString
uriFragment :: MisoString
uriQueryString :: Map MisoString (Maybe MisoString)
..} = MisoString
"/" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
uriPath MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> URI -> MisoString
prettyQueryString URI
uri MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
uriFragment
-----------------------------------------------------------------------------
-- | Pretty-prints a t'URI' query string.
prettyQueryString :: URI -> MisoString
prettyQueryString :: URI -> MisoString
prettyQueryString URI {Map MisoString (Maybe MisoString)
MisoString
uriPath :: URI -> MisoString
uriFragment :: URI -> MisoString
uriQueryString :: URI -> Map MisoString (Maybe MisoString)
uriPath :: MisoString
uriFragment :: MisoString
uriQueryString :: Map MisoString (Maybe MisoString)
..} = MisoString
queries MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
flags
  where
    queries :: MisoString
queries =
      [MisoString] -> MisoString
MS.concat
      [ MisoString
"?" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<>
        MisoString -> [MisoString] -> MisoString
MS.intercalate MisoString
"&"
        [ MisoString
k MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"=" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
v
        | (MisoString
k, Just MisoString
v) <- Map MisoString (Maybe MisoString)
-> [(MisoString, Maybe MisoString)]
forall k a. Map k a -> [(k, a)]
M.toList Map MisoString (Maybe MisoString)
uriQueryString
        ]
      | (Maybe MisoString -> Bool) -> [Maybe MisoString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe MisoString -> Bool
forall a. Maybe a -> Bool
isJust (Map MisoString (Maybe MisoString) -> [Maybe MisoString]
forall k a. Map k a -> [a]
M.elems Map MisoString (Maybe MisoString)
uriQueryString)
      ]
    flags :: MisoString
flags = [MisoString] -> MisoString
forall a. Monoid a => [a] -> a
mconcat
        [ MisoString
"?" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
k
        | (MisoString
k, Maybe MisoString
Nothing) <- Map MisoString (Maybe MisoString)
-> [(MisoString, Maybe MisoString)]
forall k a. Map k a -> [(k, a)]
M.toList Map MisoString (Maybe MisoString)
uriQueryString
        ]
-----------------------------------------------------------------------------
-- | VTreeType ADT for matching TypeScript enum
data VTreeType
  = VCompType
  | VNodeType
  | VTextType
  deriving (Int -> VTreeType -> ShowS
[VTreeType] -> ShowS
VTreeType -> String
(Int -> VTreeType -> ShowS)
-> (VTreeType -> String)
-> ([VTreeType] -> ShowS)
-> Show VTreeType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VTreeType -> ShowS
showsPrec :: Int -> VTreeType -> ShowS
$cshow :: VTreeType -> String
show :: VTreeType -> String
$cshowList :: [VTreeType] -> ShowS
showList :: [VTreeType] -> ShowS
Show, VTreeType -> VTreeType -> Bool
(VTreeType -> VTreeType -> Bool)
-> (VTreeType -> VTreeType -> Bool) -> Eq VTreeType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VTreeType -> VTreeType -> Bool
== :: VTreeType -> VTreeType -> Bool
$c/= :: VTreeType -> VTreeType -> Bool
/= :: VTreeType -> VTreeType -> Bool
Eq)
-----------------------------------------------------------------------------
instance ToJSVal VTreeType where
  toJSVal :: VTreeType -> IO JSVal
toJSVal = \case 
    VTreeType
VCompType -> Int -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (Int
0 :: Int)
    VTreeType
VNodeType -> Int -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (Int
1 :: Int)
    VTreeType
VTextType -> Int -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (Int
2 :: Int)
-----------------------------------------------------------------------------