-----------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE DataKinds                  #-}
-----------------------------------------------------------------------------
-- |
-- 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
----------------------------------------------------------------------------
module Miso.Types
  ( -- ** Types
    Component        (..)
  , SomeComponent    (..)
  , Dynamic
  , View             (..)
  , Key              (..)
  , Attribute        (..)
  , NS               (..)
  , CSS              (..)
  , LogLevel         (..)
  , MountPoint
  -- ** Classes
  , ToView           (..)
  , ToKey            (..)
  -- ** Smart Constructors
  , defaultComponent
  -- ** Components
  , component_
  -- ** Utils
  , getMountPoint
  ) where
-----------------------------------------------------------------------------
import           Data.Aeson (Value, ToJSON)
import           Data.JSString (JSString)
import           Data.Kind (Type)
import qualified Data.Map.Strict as M
import           Data.Maybe (fromMaybe)
import           Data.String (IsString, fromString)
import qualified Data.Text as T
import           Data.Proxy (Proxy(Proxy))
import           Language.Javascript.JSaddle (ToJSVal(toJSVal), Object, JSM)
import           Prelude hiding (null)
import           GHC.TypeLits (KnownSymbol, symbolVal, Symbol)
import           Servant.API (HasLink(MkLink, toLink))
-----------------------------------------------------------------------------
import           Miso.Effect (Effect, Sub, Sink)
import           Miso.Event.Types
import           Miso.String (MisoString, toMisoString, ms)
-----------------------------------------------------------------------------
-- | Application entry point
data Component (name :: Symbol) model action = Component
  { forall (name :: Symbol) model action.
Component name model action -> model
model :: model
  -- ^ initial model
  , forall (name :: Symbol) model action.
Component name model action -> action -> Effect model action
update :: action -> Effect model action
  -- ^ Function to update model, optionally providing effects.
  , forall (name :: Symbol) model action.
Component name model action -> model -> View action
view :: model -> View action
  -- ^ Function to draw `View`
  , forall (name :: Symbol) model action.
Component name model action -> [Sub action]
subs :: [ Sub action ]
  -- ^ List of subscriptions to run during application lifetime
  , forall (name :: Symbol) model action.
Component name model action -> Events
events :: Events
  -- ^ List of delegated events that the body element will listen for.
  --   You can start with 'Miso.Event.Types.defaultEvents' and modify as needed.
  , forall (name :: Symbol) model action.
Component name model action -> [CSS]
styles :: [CSS]
  -- ^ List of 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 (name :: Symbol) model action.
Component name model action -> Maybe action
initialAction :: Maybe action
  -- ^ Initial action that is run after the application has loaded, optional
  --
  -- @since 1.9.0.0
  , forall (name :: Symbol) model action.
Component name 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 (name :: Symbol) model action.
Component name model action -> LogLevel
logLevel :: LogLevel
  -- ^ Debugging for prerendering and event delegation
  }
-----------------------------------------------------------------------------
-- | @mountPoint@ for @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
--
data CSS
  = Href MisoString
  -- ^ 'Href' is a URL meant to link to hosted CSS
  | Style MisoString
  -- ^ 'Style' is meant to be raw CSS in a 'style_' tag
  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)
-----------------------------------------------------------------------------
-- | 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 @Component@ with sane defaults.
defaultComponent
  :: model
  -> (action -> Effect model action)
  -> (model -> View action)
  -> Component name model action
defaultComponent :: forall model action (name :: Symbol).
model
-> (action -> Effect model action)
-> (model -> View action)
-> Component name model action
defaultComponent model
m action -> Effect model action
u model -> View action
v = Component
  { model :: model
model = model
m
  , update :: action -> Effect model action
update = action -> Effect model action
u
  , view :: model -> View action
view = model -> View action
v
  , subs :: [Sub action]
subs = []
  , events :: Events
events = Events
defaultEvents
  , styles :: [CSS]
styles = []
  , 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
  }
-----------------------------------------------------------------------------
-- | Optional Logging for debugging miso internals (useful to see if prerendering is successful)
data LogLevel
  = Off
  -- ^ No debug logging, the default value used in @defaultComponent@
  | 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.
  | DebugNotify
  -- ^ Will warn if a @Component@ can't be found when using @notify@ or @notify'@
  | 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 action
  = VNode NS MisoString [Attribute action] [View action]
  | VText MisoString
  | VTextRaw MisoString
  | VComp MisoString [Attribute action] SomeComponent
  deriving (forall a b. (a -> b) -> View a -> View b)
-> (forall a b. a -> View b -> View a) -> Functor View
forall a b. a -> View b -> View a
forall a b. (a -> b) -> View a -> View 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) -> View a -> View b
fmap :: forall a b. (a -> b) -> View a -> View b
$c<$ :: forall a b. a -> View b -> View a
<$ :: forall a b. a -> View b -> View a
Functor
-----------------------------------------------------------------------------
-- | Existential wrapper used to allow the nesting of @Component@ in @Component@
data SomeComponent
   = forall name model action . Eq model
  => SomeComponent (Component name model action)
-----------------------------------------------------------------------------
-- | Used in the @view@ function to embed an @Component@ into another @Component@
-- Use this function if you'd like send messages to this @Component@ at @name@ via
-- @notify@ or to read the state of this @Component@ via @sample@.
component_
  :: forall name model action a . (Eq model, KnownSymbol name)
  => Component name model action
  -> [Attribute a]
  -> View a
