{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE KindSignatures      #-}

#ifdef IOS
#else
{-# LANGUAGE TemplateHaskell     #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso
-- Copyright   :  (C) 2016-2018 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
module Miso
  ( miso
  , startApp
  , module Miso.Effect
  , module Miso.Event
  , module Miso.Html
  , module Miso.Subscription
#ifndef __GHCJS__
  , module Miso.TypeLevel
#endif
  , module Miso.Types
  , module Miso.Router
  , module Miso.Util
  , module Miso.FFI
  , module Miso.WebSocket
  ) where

import           Control.Concurrent
import           Control.Monad
import           Control.Monad.IO.Class
import           Data.IORef
import           Data.List
import           Data.Sequence ((|>))
import           System.Mem.StableName
import qualified Data.Sequence as S
import qualified JavaScript.Object.Internal as OI

#ifndef __GHCJS__
import           Language.Javascript.JSaddle (eval, waitForAnimationFrame)
#ifdef IOS
import           Miso.JSBits
#else
import           GHCJS.Types (JSString)
import           Data.FileEmbed
#endif
#else
import           JavaScript.Web.AnimationFrame
#endif

import           Miso.Concurrent
import           Miso.Delegate
import           Miso.Diff
import           Miso.Effect
import           Miso.Event
import           Miso.FFI
import           Miso.Html
import           Miso.Router
import           Miso.Subscription
#ifndef __GHCJS__
import           Miso.TypeLevel
#endif
import           Miso.Types
import           Miso.Util
import           Miso.WebSocket

-- | Helper function to abstract out common functionality between `startApp` and `miso`
common
  :: Eq model
  => App model action
  -> model
  -> (Sink action -> JSM (IORef VTree))
  -> JSM ()
common :: App model action
-> model -> (Sink action -> JSM (IORef VTree)) -> JSM ()
common App {model
action
[Sub action]
Maybe MisoString
Map MisoString Bool
LogLevel
model -> View action
action -> model -> Effect action model
logLevel :: forall model action. App model action -> LogLevel
mountPoint :: forall model action. App model action -> Maybe MisoString
initialAction :: forall model action. App model action -> action
events :: forall model action. App model action -> Map MisoString Bool
subs :: forall model action. App model action -> [Sub action]
view :: forall model action. App model action -> model -> View action
update :: forall model action.
App model action -> action -> model -> Effect action model
model :: forall model action. App model action -> model
logLevel :: LogLevel
mountPoint :: Maybe MisoString
initialAction :: action
events :: Map MisoString Bool
subs :: [Sub action]
view :: model -> View action
update :: action -> model -> Effect action model
model :: model
..} model
m Sink action -> JSM (IORef VTree)
getView = do
#ifndef __GHCJS__
#ifdef IOS
  mapM_ eval [delegateJs,diffJs,isomorphicJs,utilJs]
#else
  JSVal
_ <- JSString -> JSM JSVal
forall script. ToJSString script => script -> JSM JSVal
eval ($(embedStringFile "jsbits/delegate.js") :: JSString)
  JSVal
_ <- JSString -> JSM JSVal
forall script. ToJSString script => script -> JSM JSVal
eval ($(embedStringFile "jsbits/diff.js") :: JSString)
  JSVal
_ <- JSString -> JSM JSVal
forall script. ToJSString script => script -> JSM JSVal
eval ($(embedStringFile "jsbits/isomorphic.js") :: JSString)
  JSVal
_ <- JSString -> JSM JSVal
forall script. ToJSString script => script -> JSM JSVal
eval ($(embedStringFile "jsbits/util.js") :: JSString)
#endif
#endif
  -- init Notifier
  Notify {IO ()
notify :: Notify -> IO ()
wait :: Notify -> IO ()
notify :: IO ()
wait :: IO ()
..} <- IO Notify -> JSM Notify
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Notify
newNotify
  -- init empty actions
  IORef (Seq action)
actionsRef <- IO (IORef (Seq action)) -> JSM (IORef (Seq action))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Seq action -> IO (IORef (Seq action))
forall a. a -> IO (IORef a)
newIORef Seq action
forall a. Seq a
S.empty)
  let writeEvent :: action -> f ()
writeEvent action
a = f ThreadId -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f ThreadId -> f ()) -> (IO () -> f ThreadId) -> IO () -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ThreadId -> f ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> f ThreadId)
-> (IO () -> IO ThreadId) -> IO () -> f ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> f ()) -> IO () -> f ()
forall a b. (a -> b) -> a -> b
$ do
        IORef (Seq action) -> (Seq action -> (Seq action, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Seq action)
actionsRef ((Seq action -> (Seq action, ())) -> IO ())
-> (Seq action -> (Seq action, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Seq action
as -> (Seq action
as Seq action -> action -> Seq action
forall a. Seq a -> a -> Seq a
|> action
a, ())
        IO ()
notify
  -- init Subs
  [Sub action] -> (Sub action -> JSM ()) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Sub action]
subs ((Sub action -> JSM ()) -> JSM ())
-> (Sub action -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \Sub action
sub ->
    Sub action
sub Sink action
forall (f :: * -> *). MonadIO f => action -> f ()
writeEvent
  -- Hack to get around `BlockedIndefinitelyOnMVar` exception
  -- that occurs when no event handlers are present on a template
  -- and `notify` is no longer in scope
  JSM ThreadId -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM ThreadId -> JSM ())
-> (IO () -> JSM ThreadId) -> IO () -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ThreadId -> JSM ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> JSM ThreadId)
-> (IO () -> IO ThreadId) -> IO () -> JSM ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> (IO () -> IO ()) -> IO () -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int
1000000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
86400) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
notify
  -- Retrieves reference view
  IORef VTree
