aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--frontend/app/Main.hs135
-rw-r--r--frontend/app/Page.hs48
-rw-r--r--frontend/app/Page/EditValue.hs27
-rw-r--r--frontend/app/Page/ListCollection.hs8
-rw-r--r--frontend/app/Page/NewCollection.hs32
5 files changed, 136 insertions, 114 deletions
diff --git a/frontend/app/Main.hs b/frontend/app/Main.hs
index 67f1938..f3d40c8 100644
--- a/frontend/app/Main.hs
+++ b/frontend/app/Main.hs
@@ -35,18 +35,12 @@ data LoadedState = LoadedState
instance Default Model where
def = Loading
-data Action
- = -- Loading
- SetLoaded (Either String LoadedState)
- | -- Loaded
- NoOp
- | Init URI
- | HandleURI URI
- | HandlePage Page.Action
- | SetPage (Either String Page)
- | HandleEff Eff
- | SetCollections (Either String [String])
- deriving (Show, Eq)
+newtype Action = Action (Model -> Effect Action Model)
+
+-- TODO
+instance Show Action
+
+instance Eq Action
#ifndef ghcjs_HOST_OS
runApp :: JSM () -> IO ()
@@ -59,59 +53,86 @@ runApp app = app
main :: IO ()
main = runApp $ do
uri <- getCurrentURI
- startApp App {initialAction = Init uri, ..}
+ startApp App {initialAction = update__init uri, ..}
where
model = def
- update = updateModel
+ update (Action f) m = f m
view = viewModel
events = defaultEvents
- subs = [uriSub HandleURI]
+ subs = [uriSub update__handleURI]
mountPoint = Nothing
logLevel = Off
-updateModel :: Action -> Model -> Effect Action Model
-updateModel _ (Failed err) = noEff (Failed err)
-updateModel (Init uri) Loading =
- Loading <# do
- page <- Just <$> initialPage (parseURI uri)
- schemaVersion' <- fetchSchemaVersion
- collections' <- fetchCollections
- pure $ SetLoaded do
- schemaVersion <- schemaVersion'
- collections <- collections'
- pure LoadedState {..}
-updateModel (Init _) m = noEff m
-updateModel (SetLoaded (Left err)) Loading = noEff (Failed err)
-updateModel (SetLoaded (Right state)) Loading = noEff (Loaded state)
-updateModel (SetLoaded _) m = noEff m
-updateModel _ Loading = noEff Loading
-updateModel NoOp (Loaded s) = noEff (Loaded s)
-updateModel (HandleURI uri) (Loaded s) =
- Loaded s <# do
- let route = parseURI uri
- SetPage <$> initialPage route
-updateModel (SetPage page) (Loaded s) = noEff (Loaded s {page = Just page})
-updateModel (HandlePage action) (Loaded s) =
- case s.page of
- Just (Right page) ->
- fmap Loaded $
- ( case updatePage action page
- & first (bimap HandlePage (\page -> s {page = Just (Right page)}))
- & second (map HandleEff)
- & second (map (\eff -> (\sink -> liftIO (sink eff)))) of
- (Effect s' ss, ss') ->
- Effect s' (ss ++ ss')
- )
- _ -> noEff (Loaded s)
-updateModel (HandleEff eff) (Loaded s) = Loaded s <# handleEff eff
-updateModel (SetCollections (Left err)) (Loaded s) =
- Loaded s <# do
- pure NoOp <* consoleLog (toMisoString err)
-updateModel (SetCollections (Right collections)) (Loaded s) =
- noEff (Loaded s {collections})
+update__init :: URI -> Action
+update__init uri = Action $ \case
+ Loading ->
+ Loading <# do
+ page <- Just <$> initialPage (parseURI uri)
+ schemaVersion' <- fetchSchemaVersion
+ collections' <- fetchCollections
+ pure $ update__setLoaded do
+ schemaVersion <- schemaVersion'
+ collections <- collections'
+ pure LoadedState {..}
+ m -> noEff m
+
+update__setLoaded :: Either String LoadedState -> Action
+update__setLoaded (Left e) = Action $ \case
+ Loading -> noEff (Failed e)
+ m -> noEff m
+update__setLoaded (Right s) = Action $ \case
+ Loading -> noEff (Loaded s)
+ m -> noEff m
+
+update__noOp :: Action
+update__noOp = Action noEff
+
+update__handleURI :: URI -> Action
+update__handleURI uri = Action $ \case
+ Loaded s ->
+ Loaded s <# do
+ let route = parseURI uri
+ update__setPage <$> initialPage route
+ m -> noEff m
+
+update__setPage :: Either String Page -> Action
+update__setPage (Just -> page) = Action $ \case
+ Loaded s -> noEff (Loaded s {page})
+ m -> noEff m
+
+update__handlePage :: Page.Action -> Action
+update__handlePage action = Action $ \case
+ Loaded s ->
+ case s.page of
+ Just (Right page) ->
+ fmap Loaded $
+ ( case updatePage action page
+ & first (bimap update__handlePage (\page -> s {page = Just (Right page)}))
+ & second (map update__handleEff)
+ & second (map (\eff -> (\sink -> liftIO (sink eff)))) of
+ (Effect s' ss, ss') ->
+ Effect s' (ss ++ ss')
+ )
+ _ -> noEff (Loaded s)
+ m -> noEff m
+
+update__handleEff :: Eff -> Action
+update__handleEff eff = Action $ \case
+ Loaded s -> Loaded s <# handleEff eff
+ m -> noEff m
+
+update__setCollections :: Either String [String] -> Action
+update__setCollections (Left err) = Action $ \case
+ Loaded s ->
+ Loaded s <# do
+ pure update__noOp <* consoleLog (toMisoString err)
+ m -> noEff m
+update__setCollections (Right collections) = Action $ \case
+ Loaded s -> noEff (Loaded s {collections})
+ m -> noEff m
handleEff :: Eff -> JSM Action
-handleEff E.ReloadCollections = SetCollections <$> fetchCollections
+handleEff E.ReloadCollections = update__setCollections <$> fetchCollections
viewModel :: Model -> View Action
viewModel Loading = text ".."
@@ -122,7 +143,7 @@ viewModel (Loaded s) =
viewHeader s,
nav_ [] [viewCollections s],
main_ [] $
- [ HandlePage <$> maybe (text "..") (either err viewPage) s.page
+ [ update__handlePage <$> maybe (text "..") (either err viewPage) s.page
]
]
diff --git a/frontend/app/Page.hs b/frontend/app/Page.hs
index 7c200c8..3218ae6 100644
--- a/frontend/app/Page.hs
+++ b/frontend/app/Page.hs
@@ -10,13 +10,13 @@ where
import Data.Bifunctor
import Data.Default
import Data.Function
+import Effect (Eff)
import Miso
import Page.EditValue qualified as EditValue
import Page.ListCollection qualified as ListCollection
import Page.NewCollection qualified as NewCollection
import Route (Route)
import Route qualified as Route
-import Effect (Eff)
data Page
= Home
@@ -25,11 +25,7 @@ data Page
| NewCollection NewCollection.Model
deriving (Show, Eq)
-data Action
- = HandleListCollection ListCollection.Action
- | HandleEditValue EditValue.Action
- | HandleNewCollection NewCollection.Action
- deriving (Show, Eq)
+newtype Action = Action (Page -> (Effect Action Page, [Eff]))
instance Default Page where
def = Home
@@ -43,22 +39,32 @@ initialPage (Route.EditValue c f) =
initialPage Route.NewCollection =
fmap NewCollection <$> NewCollection.initialModel
+update__handleListCollection :: ListCollection.Action -> Action
+update__handleListCollection action = Action $ \case
+ ListCollection m ->
+ ListCollection.updateModel action m
+ & first (bimap update__handleListCollection ListCollection)
+ p -> (noEff p, [])
+
+update__handleEditValue :: EditValue.Action -> Action
+update__handleEditValue action = Action $ \case
+ EditValue m ->
+ EditValue.updateModel action m
+ & first (bimap update__handleEditValue EditValue)
+ p -> (noEff p, [])
+
+update__handleNewCollection :: NewCollection.Action -> Action
+update__handleNewCollection action = Action $ \case
+ NewCollection m ->
+ NewCollection.updateModel action m
+ & first (bimap update__handleNewCollection NewCollection)
+ p -> (noEff p, [])
+
updatePage :: Action -> Page -> (Effect Action Page, [Eff])
-updatePage (HandleListCollection action) (ListCollection m) =
- ListCollection.updateModel action m
- & first (bimap HandleListCollection ListCollection)
-updatePage (HandleListCollection _) p = (noEff p, [])
-updatePage (HandleEditValue action) (EditValue m) =
- EditValue.updateModel action m
- & first (bimap HandleEditValue EditValue)
-updatePage (HandleEditValue _) p = (noEff p, [])
-updatePage (HandleNewCollection action) (NewCollection m) =
- NewCollection.updateModel action m
- & first (bimap HandleNewCollection NewCollection)
-updatePage (HandleNewCollection _) p = (noEff p, [])
+updatePage (Action f) m = f m
viewPage :: Page -> View Action
viewPage Home = text "home"
-viewPage (ListCollection m) = HandleListCollection <$> ListCollection.viewModel m
-viewPage (EditValue m) = HandleEditValue <$> EditValue.viewModel m
-viewPage (NewCollection m) = HandleNewCollection <$> NewCollection.viewModel m
+viewPage (ListCollection m) = update__handleListCollection <$> ListCollection.viewModel m
+viewPage (EditValue m) = update__handleEditValue <$> EditValue.viewModel m
+viewPage (NewCollection m) = update__handleNewCollection <$> NewCollection.viewModel m
diff --git a/frontend/app/Page/EditValue.hs b/frontend/app/Page/EditValue.hs
index 43c6f17..cdb1dd0 100644
--- a/frontend/app/Page/EditValue.hs
+++ b/frontend/app/Page/EditValue.hs
@@ -12,10 +12,10 @@ import Data.Aeson qualified as A
import Data.Aeson.KeyMap qualified as AM
import Data.ByteString.Lazy.UTF8 as LB
import Data.Maybe
+import Effect (Eff)
import Form qualified as F
import Miso
import Miso.String (toMisoString)
-import Effect (Eff)
import Schema
data Model = Model
@@ -35,19 +35,20 @@ initialModel collection fileName = do
input <- input'
pure $ Model {..}
-data Action
- = NoOp
- | FormChanged A.Value
- | FormSubmitted A.Value
- | EntityWritten (Either String ())
- deriving (Eq, Show)
+newtype Action = Action (Model -> (Effect Action Model, [Eff]))
+
+update__formChanged :: A.Value -> Action
+update__formChanged (Just -> input) = Action $ \m -> (noEff m {input}, [])
+
+update__formSubmitted :: A.Value -> Action
+update__formSubmitted output = Action $ \m ->
+ (m <# do update__entityWritten <$> updatePost m.fileName output, [])
+
+update__entityWritten :: Either String () -> Action
+update__entityWritten _ = Action $ \m -> (noEff m, [])
updateModel :: Action -> Model -> (Effect Action Model, [Eff])
-updateModel NoOp m = (noEff m, [])
-updateModel (FormChanged (Just -> input)) m = (noEff m {input}, [])
-updateModel (FormSubmitted output) m =
- (m <# do EntityWritten <$> updatePost m.fileName output, [])
-updateModel (EntityWritten _) m = (noEff m, [])
+updateModel (Action f) m = f m
viewModel :: Model -> View Action
viewModel m = do
@@ -60,7 +61,7 @@ viewModel m = do
viewForm :: A.Value -> Schema -> View Action
viewForm input =
- fmap (either FormChanged FormSubmitted)
+ fmap (either update__formChanged update__formSubmitted)
. flip F.runForm input
. schemaForm
diff --git a/frontend/app/Page/ListCollection.hs b/frontend/app/Page/ListCollection.hs
index 93ea389..9acca3c 100644
--- a/frontend/app/Page/ListCollection.hs
+++ b/frontend/app/Page/ListCollection.hs
@@ -10,9 +10,9 @@ where
import Api
import Data.Aeson qualified as A
import Data.Aeson.KeyMap qualified as AM
+import Effect (Eff)
import Miso
import Schema
-import Effect (Eff)
data Model = Model
{ collection :: String,
@@ -31,12 +31,10 @@ initialModel collection = do
posts <- posts'
pure $ Model {input = A.Object AM.empty, ..}
-data Action
- = NoOp
- deriving (Eq, Show)
+newtype Action = Action (Model -> (Effect Action Model, [Eff]))
updateModel :: Action -> Model -> (Effect Action Model, [Eff])
-updateModel NoOp m = (noEff m, [])
+updateModel (Action f) m = f m
viewModel :: Model -> View Action
viewModel m =
diff --git a/frontend/app/Page/NewCollection.hs b/frontend/app/Page/NewCollection.hs
index dbc448b..12b9cf1 100644
--- a/frontend/app/Page/NewCollection.hs
+++ b/frontend/app/Page/NewCollection.hs
@@ -25,33 +25,29 @@ initialModel :: JSM (Either String Model)
initialModel = do
pure (Right (Model {input = ""}))
-data Action
- = NoOp
- | FormChanged T.Text
- | FormSubmitted T.Text
- | CollectionCreated (Either String ())
- deriving (Eq, Show)
+newtype Action = Action (Model -> (Effect Action Model, [Eff]))
-updateModel :: Action -> Model -> (Effect Action Model, [Eff])
-updateModel NoOp m = (noEff m, [])
-updateModel (FormChanged input) m = (noEff m {input}, [])
-updateModel (FormSubmitted collection) m =
- ( m <# do
- CollectionCreated <$> createCollection (T.unpack collection),
- []
- )
-updateModel (CollectionCreated (Left err)) m =
+update__formChanged :: T.Text -> Action
+update__formChanged input = Action $ \m -> (noEff m {input}, [])
+
+update__formSubmitted :: T.Text -> Action
+update__formSubmitted collection = Action $ \m ->
( m <# do
- pure NoOp <* consoleLog (toMisoString err),
+ update__collectionCreated <$> createCollection (T.unpack collection),
[]
)
-updateModel (CollectionCreated (Right _)) m = (noEff m, [E.ReloadCollections])
+
+update__collectionCreated :: Either String () -> Action
+update__collectionCreated _ = Action $ \m -> (noEff m, [E.ReloadCollections])
+
+updateModel :: Action -> Model -> (Effect Action Model, [Eff])
+updateModel (Action f) m = f m
viewModel :: Model -> View Action
viewModel m = do
div_ [] $
[ h3_ [] [text "new collection"],
- either FormChanged FormSubmitted
+ either update__formChanged update__formSubmitted
<$> F.runForm collectionForm m.input,
pre_ [] [text (toMisoString (A.encode m.input))],
pre_ [] [text (toMisoString (A.encode (collectionForm.fill m.input)))]
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 05:16:25 +0000