newtype Page

Author: seanhess

.hlint.yaml

@@ -0,0 +1,2 @@
+- ignore: {name: "Use <$>"}
+- ignore: {name: "Use newtype instead of data"}

example/Example/Contacts.hs

@@ -39,7 +39,7 @@ data Filter
   deriving (Show, Read, Eq)
 
 
-page :: forall es. (Hyperbole :> es, Users :> es, Debug :> es) => Eff es ()
+page :: forall es. (Hyperbole :> es, Users :> es, Debug :> es) => Page es ()
 page = do
   hyper contacts
   hyper contact

example/Example/Layout.hs

@@ -7,7 +7,7 @@ import Web.UI
 
 
 -- need to be able to set bg color of page, sure
-page :: (Hyperbole :> es) => Eff es ()
+page :: (Hyperbole :> es) => Page es ()
 page = load $ do
   pure $ do
     layout (bg GrayLight . big flexRow) $ do

example/Example/Transitions.hs

@@ -17,7 +17,7 @@ data Action
 
 
 -- need to be able to set bg color of page, sure
-page :: (Hyperbole :> es) => Eff es ()
+page :: (Hyperbole :> es) => Page es ()
 page = do
   hyper content
 

example/Main.hs

@@ -57,16 +57,16 @@ app :: UserStore -> Application
 app users = waiApplication document (runUsersIO users . runHyperbole . runDebugIO . router)
  where
   router :: (Hyperbole :> es, Users :> es, Debug :> es) => AppRoute -> Eff es ()
-  router (Hello h) = hello h
-  router Echo = do
+  router (Hello h) = page $ hello h
+  router Echo = page $ load $ do
     f <- formData
-    load $ pure $ col id $ do
+    pure $ col id $ do
       el id "ECHO:"
       text $ cs $ show f
-  router Contacts = Contacts.page
-  router Layout = Layout.page
-  router Transitions = Transitions.page
-  router Main = load $ pure $ do
+  router Contacts = page Contacts.page
+  router Layout = page Layout.page
+  router Transitions = page Transitions.page
+  router Main = page $ load $ pure $ do
     col (gap 10 . pad 10) $ do
       el (bold . fontSize 32) "Examples"
       link (routeUrl (Hello (Greet "World"))) id "Hello World"

src/Web/Hyperbole/Effect.hs

@@ -21,11 +21,9 @@ import Web.Hyperbole.HyperView
 import Web.UI
 
 
--- you can't automatically derive FromHttpApiData. I don't like it!
-
 data Hyperbole :: Effect where
-  RespondView :: View () () -> Hyperbole m ()
   GetEvent :: (HyperView id action) => Hyperbole m (Maybe (Event id action))
+  RespondView :: View () () -> Hyperbole m ()
   GetForm :: Hyperbole m Form
   HyperError :: HyperError -> Hyperbole m a
 
@@ -46,16 +44,16 @@ runHyperbole = interpret $ \_ -> \case
     send $ ResHeader "Content-Type" "text/html"
     send $ ResBody ContentHtml bd
     Wai.continue
+  GetForm -> Wai.formData
+  HyperError NotFound -> send $ Interrupt Wai.NotFound
+  HyperError (ParseError e) -> send $ Interrupt $ Wai.ParseError e
   GetEvent -> do
     q <- fmap queryString <$> send $ Wai.Request
     pure $ do
       Event ti ta <- lookupEvent q
       vid <- parseParam ti
       act <- parseParam ta
       pure $ Event vid act
-  GetForm -> Wai.formData
-  HyperError NotFound -> send $ Interrupt Wai.NotFound
-  HyperError (ParseError e) -> send $ Interrupt $ Wai.ParseError e
  where
   lookupParam :: ByteString -> Query -> Maybe Text
   lookupParam p q =
@@ -90,18 +88,37 @@ data HyperError
   | ParseError Text
 
 
-load :: (Hyperbole :> es) => Eff es (View () ()) -> Eff es ()
-load pg = do
-  vw <- pg
+newtype Page es a = Page (Eff es a)
+  deriving newtype (Applicative, Monad, Functor)
+
+
+-- | Load the entire page when no HyperViews match
+load
+  :: (Hyperbole :> es)
+  => Eff es (View () ())
+  -> Page es ()
+load run = Page $ do
+  vw <- run
   send $ RespondView vw
 
 
-hyper :: forall id action es. (Hyperbole :> es, HyperView id action) => (id -> action -> Eff es (View id ())) -> Eff es ()
-hyper run = do
+-- | Handle a HyperView. If the event matches our handler, respond with the fragment
+hyper
+  :: (Hyperbole :> es, HyperView id action)
+  => (id -> action -> Eff es (View id ()))
+  -> Page es ()
+hyper run = Page $ do
   -- Get an event matching our type. If it doesn't match, skip to the next handler
   mev <- send GetEvent
   case mev of
     Just (Event vid act) -> do
       vw <- run vid act
       send $ RespondView $ viewId vid vw
     _ -> pure ()
+
+
+page
+  :: (Hyperbole :> es)
+  => Page es ()
+  -> Eff es ()
+page (Page eff) = eff