diff options
| -rw-r--r-- | erebos-webapp.cabal | 25 | ||||
| -rw-r--r-- | src/Main.hs | 58 |
2 files changed, 82 insertions, 1 deletions
diff --git a/erebos-webapp.cabal b/erebos-webapp.cabal index 4fc3ca6..a040a0a 100644 --- a/erebos-webapp.cabal +++ b/erebos-webapp.cabal @@ -25,12 +25,37 @@ executable erebos-webapp -optl-mexec-model=reactor -optl-Wl,--export=hs_init,--export=setup + extra-libraries: blake2b-ref + -- other-modules: + default-extensions: + DefaultSignatures + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiWayIf + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TypeOperators + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + -- other-extensions: build-depends: base ^>= { 4.21 }, + erebos ^>= { 0.1.8 }, ghc-experimental ^>= { 9.1201 }, + mtl ^>= { 2.3 }, + text ^>= { 2.1 }, hs-source-dirs: src default-language: GHC2021 diff --git a/src/Main.hs b/src/Main.hs index 69276ac..d201708 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,21 +1,74 @@ module Main (main, setup) where +import Control.Monad.Reader + +import Data.Maybe +import Data.Proxy +import Data.Text qualified as T + import GHC.Wasm.Prim +import Erebos.Identity +import Erebos.State +import Erebos.Storable +import Erebos.Storage + +import System.IO.Unsafe + main :: IO () main = error "unused" +{-# NOINLINE globalStorage #-} +globalStorage :: Storage +globalStorage = unsafePerformIO $ memoryStorage + +{-# NOINLINE globalHead #-} +globalHead :: Head LocalState +globalHead = unsafePerformIO $ do + identity <- createIdentity globalStorage (Just $ T.pack "<init>") Nothing + storeHead globalStorage $ LocalState { lsPrev = Nothing, lsIdentity = idExtData identity, lsShared = [], lsOther = [] } + foreign export javascript setup :: IO () setup :: IO () setup = do body <- js_document_getElementById (toJSString "body") - js_set_innerHTML body (toJSString "<input id=\"some_input\" type=\"text\" value=\"xyz\" /><button id=\"some_button\">add</button></div><div><ul id=\"some_list\"></ul></div>") + js_set_innerHTML body (toJSString "<div>Name: <span id=\"name_text\"></span></div><hr><input id=\"some_input\" type=\"text\" value=\"xyz\" /><button id=\"some_button\">add</button></div><div><ul id=\"some_list\"></ul></div>") + + nameElem <- js_document_getElementById (toJSString "name_text") + _ <- watchHead globalHead $ \ls -> do + js_set_textContent nameElem $ toJSString $ T.unpack $ displayIdentity $ headLocalIdentity ls buttonElem <- js_document_getElementById (toJSString "some_button") buttonCallback <- asEventListener onButtonClick js_addEventListener buttonElem (toJSString "click") buttonCallback + let name = T.pack "My Name" + devName = T.pack "WebApp" + + let st = globalStorage + owner <- if + | T.null name -> return Nothing + | otherwise -> Just <$> createIdentity st (Just name) Nothing + + identity <- createIdentity st (if T.null devName then Nothing else Just devName) owner + + shared <- wrappedStore st $ SharedState + { ssPrev = [] + , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy + , ssValue = [ storedRef $ idExtData $ fromMaybe identity owner ] + } + flip runReaderT globalHead $ do + updateLocalState_ $ \_ -> do + mstore $ LocalState + { lsPrev = Nothing + , lsIdentity = idExtData identity + , lsShared = [ shared ] + , lsOther = [] + } + return () + + onButtonClick :: JSVal -> IO () onButtonClick _event = do inputElem <- js_document_getElementById (toJSString "some_input") @@ -32,6 +85,9 @@ foreign import javascript unsafe "document.getElementById($1)" foreign import javascript unsafe "$1.innerHTML = $2" js_set_innerHTML :: JSVal -> JSString -> IO () +foreign import javascript unsafe "$1.textContent = $2" + js_set_textContent :: JSVal -> JSString -> IO () + foreign import javascript unsafe "$1.appendChild($2)" js_appendChild :: JSVal -> JSVal -> IO () |