diff --git a/ghc-src/Miso.hs b/ghc-src/Miso.hs --- a/ghc-src/Miso.hs +++ b/ghc-src/Miso.hs @@ -15,7 +15,9 @@ module Miso ( module Miso.Event , module Miso.Html + , module Miso.TypeLevel ) where import Miso.Event import Miso.Html +import Miso.TypeLevel diff --git a/ghc-src/Miso/Html/Internal.hs b/ghc-src/Miso/Html/Internal.hs --- a/ghc-src/Miso/Html/Internal.hs +++ b/ghc-src/Miso/Html/Internal.hs @@ -39,8 +39,6 @@ -- * Handling events , on , onWithOptions - -- * String - , module Miso.String ) where import Data.Aeson @@ -64,7 +62,6 @@ VNode :: { vType :: Text -- ^ Element type (i.e. "div", "a", "p") , vNs :: NS -- ^ HTML or SVG , vProps :: Props -- ^ Fields present on DOM Node - , vCss :: CSS -- ^ Styles , vKey :: Maybe Key -- ^ Key used for child swap patch , vChildren :: V.Vector (VTree action) -- ^ Child nodes } -> VTree action @@ -77,7 +74,8 @@ -- | Converting `VTree` to Lucid's `L.Html` instance L.ToHtml (VTree action) where toHtmlRaw = L.toHtml - toHtml (VText x) = L.toHtml x + toHtml (VText x) | T.null x = L.toHtml (" " :: MisoString) + | otherwise = L.toHtml x toHtml VNode{..} = let ele = L.makeElement (toTag vType) kids in L.with ele as @@ -130,7 +128,6 @@ node :: NS -> MisoString -> Maybe Key -> [Attribute action] -> [View action] -> View action node vNs vType vKey as xs = let vProps = Props $ M.fromList [ (k,v) | P k v <- as ] - vCss = CSS $ M.fromList [ (k,v) | C k v <- as ] vChildren = V.fromList $ map runView xs in View VNode {..} @@ -161,15 +158,13 @@ -- | Properties newtype Props = Props (M.Map MisoString Value) - --- | CSS -newtype CSS = CSS (M.Map MisoString MisoString) + deriving (Show, Eq) -- | `View` Attributes to annotate DOM, converted into Events, Props, Attrs and CSS data Attribute action - = C MisoString MisoString - | P MisoString Value + = P MisoString Value | E () + deriving (Show, Eq) -- | DMJ: this used to get set on preventDefault on Options... if options are dynamic now what -- | Useful for `drop` events @@ -212,7 +207,7 @@ -- -- style_ :: M.Map MisoString MisoString -> Attribute action -style_ = C "style" . M.foldrWithKey go mempty +style_ map' = P "style" $ String (M.foldrWithKey go mempty map') where go :: MisoString -> MisoString -> MisoString -> MisoString go k v xs = mconcat [ k, ":", v, ";" ] <> xs diff --git a/ghc-src/Miso/TypeLevel.hs b/ghc-src/Miso/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/ghc-src/Miso/TypeLevel.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +module Miso.TypeLevel ( ToServerRoutes ) where + +import Miso.Html +import Servant.API +import Servant.HTML.Lucid + +-- | Convert client route type to a server web handler type +type family ToServerRoutes (layout :: k) (wrapper :: * -> *) (action :: *) :: k where + ToServerRoutes (a :<|> b) wrapper action = + ToServerRoutes a wrapper action :<|> + ToServerRoutes b wrapper action + ToServerRoutes (a :> b) wrapper action = + a :> ToServerRoutes b wrapper action + ToServerRoutes (View _) wrapper action = + Get '[HTML] (wrapper (View action)) diff --git a/ghcjs-src/Miso.hs b/ghcjs-src/Miso.hs --- a/ghcjs-src/Miso.hs +++ b/ghcjs-src/Miso.hs @@ -13,7 +13,8 @@ -- Portability : non-portable ---------------------------------------------------------------------------- module Miso - ( startApp + ( miso + , startApp , module Miso.Effect , module Miso.Event , module Miso.Html @@ -28,6 +29,7 @@ import Data.List import Data.Sequence ((|>)) import qualified Data.Sequence as S +import qualified JavaScript.Object.Internal as OI import JavaScript.Web.AnimationFrame import Miso.Concurrent @@ -39,39 +41,40 @@ import Miso.Router import Miso.Subscription import Miso.Types +import Miso.FFI --- | Runs a miso application -startApp :: Eq model => App model action -> IO () -startApp App {..} = do - let initialView = view model - -- init empty Model - modelRef <- newIORef model - -- init empty actions - actionsMVar <- newMVar S.empty +-- | Helper function to abstract out common functionality between `startApp` and `miso` +common + :: Eq model + => App model action + -> model + -> ((action -> IO ()) -> IO (IORef VTree)) + -> IO b +common App {..} m getView = do -- init Notifier Notify {..} <- newNotify -- init EventWriter EventWriter {..} <- newEventWriter notify + -- init empty Model + modelRef <- newIORef m + -- init empty actions + actionsMVar <- newMVar S.empty -- init Subs forM_ subs $ \sub -> sub (readIORef modelRef) writeEvent -- init event application thread void . forkIO . forever $ do - newAction <- getEvent + action <- getEvent modifyMVar_ actionsMVar $! \actions -> - pure (actions |> newAction) + pure (actions |> action) -- Hack to get around `BlockedIndefinitelyOnMVar` exception -- that occurs when no event handlers are present on a template -- and `notify` is no longer in scope void . forkIO . forever $ threadDelay (1000000 * 86400) >> notify - -- Create virtual dom, perform initial diff - initialVTree <- flip runView writeEvent initialView - Nothing `diff` (Just initialVTree) - viewRef <- newIORef initialVTree + -- Retrieves reference view + viewRef <- getView writeEvent -- Begin listening for events in the virtual dom delegator viewRef events - -- Process initial action of application - writeEvent initialAction -- Program loop, blocking on SkipChan forever $ wait >> do -- Apply actions to model @@ -93,6 +96,31 @@ Just oldVTree `diff` Just newVTree atomicWriteIORef viewRef newVTree +-- | Runs an isomorphic miso application +-- Assumes the pre-rendered DOM is already present +miso :: (HasURI model, Eq model) => App model action -> IO () +miso app@App{..} = do + uri <- getCurrentURI + let modelWithUri = setURI uri model + common app model $ \writeEvent -> do + let initialView = view modelWithUri + VTree (OI.Object iv) <- flip runView writeEvent initialView + -- Initial diff can be bypassed, just copy DOM into VTree + copyDOMIntoVTree iv + let initialVTree = VTree (OI.Object iv) + -- Create virtual dom, perform initial diff + newIORef initialVTree + +-- | Runs a miso application +startApp :: Eq model => App model action -> IO () +startApp app@App {..} = + common app model $ \writeEvent -> do + let initialView = view model + initialVTree <- flip runView writeEvent initialView + Nothing `diff` (Just initialVTree) + newIORef initialVTree + +-- | Helper foldEffects :: (action -> IO ()) -> (action -> model -> Effect model action) diff --git a/ghcjs-src/Miso/Router.hs b/ghcjs-src/Miso/Router.hs --- a/ghcjs-src/Miso/Router.hs +++ b/ghcjs-src/Miso/Router.hs @@ -190,7 +190,10 @@ p:paths -> if p == T.pack (symbolVal sym) then routeLoc (loc { locPath = paths }) a m else Left Fail - RPage a -> Right a + RPage a -> + case locPath loc of + [] -> Right a + _ -> Left Fail -- | Convert a 'URI' to a 'Location'. uriToLocation :: URI -> Location diff --git a/ghcjs-src/Miso/Subscription/History.hs b/ghcjs-src/Miso/Subscription/History.hs --- a/ghcjs-src/Miso/Subscription/History.hs +++ b/ghcjs-src/Miso/Subscription/History.hs @@ -43,7 +43,7 @@ getURI = do URI <$> pure mempty <*> pure Nothing - <*> do unpack <$> getPathName + <*> do Prelude.drop 1 . unpack <$> getPathName <*> do unpack <$> getSearch <*> pure mempty diff --git a/jsbits/isomorphic.js b/jsbits/isomorphic.js --- a/jsbits/isomorphic.js +++ b/jsbits/isomorphic.js @@ -3,10 +3,17 @@ } function walk (vtree, node) { - var i = 0; + var i = 0, vdomChild, domChild; vtree.domRef = node; while (i < vtree.children.length) { - walk(vtree.children[i], node.children[i]); + vdomChild = vtree.children[i]; + domChild = node.childNodes[i]; + if (vdomChild.type === "vtext") { + vdomChild.domRef = domChild; + i++; + continue; + } + walk(vdomChild, domChild); i++; } } diff --git a/miso.cabal b/miso.cabal --- a/miso.cabal +++ b/miso.cabal @@ -1,5 +1,5 @@ name: miso -version: 0.3.0.0 +version: 0.4.0.0 category: Web, Miso, Data Structures license: BSD3 license-file: LICENSE @@ -204,8 +204,11 @@ Miso.FFI Miso.Delegate else + exposed-modules: + Miso.TypeLevel build-depends: lucid, + servant-lucid, vector hs-source-dirs: ghc-src