viewRef <- Sink action -> JSM (IORef VTree)
getView Sink action
forall (f :: * -> *). MonadIO f => action -> f ()
writeEvent
  -- know thy mountElement
  JSVal
mountEl <- Maybe MisoString -> JSM JSVal
mountElement Maybe MisoString
mountPoint
  -- Begin listening for events in the virtual dom
  JSVal -> IORef VTree -> Map MisoString Bool -> JSM ()
delegator JSVal
mountEl IORef VTree
viewRef Map MisoString Bool
events
  -- Process initial action of application
  action -> JSM ()
forall (f :: * -> *). MonadIO f => action -> f ()
writeEvent action
initialAction
  -- Program loop, blocking on SkipChan

  let
    loop :: model -> JSM b
loop !model
oldModel = IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
wait JSM () -> JSM b -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> do
        -- Apply actions to model
        Seq action
actions <- IO (Seq action) -> JSM (Seq action)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Seq action) -> JSM (Seq action))
-> IO (Seq action) -> JSM (Seq action)
forall a b. (a -> b) -> a -> b
$ IORef (Seq action)
-> (Seq action -> (Seq action, Seq action)) -> IO (Seq action)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Seq action)
actionsRef ((Seq action -> (Seq action, Seq action)) -> IO (Seq action))
-> (Seq action -> (Seq action, Seq action)) -> IO (Seq action)
forall a b. (a -> b) -> a -> b
$ \Seq action
actions -> (Seq action
forall a. Seq a
S.empty, Seq action
actions)
        let (Acc model
newModel JSM ()
effects) = (Acc model -> action -> Acc model)
-> Acc model -> Seq action -> Acc model
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Sink action
-> (action -> model -> Effect action model)
-> Acc model
-> action
-> Acc model
forall action model.
Sink action
-> (action -> model -> Effect action model)
-> Acc model
-> action
-> Acc model
foldEffects Sink action
forall (f :: * -> *). MonadIO f => action -> f ()
writeEvent action -> model -> Effect action model
update)
                                            (model -> JSM () -> Acc model
forall model. model -> JSM () -> Acc model
Acc model
oldModel (() -> JSM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())) Seq action
actions
        JSM ()
effects
        StableName model
oldName <- IO (StableName model) -> JSM (StableName model)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (StableName model) -> JSM (StableName model))
-> IO (StableName model) -> JSM (StableName model)
forall a b. (a -> b) -> a -> b
$ model
oldModel model -> IO (StableName model) -> IO (StableName model)
`seq` model -> IO (StableName model)
forall a. a -> IO (StableName a)
makeStableName model
oldModel
        StableName model
