1 files changed, 78 insertions, 57 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
         ]
     ]