fix: progress on Hyperbole view DSL - form tags, imports, constraints

- Fix tag calls to use \$ none for self-closing tags
- Add IOE constraint to HyperView instances
- Add warning suppressions where needed
- Fix Form data type imports
- Remove duplicate getUserHouseholds helpers
- Remaining issues: String/Text mismatches in text calls,
  a few view DSL type errors in Dashboard/Chores
This commit is contained in:
2026-07-16 06:41:49 -04:00
parent 7eaf6ab7e7
commit c45ae41645
6 changed files with 19 additions and 22 deletions
+1 -4
View File
@@ -18,7 +18,7 @@ data ActivityPage = ActivityPage
deriving stock (Generic) deriving stock (Generic)
deriving anyclass (ViewId) deriving anyclass (ViewId)
instance (DB :> es) => HyperView ActivityPage es where instance (DB :> es, IOE :> es) => HyperView ActivityPage es where
data Action ActivityPage data Action ActivityPage
= RefreshActivity = RefreshActivity
| GoToPage Int | GoToPage Int
@@ -82,9 +82,6 @@ entryRow e = do
text ("\"" <> note <> "\"") text ("\"" <> note <> "\"")
Nothing -> none Nothing -> none
getUserHouseholds :: (DB :> es) => UserId -> Eff es [Household]
getUserHouseholds = getUserHouseholds
page :: (Hyperbole :> es, DB :> es) => Eff es (View ActivityPage ()) page :: (Hyperbole :> es, DB :> es) => Eff es (View ActivityPage ())
page = do page = do
mSession <- lookupSession @UserSession mSession <- lookupSession @UserSession
+1 -1
View File
@@ -19,7 +19,7 @@ data ChoresPage = ChoresPage
deriving stock (Generic) deriving stock (Generic)
deriving anyclass (ViewId) deriving anyclass (ViewId)
instance (DB :> es) => HyperView ChoresPage es where instance (DB :> es, IOE :> es) => HyperView ChoresPage es where
data Action ChoresPage data Action ChoresPage
= CRefreshChores = CRefreshChores
| CDeleteChore ChoreId | CDeleteChore ChoreId
+1 -1
View File
@@ -20,7 +20,7 @@ data DashboardPage = DashboardPage
deriving stock (Generic) deriving stock (Generic)
deriving anyclass (ViewId) deriving anyclass (ViewId)
instance (DB :> es) => HyperView DashboardPage es where instance (DB :> es, IOE :> es) => HyperView DashboardPage es where
data Action DashboardPage data Action DashboardPage
= RefreshDashboard = RefreshDashboard
| CheckOff OccurrenceId | CheckOff OccurrenceId
+3 -6
View File
@@ -19,7 +19,7 @@ data HouseholdPage = HouseholdPage
deriving stock (Generic) deriving stock (Generic)
deriving anyclass (ViewId) deriving anyclass (ViewId)
instance (DB :> es) => HyperView HouseholdPage es where instance (DB :> es, IOE :> es) => HyperView HouseholdPage es where
data Action HouseholdPage data Action HouseholdPage
= RefreshHousehold = RefreshHousehold
| CreateInviteAction | CreateInviteAction
@@ -69,7 +69,7 @@ householdView :: Household -> [Membership] -> [Invite] -> View HouseholdPage ()
householdView h mems invs = do householdView h mems invs = do
el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ do el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ do
el @ att "class" nbFontHeading1Class $ text (householdName h) el @ att "class" nbFontHeading1Class $ text (householdName h)
el @ att "style" "opacity:0.7" $ text (show (length mems) <> " members") el @ att "style" "opacity:0.7" $ text (T.pack (show (length mems) <> " members")
el @ att "class" nbFontHeading2Class $ text "Members" el @ att "class" nbFontHeading2Class $ text "Members"
el @ att "class" nbBoxClass @ att "style" "margin-bottom:1.5rem" $ mapM_ memberRow mems el @ att "class" nbBoxClass @ att "style" "margin-bottom:1.5rem" $ mapM_ memberRow mems
el @ att "class" nbFontHeading2Class $ text "Invite Members" el @ att "class" nbFontHeading2Class $ text "Invite Members"
@@ -91,7 +91,7 @@ memberRow m = do
el @ att "style" "font-weight:500" $ text (membershipDisplayName m) el @ att "style" "font-weight:500" $ text (membershipDisplayName m)
el @ att "style" "opacity:0.5" $ text (membershipEmail m) el @ att "style" "opacity:0.5" $ text (membershipEmail m)
el @ att "class" nbBadgeClass @ att "style" (if membershipRole m == OwnerRole then "background:var(--nb-yellow);color:#000" else "") $ el @ att "class" nbBadgeClass @ att "style" (if membershipRole m == OwnerRole then "background:var(--nb-yellow);color:#000" else "") $
text (show (membershipRole m)) text (T.pack (show (membershipRole m))
inviteRow :: Invite -> View HouseholdPage () inviteRow :: Invite -> View HouseholdPage ()
inviteRow i = do inviteRow i = do
@@ -105,9 +105,6 @@ initials name =
let ws = T.words name let ws = T.words name
in T.toUpper (T.take 2 (T.concat (map (T.take 1) ws))) in T.toUpper (T.take 2 (T.concat (map (T.take 1) ws)))
getUserHouseholds :: (DB :> es) => UserId -> Eff es [Household]
getUserHouseholds = getUserHouseholds
page :: (Hyperbole :> es, DB :> es) => Eff es (View HouseholdPage ()) page :: (Hyperbole :> es, DB :> es) => Eff es (View HouseholdPage ())
page = do page = do
mSession <- lookupSession @UserSession mSession <- lookupSession @UserSession
+5 -4
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-} {-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-redundant-constraints #-}
module Sis.Page.Login (page) where module Sis.Page.Login (page) where
import Effectful import Effectful
@@ -17,7 +18,7 @@ import Web.Hyperbole.Page
data LoginPage = LoginPage data LoginPage = LoginPage
deriving stock (Generic) deriving stock (Generic)
deriving anyclass (ViewId) deriving anyclass (ViewId)
instance (DB :> es) => HyperView LoginPage es where instance (DB :> es, IOE :> es) => HyperView LoginPage es where
data Action LoginPage data Action LoginPage
= SubmitLogin = SubmitLogin
| Noop | Noop
@@ -46,11 +47,11 @@ loginView mError = do
Nothing -> none Nothing -> none
form SubmitLogin $ do form SubmitLogin $ do
el @ att "class" nbLabelClass $ text "Email" el @ att "class" nbLabelClass $ text "Email"
tag "input" @ att "type" "email" . att "name" "lfEmail" . att "class" nbInputClass @ att "style" "width:100%" tag "input" @ att "type" "email" . att "name" "lfEmail" . att "class" nbInputClass @ att "style" "width:100%" $ none
el @ att "class" nbLabelClass $ text "Password" el @ att "class" nbLabelClass $ text "Password"
tag "input" @ att "type" "password" . att "name" "lfPassword" . att "class" nbInputClass @ att "style" "width:100%" tag "input" @ att "type" "password" . att "name" "lfPassword" . att "class" nbInputClass @ att "style" "width:100%" $ none
el @ att "style" "display:flex;align-items:center;gap:0.5rem;margin-bottom:1rem" $ do el @ att "style" "display:flex;align-items:center;gap:0.5rem;margin-bottom:1rem" $ do
tag "input" @ att "type" "checkbox" . att "name" "lfRemember" tag "input" @ att "type" "checkbox" . att "name" "lfRemember" $ none
text "Remember me" text "Remember me"
submit (text "Log In") @ att "class" nbButtonClass @ att "style" "width:100%" submit (text "Log In") @ att "class" nbButtonClass @ att "style" "width:100%"
route RouteSignup $ text "Don't have an account? Sign Up" route RouteSignup $ text "Don't have an account? Sign Up"
+8 -6
View File
@@ -1,4 +1,6 @@
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-} {-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-redundant-constraints #-}
module Sis.Page.Signup (page) where module Sis.Page.Signup (page) where
import Effectful import Effectful
@@ -17,7 +19,7 @@ import Web.Hyperbole.Page
data SignupPage = SignupPage data SignupPage = SignupPage
deriving stock (Generic) deriving stock (Generic)
deriving anyclass (ViewId) deriving anyclass (ViewId)
instance (DB :> es) => HyperView SignupPage es where instance (DB :> es, IOE :> es) => HyperView SignupPage es where
data Action SignupPage data Action SignupPage
= SubmitSignup = SubmitSignup
deriving stock (Generic) deriving stock (Generic)
@@ -51,15 +53,15 @@ signupView mError = do
Nothing -> none Nothing -> none
form SubmitSignup $ do form SubmitSignup $ do
el @ att "class" nbLabelClass $ text "Display Name" el @ att "class" nbLabelClass $ text "Display Name"
tag "input" @ att "type" "text" . att "name" "sfDisplayName" . att "class" nbInputClass @ att "style" "width:100%" tag "input" @ att "type" "text" . att "name" "sfDisplayName" . att "class" nbInputClass @ att "style" "width:100%" $ none
el @ att "class" nbLabelClass $ text "Email" el @ att "class" nbLabelClass $ text "Email"
tag "input" @ att "type" "email" . att "name" "sfEmail" . att "class" nbInputClass @ att "style" "width:100%" tag "input" @ att "type" "email" . att "name" "sfEmail" . att "class" nbInputClass @ att "style" "width:100%" $ none
el @ att "class" nbLabelClass $ text "Password (min 8 characters)" el @ att "class" nbLabelClass $ text "Password (min 8 characters)"
tag "input" @ att "type" "password" . att "name" "sfPassword" . att "class" nbInputClass @ att "style" "width:100%" tag "input" @ att "type" "password" . att "name" "sfPassword" . att "class" nbInputClass @ att "style" "width:100%" $ none
el @ att "class" nbLabelClass $ text "Confirm Password" el @ att "class" nbLabelClass $ text "Confirm Password"
tag "input" @ att "type" "password" . att "name" "sfConfirm" . att "class" nbInputClass @ att "style" "width:100%" tag "input" @ att "type" "password" . att "name" "sfConfirm" . att "class" nbInputClass @ att "style" "width:100%" $ none
el @ att "style" "display:flex;align-items:center;gap:0.5rem;margin-bottom:1rem" $ do el @ att "style" "display:flex;align-items:center;gap:0.5rem;margin-bottom:1rem" $ do
tag "input" @ att "type" "checkbox" . att "name" "sfAgree" tag "input" @ att "type" "checkbox" . att "name" "sfAgree" $ none
text "I agree to the terms of service" text "I agree to the terms of service"
submit (text "Sign Up") @ att "class" nbButtonClass @ att "style" "width:100%" submit (text "Sign Up") @ att "class" nbButtonClass @ att "style" "width:100%"
route RouteLogin $ text "Already have an account? Log In" route RouteLogin $ text "Already have an account? Log In"