-----------------------------------------------------------------------------
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Internal
-- 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.Internal
  ( initialize
  , componentMap
  , sink
  , notify
  , runView
  , sample
  , renderStyles
  , Prerender(..)
  ) where
-----------------------------------------------------------------------------
import           Control.Exception (throwIO)
import           Control.Concurrent (ThreadId, killThread)
import           Control.Monad (forM, forM_, when, void)
import           Control.Monad.IO.Class
import qualified Data.Aeson as A
import           Data.Foldable (toList)
import           Data.IORef (IORef, newIORef, atomicModifyIORef', readIORef, atomicWriteIORef, modifyIORef')
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import qualified Data.Sequence as S
import           Data.Sequence (Seq)
import qualified JavaScript.Array as JSArray
import           Language.Javascript.JSaddle
import           Prelude hiding (null)
import           System.IO.Unsafe (unsafePerformIO)
import           System.Mem.StableName (makeStableName)
import           Text.HTML.TagSoup (Tag(..))
import           Text.HTML.TagSoup.Tree (parseTree, TagTree(..))
-----------------------------------------------------------------------------
import           Miso.Concurrent (Waiter(..), waiter)
import           Miso.Delegate (delegator, undelegator)
import           Miso.Diff (diff)
import           Miso.Exception (MisoException(..), exception)
import qualified Miso.FFI.Internal as FFI
import           Miso.Html hiding (on)
import           Miso.String hiding (reverse)
import           Miso.Types hiding (componentName)
import           Miso.Event (Events)
import           Miso.Effect (Sink, Effect, runEffect)
-----------------------------------------------------------------------------
-- | Helper function to abstract out initialization of @App@ between top-level API functions.
initialize
  :: Eq model
  => App model action
  -> (Sink action -> JSM (MisoString, JSVal, IORef VTree))
  -- ^ Callback function is used to perform the creation of VTree
  -> JSM (IORef VTree)
initialize App {..} getView = do
  Waiter {..} <- liftIO waiter
  componentActions <- liftIO (newIORef S.empty)
  let
    componentSink = \action -> liftIO $ do
      atomicModifyIORef' componentActions $ \actions -> (actions S.|> action, ())
      serve
  componentSubThreads <- forM subs $ \sub -> FFI.forkJSM (sub componentSink)
  (componentName, componentMount, componentVTree) <- getView componentSink
  componentModel <- liftIO (newIORef model)
  let
    eventLoop !oldModel = liftIO wait >> do
      as <- liftIO $ atomicModifyIORef' componentActions $ \actions -> (S.empty, actions)
      newModel <- foldEffects update componentSink (toList as) oldModel
      oldName <- liftIO $ oldModel `seq` makeStableName oldModel
      newName <- liftIO $ newModel `seq` makeStableName newModel
      when (oldName /= newName && oldModel /= newModel) $ do
        newVTree <- runView DontPrerender (view newModel) componentSink logLevel events
        oldVTree <- liftIO (readIORef componentVTree)
        void waitForAnimationFrame
        diff componentMount (Just oldVTree) (Just newVTree)
        liftIO $ do
          atomicWriteIORef componentVTree newVTree
          atomicWriteIORef componentModel newModel
      syncPoint
      eventLoop newModel
  _ <- FFI.forkJSM (eventLoop model)
  registerComponent ComponentState {..}
  delegator componentMount componentVTree events (logLevel `elem` [DebugEvents, DebugAll])
  forM_ initialAction componentSink
  pure componentVTree
-----------------------------------------------------------------------------
-- | Prerender avoids calling @diff@
-- and instead calls @hydrate@
data Prerender
  = DontPrerender
  | Prerender
  deriving (Show, Eq)
-----------------------------------------------------------------------------
-- | @Component@ state, data associated with the lifetime of a @Component@
data ComponentState model action
  = ComponentState
  { componentName       :: MisoString
  , componentSubThreads :: [ThreadId]
  , componentMount      :: JSVal
  , componentVTree      :: IORef VTree
  , componentSink       :: action -> JSM ()
  , componentModel      :: IORef model
  , componentActions    :: IORef (Seq action)
  }