newName <- IO (StableName model) -> JSM (StableName model)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (StableName model) -> JSM (StableName model))
-> IO (StableName model) -> JSM (StableName model)
forall a b. (a -> b) -> a -> b
$ model
newModel model -> IO (StableName model) -> IO (StableName model)
`seq` model -> IO (StableName model)
forall a. a -> IO (StableName a)
makeStableName model
newModel
        Bool -> JSM () -> JSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StableName model
oldName StableName model -> StableName model -> Bool
forall a. Eq a => a -> a -> Bool
/= StableName model
newName Bool -> Bool -> Bool
&& model
oldModel model -> model -> Bool
forall a. Eq a => a -> a -> Bool
/= model
newModel) (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
          JSM ()
swapCallbacks
          VTree
newVTree <- View action -> Sink action -> JSM VTree
forall action. View action -> Sink action -> JSM VTree
runView (model -> View action
view model
newModel) Sink action
forall (f :: * -> *). MonadIO f => action -> f ()
writeEvent
          VTree
oldVTree <- IO VTree -> JSM VTree
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef VTree -> IO VTree
forall a. IORef a -> IO a
readIORef IORef VTree
viewRef)
          JSM Double -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM Double -> JSM ()) -> JSM Double -> JSM ()
forall a b. (a -> b) -> a -> b
$ JSM Double
waitForAnimationFrame
          (Maybe MisoString -> Maybe VTree -> Maybe VTree -> JSM ()
diff Maybe MisoString
mountPoint) (VTree -> Maybe VTree
forall a. a -> Maybe a
Just VTree
oldVTree) (VTree -> Maybe VTree
forall a. a -> Maybe a
Just VTree
newVTree)
          JSM ()
releaseCallbacks
          IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef VTree -> VTree -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef VTree
viewRef VTree
newVTree)
        JSM ()
syncPoint
        model -> JSM b
loop model
newModel
  model -> JSM ()
forall b. model -> JSM b
loop model
m

-- | Runs an isomorphic miso application.
-- Assumes the pre-rendered DOM is already present
miso :: Eq model => (URI -> App model action) -> JSM ()
miso :: (URI -> App model action) -> JSM ()
miso URI -> App model action
f = do
  app :: App model action
app@App {model
action
[Sub action]
Maybe MisoString
Map MisoString Bool
LogLevel
model -> View action
action -> model -> Effect action model
logLevel :: LogLevel
mountPoint :: Maybe MisoString
initialAction :: action
events :: Map MisoString Bool
subs :: [Sub action]
view :: model -> View action
update :: action -> model -> Effect action model
model :: model
logLevel :: forall model action. App model action -> LogLevel
mountPoint :: forall model action. App model action -> Maybe MisoString
initialAction :: forall model action. App model action -> action
events :: forall model action. App model action -> Map MisoString Bool
subs :: forall model action. App model action -> [Sub action]
view :: forall model action. App model action -> model -> View action
update :: forall model action.
App model action -> action -> model -> Effect action model
model :: forall model action. App model action -> model
..} <- URI -> App model action
f (URI -> App model action) -> JSM URI -> JSM (App model action)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSM URI
getCurrentURI
  App model action
-> model -> (Sink action -> JSM (IORef VTree)) -> JSM ()
forall model action.
Eq model =>
App model action
-> model -> (Sink action -> JSM (IORef VTree)) -> JSM ()
common App model action
app model
model ((Sink action -> JSM (IORef VTree)) -> JSM ())
-> (Sink action -> JSM (IORef VTree)) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \Sink action
writeEvent -> do
    let initialView :: View action
initialView = model -> View action
view model
model
    VTree (OI.Object JSVal
iv) <- (View action -> Sink action -> JSM VTree)
-> Sink action -> View action -> JSM VTree
forall a b c. (a -> b -> c) -> b -> a -> c
flip View action -> Sink action -> JSM VTree
forall action. View action -> Sink action -> JSM VTree
runView Sink action
writeEvent View action
initialView
    JSVal
