jbrechtel/sis
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
- 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:
James Brechtel
2026-07-16 06:41:49 -04:00
parent 7eaf6ab7e7
commit c45ae41645
6 changed files with 19 additions and 22 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Sis/Page/Activity.hs
+1 -4
View File
@@ -18,7 +18,7 @@ data ActivityPage = ActivityPage
deriving stock (Generic)
deriving anyclass (ViewId)
instance (DB :> es) => HyperView ActivityPage es where
instance (DB :> es, IOE :> es) => HyperView ActivityPage es where
data Action ActivityPage
= RefreshActivity
| GoToPage Int
@@ -82,9 +82,6 @@ entryRow e = do
text ("\"" <> note <> "\"")
Nothing -> none
getUserHouseholds :: (DB :> es) => UserId -> Eff es [Household]
getUserHouseholds = getUserHouseholds
page :: (Hyperbole :> es, DB :> es) => Eff es (View ActivityPage ())
page = do
mSession <- lookupSession @UserSession
src/Sis/Page/Chores.hs
+1 -1
View File
@@ -19,7 +19,7 @@ data ChoresPage = ChoresPage
deriving stock (Generic)
deriving anyclass (ViewId)
instance (DB :> es) => HyperView ChoresPage es where
instance (DB :> es, IOE :> es) => HyperView ChoresPage es where
data Action ChoresPage
= CRefreshChores
| CDeleteChore ChoreId
src/Sis/Page/Dashboard.hs
+1 -1
View File
@@ -20,7 +20,7 @@ data DashboardPage = DashboardPage
deriving stock (Generic)
deriving anyclass (ViewId)
instance (DB :> es) => HyperView DashboardPage es where
instance (DB :> es, IOE :> es) => HyperView DashboardPage es where
data Action DashboardPage
= RefreshDashboard
| CheckOff OccurrenceId
src/Sis/Page/Household.hs
+3 -6
View File
@@ -19,7 +19,7 @@ data HouseholdPage = HouseholdPage
deriving stock (Generic)
deriving anyclass (ViewId)
instance (DB :> es) => HyperView HouseholdPage es where
instance (DB :> es, IOE :> es) => HyperView HouseholdPage es where
data Action HouseholdPage
= RefreshHousehold
| CreateInviteAction
@@ -69,7 +69,7 @@ householdView :: Household -> [Membership] -> [Invite] -> View HouseholdPage ()
householdView h mems invs = do
el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ do
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" nbBoxClass @ att "style" "margin-bottom:1.5rem" $ mapM_ memberRow mems
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" "opacity:0.5" $ text (membershipEmail m)
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 i = do
@@ -105,9 +105,6 @@ initials name =
let ws = T.words name
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 = do
mSession <- lookupSession @UserSession
src/Sis/Page/Login.hs
+5 -4
View File
@@ -1,4 +1,5 @@
{-# 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
import Effectful
@@ -17,7 +18,7 @@ import Web.Hyperbole.Page
data LoginPage = LoginPage
deriving stock (Generic)
deriving anyclass (ViewId)
instance (DB :> es) => HyperView LoginPage es where
instance (DB :> es, IOE :> es) => HyperView LoginPage es where
data Action LoginPage
= SubmitLogin
| Noop
@@ -46,11 +47,11 @@ loginView mError = do
Nothing -> none
form SubmitLogin $ do
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"
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
tag "input" @ att "type" "checkbox" . att "name" "lfRemember"
tag "input" @ att "type" "checkbox" . att "name" "lfRemember" $ none
text "Remember me"
submit (text "Log In") @ att "class" nbButtonClass @ att "style" "width:100%"
route RouteSignup $ text "Don't have an account? Sign Up"
src/Sis/Page/Signup.hs
+8 -6
View File
@@ -1,4 +1,6 @@
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# 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
import Effectful
@@ -17,7 +19,7 @@ import Web.Hyperbole.Page
data SignupPage = SignupPage
deriving stock (Generic)
deriving anyclass (ViewId)
instance (DB :> es) => HyperView SignupPage es where
instance (DB :> es, IOE :> es) => HyperView SignupPage es where
data Action SignupPage
= SubmitSignup
deriving stock (Generic)
@@ -51,15 +53,15 @@ signupView mError = do
Nothing -> none
form SubmitSignup $ do
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"
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)"
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"
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
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"
submit (text "Sign Up") @ att "class" nbButtonClass @ att "style" "width:100%"
route RouteLogin $ text "Already have an account? Log In"