component_ :: forall (name :: Symbol) model action a.
(Eq model, KnownSymbol name) =>
Component name model action -> [Attribute a] -> View a
component_ Component name model action
app [Attribute a]
attrs = MisoString -> [Attribute a] -> SomeComponent -> View a
forall action.
MisoString -> [Attribute action] -> SomeComponent -> View action
VComp (String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms String
name) [Attribute a]
attrs (Component name model action -> SomeComponent
forall (name :: Symbol) model action.
Eq model =>
Component name model action -> SomeComponent
SomeComponent Component name model action
app)
  where
    name :: String
name = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)
-----------------------------------------------------------------------------
-- | Type synonym for Dynamically constructed @Component@
-- @
-- sampleComponent :: Component Dynamic Model Action
-- @
type Dynamic = ""
-----------------------------------------------------------------------------
-- | For constructing type-safe links
instance HasLink (View a) where
  type MkLink (View a) b = b
  toLink :: forall a.
(Link -> a) -> Proxy (View a) -> Link -> MkLink (View a) a
toLink Link -> a
x Proxy (View a)
_ = Link -> a
Link -> MkLink (View a) a
x
-----------------------------------------------------------------------------
-- | Convenience class for using View
class ToView a where
  type ToViewAction a :: Type
  toView :: a -> View (ToViewAction a)
-----------------------------------------------------------------------------
instance ToView (View action) where
  type ToViewAction (View action) = action
  toView :: View action -> View (ToViewAction (View action))
toView = View action -> View action
View action -> View (ToViewAction (View action))
forall a. a -> a
id
-----------------------------------------------------------------------------
instance ToView (Component name model action) where
  type ToViewAction (Component name model action) = action
  toView :: Component name model action
-> View (ToViewAction (Component name model action))
toView Component {model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
model :: forall (name :: Symbol) model action.
Component name model action -> model
update :: forall (name :: Symbol) model action.
Component name model action -> action -> Effect model action
view :: forall (name :: Symbol) model action.
Component name model action -> model -> View action
subs :: forall (name :: Symbol) model action.
Component name model action -> [Sub action]
events :: forall (name :: Symbol) model action.
Component name model action -> Events
styles :: forall (name :: Symbol) model action.
Component name model action -> [CSS]
initialAction :: forall (name :: Symbol) model action.
Component name model action -> Maybe action
mountPoint :: forall (name :: Symbol) model action.
Component name model action -> Maybe MisoString
logLevel :: forall (name :: Symbol) model action.
Component name model action -> LogLevel
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Events
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
..} = View action -> View (ToViewAction (View action))
forall a. ToView a => a -> View (ToViewAction a)
toView (model -> View action
view model
model)
-----------------------------------------------------------------------------
-- | Namespace of DOM elements.
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 -> JSM JSVal
toJSVal NS
SVG  = JSString -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal (JSString
"svg" :: JSString)
  toJSVal NS
HTML = JSString -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal (JSString
"html" :: JSString)
  toJSVal NS
MATHML = JSString -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal (JSString
"mathml" :: JSString)
-----------------------------------------------------------------------------
-- | A 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 (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] -> Value
[Key] -> Encoding
Key -> Bool
Key -> Value
Key -> Encoding
(Key -> Value)
-> (Key -> Encoding)
-> ([Key] -> Value)
-> ([Key] -> Encoding)
-> (Key -> Bool)
-> ToJSON Key
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Key -> Value
toJSON :: Key -> Value
$ctoEncoding :: Key -> Encoding
toEncoding :: Key -> Encoding
$ctoJSONList :: [Key] -> Value
toJSONList :: [Key] -> Value
$ctoEncodingList :: [Key] -> Encoding
toEncodingList :: [Key] -> Encoding
$comitField :: Key -> Bool
omitField :: Key -> Bool
ToJSON)
-----------------------------------------------------------------------------
-- | ToJSVal instance for Key
instance ToJSVal Key where
  toJSVal :: Key -> JSM JSVal
toJSVal (Key MisoString
x) = MisoString -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal MisoString
x
-----------------------------------------------------------------------------
-- | Convert custom key types to @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.
class ToKey key where
  -- | Converts any key into @Key@
  toKey :: key -> Key
-----------------------------------------------------------------------------
-- | Identity instance
instance ToKey Key where toKey :: Key -> Key
toKey = Key -> Key
forall a. a -> a
id
-----------------------------------------------------------------------------
-- | Convert @MisoString@ to @Key@
instance ToKey JSString where toKey :: JSString -> Key
toKey = MisoString -> Key
Key (MisoString -> Key) -> (JSString -> MisoString) -> JSString -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString
-----------------------------------------------------------------------------
-- | Convert @T.Text@ to @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 @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 @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 @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 @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 @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 @View@.
--
-- 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.
data Attribute action
  = Property MisoString Value
  | Event (Sink action -> Object -> LogLevel -> Events -> JSM ())
  | 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
-----------------------------------------------------------------------------
-- | @IsString@ instance
instance IsString (View a) where
  fromString :: String -> View a
fromString = MisoString -> View a
forall action. MisoString -> View action
VText (MisoString -> View a)
-> (String -> MisoString) -> String -> View a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MisoString
forall a. IsString a => String -> a
fromString
-----------------------------------------------------------------------------