mountEl <- Maybe MisoString -> JSM JSVal
mountElement Maybe MisoString
mountPoint
    -- Initial diff can be bypassed, just copy DOM into VTree
    Bool -> JSVal -> JSVal -> JSM ()
copyDOMIntoVTree (LogLevel
logLevel LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
DebugPrerender) JSVal
mountEl JSVal
iv
    let initialVTree :: VTree
initialVTree = Object -> VTree
VTree (JSVal -> Object
OI.Object JSVal
iv)
    -- Create virtual dom, perform initial diff
    IO (IORef VTree) -> JSM (IORef VTree)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (VTree -> IO (IORef VTree)
forall a. a -> IO (IORef a)
newIORef VTree
initialVTree)

-- | Runs a miso application
startApp :: Eq model => App model action -> JSM ()
startApp :: App model action -> JSM ()
startApp app :: App model action
app@App {model
action
[Sub action]
Maybe MisoString
Map MisoString Bool
LogLevel
model -> View action
action -> model -> Effect action model
logLevel :: LogLevel
mountPoint :: Maybe MisoString
initialAction :: action
events :: Map MisoString Bool
subs :: [Sub action]
view :: model -> View action
update :: action -> model -> Effect action model
model :: model
logLevel :: forall model action. App model action -> LogLevel
mountPoint :: forall model action. App model action -> Maybe MisoString
initialAction :: forall model action. App model action -> action
events :: forall model action. App model action -> Map MisoString Bool
subs :: forall model action. App model action -> [Sub action]
view :: forall model action. App model action -> model -> View action
update :: forall model action.
App model action -> action -> model -> Effect action model
model :: forall model action. App model action -> model
..} =
  App model action
-> model -> (Sink action -> JSM (IORef VTree)) -> JSM ()
forall model action.
Eq model =>
App model action
-> model -> (Sink action -> JSM (IORef VTree)) -> JSM ()
common App model action
app model
model ((Sink action -> JSM (IORef VTree)) -> JSM ())
-> (Sink action -> JSM (IORef VTree)) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \Sink action
writeEvent -> do
    let initialView :: View action
initialView = model -> View action
view model
model
    VTree
initialVTree <- (View action -> Sink action -> JSM VTree)
-> Sink action -> View action -> JSM VTree
forall a b c. (a -> b -> c) -> b -> a -> c
flip View action -> Sink action -> JSM VTree
forall action. View action -> Sink action -> JSM VTree
runView Sink action
writeEvent View action
initialView
    (Maybe MisoString -> Maybe VTree -> Maybe VTree -> JSM ()
diff Maybe MisoString
mountPoint) Maybe VTree
forall a. Maybe a
Nothing (VTree -> Maybe VTree
forall a. a -> Maybe a
Just VTree
initialVTree)
    IO (IORef VTree) -> JSM (IORef VTree)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (VTree -> IO (IORef VTree)
forall a. a -> IO (IORef a)
newIORef VTree
initialVTree)

-- | Helper
foldEffects
  :: Sink action
  -> (action -> model -> Effect action model)
  -> Acc model -> action -> Acc model
foldEffects :: Sink action
-> (action -> model -> Effect action model)
-> Acc model
-> action
-> Acc model
foldEffects Sink action
sink action -> model -> Effect action model
update = \(Acc model
model JSM ()
as) action
action ->
  case action -> model -> Effect action model
update action
action model
model of
    Effect model
newModel [Sub action]
effs -> model -> JSM () -> Acc model
forall model. model -> JSM () -> Acc model
Acc model
newModel JSM ()
newAs
      where
        newAs :: JSM ()
newAs = JSM ()
as JSM () -> JSM () -> JSM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> do
          [Sub action] -> (Sub action -> JSM ()) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Sub action]
effs ((Sub action -> JSM ()) -> JSM ())
-> (Sub action -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \Sub action
eff -> JSM () -> JSM ()
forkJSM (Sub action
eff Sink action
sink)

data Acc model = Acc !model !(JSM ())