{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
#ifdef IOS
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
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
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
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
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
[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
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
IORef VTree
viewRef <- Sink action -> JSM (IORef VTree)
getView Sink action
forall (f :: * -> *). MonadIO f => action -> f ()
writeEvent
JSVal
mountEl <- Maybe MisoString -> JSM JSVal
mountElement Maybe MisoString
mountPoint
JSVal -> IORef VTree -> Map MisoString Bool -> JSM ()
delegator JSVal
mountEl IORef VTree
viewRef Map MisoString Bool
events
action -> JSM ()
forall (f :: * -> *). MonadIO f => action -> f ()
writeEvent action
initialAction
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
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
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
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)
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)
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)
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 ())