-----------------------------------------------------------------------------
-- | componentMap
--
-- This is a global @Component@ @Map@ that holds the state of all currently
-- mounted @Component@s
componentMap :: IORef (Map MisoString (ComponentState model action))
{-# NOINLINE componentMap #-}
componentMap = unsafePerformIO (newIORef mempty)
-----------------------------------------------------------------------------
-- | Read-only access to another @Component@'s @model@.
-- This function is safe to use when a child @Component@ wishes access
-- a parent @Components@ @model@ state. Under this circumstance the parent
-- will always be mounted and available.
--
-- Otherwise, if a sibling or parent @Component@'s @model@ state is attempted
-- to be accessed. Then we throw a @NotMountedException@, in the case the
-- @Component@ being accessed is not available.
sample
  :: Component model action
  -> JSM model
sample (Component _ name _) = do
  componentStateMap <- liftIO (readIORef componentMap)
  liftIO $ case M.lookup name componentStateMap of
    Nothing -> throwIO (NotMountedException name)
    Just ComponentState {..} -> readIORef componentModel
-----------------------------------------------------------------------------
-- | Used for bidirectional communication between components.
-- Specify the mounted @Component@'s 'App' you'd like to target.
-- This function is used to send messages to @Component@s on other parts of the application
notify
  :: Component model action
  -> action
  -> JSM ()
notify (Component _ name _) action = io
  where
    io = do
      componentStateMap <- liftIO (readIORef componentMap)
      forM_ (M.lookup name componentStateMap) $ \ComponentState {..} ->
        componentSink action
-----------------------------------------------------------------------------
-- | Helper for processing effects in the event loop.
foldEffects
  :: (action -> Effect model action)
  -> Sink action
  -> [action]
  -> model
  -> JSM model
foldEffects _ _ [] m = pure m
foldEffects update snk (e:es) o =
  case runEffect o (update e) of
    (n, subs) -> do
      forM_ subs $ \sub ->
        sub snk `catch` (void . exception)
      foldEffects update snk es n
-----------------------------------------------------------------------------
-- | The sink function gives access to an @App@
-- @Sink@. This is use for third-party integration, or for
-- long-running @IO@ operations. Use at your own risk.
--
-- If the @Component@ or is not mounted, it does not exist
-- in the global component map, and will therefore be a no-op.
-- This is a backdoor function, caveat emptor.
--
-- It is recommended to use the @mail@ or @notify@ functions by default
-- when message passing with @App@ and @Component@
--
sink
  :: MisoString
  -> App model action
  -> Sink action
sink name _ = \a ->
  M.lookup name <$> liftIO (readIORef componentMap) >>= \case
    Just ComponentState {..} -> componentSink a
    Nothing -> pure ()
--------------------------------------------------
-- | Internally used for runView and startApp
-- Initial draw helper
-- If prerendering, bypass diff and continue copying
drawComponent
  :: Prerender
  -> MisoString
  -> App model action
  -> Sink action
  -> JSM (MisoString, JSVal, IORef VTree)
drawComponent prerender name App {..} snk = do
  vtree <- runView prerender (view model) snk logLevel events
  mountElement <- FFI.getComponent name
  when (prerender == DontPrerender) $ diff mountElement Nothing (Just vtree)
  ref <- liftIO (newIORef vtree)
  pure (name, mountElement, ref)
-----------------------------------------------------------------------------
-- | Drains the event queue before unmounting, executed synchronously
drain
  :: App model action
  -> ComponentState model action
  -> JSM ()
drain app@App{..} cs@ComponentState {..} = do
  actions <- liftIO $ atomicModifyIORef' componentActions $ \actions -> (S.empty, actions)
  if S.null actions then pure () else go actions
    where
      go as = do
        x <- liftIO (readIORef componentModel)
        y <- foldEffects update componentSink (toList as) x
        liftIO (atomicWriteIORef componentModel y)
        drain app cs
-----------------------------------------------------------------------------
-- | Helper function for cleanly destroying a @Component@
unmount
  :: Function
  -> App model action
  -> ComponentState model action
  -> JSM ()
unmount mountCallback app@App {..} cs@ComponentState {..} = do
  undelegator componentMount componentVTree events (logLevel `elem` [DebugEvents, DebugAll])
  freeFunction mountCallback
  liftIO (mapM_ killThread componentSubThreads)
  drain app cs
  liftIO $ modifyIORef' componentMap (M.delete componentName)
-----------------------------------------------------------------------------
-- | Internal function for construction of a Virtual DOM.
--
-- Component mounting should be synchronous.
-- Mounting causes a recursive diffing to occur
-- (creating sub components as detected), setting up
-- infrastructure for each sub-component. During this
-- process we go between the Haskell heap and the JS heap.
runView
  :: Prerender
  -> View action
  -> Sink action
  -> LogLevel
  -> Events
  -> JSM VTree
runView prerender (Embed attributes (SomeComponent (Component key mount app))) snk _ _ = do
  mountCallback <- do
    FFI.syncCallback1 $ \continuation -> do
      vtreeRef <- initialize app (drawComponent prerender mount app)
      VTree vtree <- liftIO (readIORef vtreeRef)
      void $ call continuation global [vtree]
  unmountCallback <- toJSVal =<< do
    FFI.syncCallback $ do
      M.lookup mount <$> liftIO (readIORef componentMap) >>= \case
        Nothing -> pure ()
        Just componentState ->
          unmount mountCallback app componentState
  vcomp <- createNode "vcomp" HTML key "div"
  setAttrs vcomp attributes snk (logLevel app) (events app)
  flip (FFI.set "children") vcomp =<< toJSVal ([] :: [MisoString])
  FFI.set "data-component-id" mount vcomp
  flip (FFI.set "mount") vcomp =<< toJSVal mountCallback
  FFI.set "unmount" unmountCallback vcomp
  pure (VTree vcomp)
runView prerender (Node ns tag key attrs kids) snk logLevel events = do
  vnode <- createNode "vnode" ns key tag
  setAttrs vnode attrs snk logLevel events
  vchildren <- ghcjsPure . jsval =<< procreate
  FFI.set "children" vchildren vnode
  sync <- FFI.shouldSync =<< toJSVal vnode
  FFI.set "shouldSync" sync vnode
  pure $ VTree vnode
    where
      procreate = do
        kidsViews <- forM kids $ \kid -> do
          VTree (Object vtree) <- runView prerender kid snk logLevel events
          pure vtree
        ghcjsPure (JSArray.fromList kidsViews)
runView _ (Text t) _ _ _ = do
  vtree <- create
  FFI.set "type" ("vtext" :: JSString) vtree
  FFI.set "ns" ("text" :: JSString) vtree
  FFI.set "text" t vtree
  pure $ VTree vtree
runView prerender (TextRaw str) snk logLevel events =
  case parseView str of
    [] ->
      runView prerender (Text (" " :: MisoString)) snk logLevel events
    [parent] ->
      runView prerender parent snk logLevel events
    kids -> do
      runView prerender (Node HTML "div" Nothing mempty kids) snk logLevel events
-----------------------------------------------------------------------------
-- | @createNode@
-- A helper function for constructing a vtree (used for 'vcomp' and 'vnode')
-- Doesn't handle children
createNode :: MisoString -> NS -> Maybe Key -> MisoString -> JSM Object
createNode typ ns key tag = do
  vnode <- create
  cssObj <- create
  propsObj <- create
  eventsObj <- create
  FFI.set "css" cssObj vnode
  FFI.set "type" typ vnode
  FFI.set "props" propsObj vnode
  FFI.set "events" eventsObj vnode
  FFI.set "ns" ns vnode
  FFI.set "tag" tag vnode
  FFI.set "key" key vnode
  pure vnode
-----------------------------------------------------------------------------
-- | Helper function for populating "props" and "css" fields on a virtual
-- DOM node
setAttrs
  :: Object
  -> [Attribute action]
  -> Sink action
  -> LogLevel
  -> Events
  -> JSM ()
setAttrs vnode attrs snk logLevel events =
  forM_ attrs $ \case
    Property k v -> do
      value <- toJSVal v
      o <- getProp "props" vnode
      FFI.set k value (Object o)
    Event attr -> attr snk vnode logLevel events
    Styles styles -> do
      cssObj <- getProp "css" vnode
      forM_ (M.toList styles) $ \(k,v) -> do
        FFI.set k v (Object cssObj)
-----------------------------------------------------------------------------
-- | Used to support RawText, inlining of HTML.
-- Filters tree to only branches and leaves w/ Text tags.
-- converts to View a. Note: if HTML is malformed,
-- (e.g. closing tags and opening tags are present) they will
-- be removed.
parseView :: MisoString -> [View a]
parseView html = reverse (go (parseTree html) [])
  where
    go [] xs = xs
    go (TagLeaf (TagText s) : next) views =
      go next (Text s : views)
    go (TagLeaf (TagOpen name attrs) : next) views =
      go (TagBranch name attrs [] : next) views
    go (TagBranch name attrs kids : next) views =
      let
        attrs' = [ Property key $ A.String (fromMisoString value)
                 | (key, value) <- attrs
                 ]
        newNode =
          Node HTML name Nothing attrs' (reverse (go kids []))
      in
        go next (newNode:views)
    go (TagLeaf _ : next) views =
      go next views
-----------------------------------------------------------------------------
-- | Registers components in the global state
registerComponent :: MonadIO m => ComponentState model action -> m ()
registerComponent componentState = liftIO
  $ modifyIORef' componentMap
  $ M.insert (componentName componentState) componentState
-----------------------------------------------------------------------------
-- | Registers components in the global state
renderStyles :: [CSS] -> JSM ()
renderStyles styles =
  forM_ styles $ \case
    Href url -> FFI.addStyleSheet url
    Style css -> FFI.addStyle css
-----------------------------------------------------------------------------