hyperbole 0.1.1 → 0.1.2
raw patch · 6 files changed
+160/−160 lines, 6 filesdep ~effectful
Dependency ranges changed: effectful
Files
- example/Example/Contacts.hs +4/−4
- hyperbole.cabal +4/−4
- src/Web/Hyperbole.hs +2/−2
- src/Web/Hyperbole/Forms.hs +145/−0
- src/Web/Hyperbole/HyperView.hs +5/−5
- src/Web/Hyperbole/Input.hs +0/−145
example/Example/Contacts.hs view
@@ -61,10 +61,10 @@ row (gap 10) $ do button (Reload Nothing) (bg GrayLight) "Reload" - dropdown Reload (== fil) $ do- option Nothing id ""- option (Just Active) id "Active!"- option (Just Inactive) id "Inactive"+ dropdown Reload (== fil) id $ do+ option Nothing ""+ option (Just Active) "Active!"+ option (Just Inactive) "Inactive" target (Contact 2) $ button Edit (bg GrayLight) "Edit 2"
hyperbole.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hyperbole-version: 0.1.1+version: 0.1.2 synopsis: Web Framework inspired by HTMX description: Web Framework inspired by HTMX. category: Web@@ -34,8 +34,8 @@ Web.Hyperbole.Application Web.Hyperbole.Effect Web.Hyperbole.Embed+ Web.Hyperbole.Forms Web.Hyperbole.HyperView- Web.Hyperbole.Input Web.Hyperbole.Route other-modules: Paths_hyperbole@@ -58,7 +58,7 @@ , bytestring >=0.11 && <0.13 , casing >0.1.3.0 && <0.2 , containers >=0.6 && <1- , effectful ==2.3.*+ , effectful >=2.3 && <3 , file-embed >=0.0.10 && <0.1 , http-api-data ==0.6.* , http-types >=0.12.3 && <0.13@@ -100,7 +100,7 @@ , bytestring >=0.11 && <0.13 , casing >0.1.3.0 && <0.2 , containers >=0.6 && <1- , effectful ==2.3.*+ , effectful >=2.3 && <3 , file-embed >=0.0.10 && <0.1 , http-api-data ==0.6.* , http-types >=0.12.3 && <0.13
src/Web/Hyperbole.hs view
@@ -3,7 +3,7 @@ , module Web.Hyperbole.Effect , module Web.Hyperbole.HyperView , module Web.Hyperbole.Application- , module Web.Hyperbole.Input+ , module Web.Hyperbole.Forms , module Web.View , Application , run@@ -15,8 +15,8 @@ import Web.Hyperbole.Application import Web.Hyperbole.Effect import Web.Hyperbole.Embed (scriptEmbed)+import Web.Hyperbole.Forms import Web.Hyperbole.HyperView-import Web.Hyperbole.Input import Web.Hyperbole.Route import Web.View hiding (button, form, input, label, link)
+ src/Web/Hyperbole/Forms.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE DefaultSignatures #-}++module Web.Hyperbole.Forms where++import Data.Functor.Identity (Identity)+import Data.Kind (Type)+import Data.Text+import Effectful+import Effectful.Dispatch.Dynamic+import GHC.Generics+import Text.Casing (kebab)+import Web.FormUrlEncoded qualified as FE+import Web.Hyperbole.Effect+import Web.Hyperbole.HyperView (HyperView (..), Param (..), dataTarget)+import Web.Internal.FormUrlEncoded (GFromForm, defaultFormOptions, genericFromForm)+import Web.View hiding (form, input)+++-- | The only time we can use Fields is inside a form+newtype FormFields f id = FormFields id+ deriving newtype (Show)+++instance (Param id, Show id) => Param (FormFields f id) where+ parseParam t = FormFields <$> parseParam t+ toParam (FormFields i) = toParam i+++instance (HyperView id, Show id) => HyperView (FormFields f id) where+ type Action (FormFields f id) = Action id+++-- | TODO: there are many more of these: https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes/autocomplete+data FieldInput+ = NewPassword+ | CurrentPassword+ | Username+ | Email+ | Number+ | TextInput+ | Name+ | OneTimeCode+ | Organization+ | StreetAddress+ | Country+ | CountryName+ | PostalCode+ | Search+ deriving (Show)+++data Label a+++data Input a = Input+++newtype InputName = InputName Text+++field :: Mod -> View (Input id) () -> View (FormFields form id) ()+field f cnt =+ tag "label" (f . flexCol)+ $ addContext Input cnt+++label :: Text -> View (Input id) ()+label = text+++input :: FieldInput -> Mod -> InputName -> View (Input id) ()+input fi f (InputName n) = tag "input" (f . name n . att "type" (typ fi) . att "autocomplete" (auto fi)) none+ where+ typ NewPassword = "password"+ typ CurrentPassword = "password"+ typ Number = "number"+ typ Email = "email"+ typ Search = "search"+ typ _ = "text"++ auto :: FieldInput -> Text+ auto = pack . kebab . show+++form :: forall form id. (Form form, HyperView id) => Action id -> Mod -> (form Label -> View (FormFields form id) ()) -> View id ()+form a f fcnt = do+ vid <- context+ let frm = formLabels :: form Label+ let cnt = fcnt frm+ tag "form" (onSubmit a . dataTarget vid . f . flexCol) $ addContext (FormFields vid) cnt+ where+ onSubmit :: (Param a) => a -> Mod+ onSubmit = att "data-on-submit" . toParam+++submit :: Mod -> View (FormFields form id) () -> View (FormFields form id) ()+submit f = tag "button" (att "type" "submit" . f)+++parseForm :: forall form es. (Form form, Hyperbole :> es) => Eff es (form Identity)+parseForm = do+ (f :: FE.Form) <- formData+ let ef = fromForm f :: Either Text (form Identity)+ either (send . HyperError . ParseError) pure ef+++class Form (form :: (Type -> Type) -> Type) where+ formLabels :: form Label+ default formLabels :: (Generic (form Label), GFormLabels (Rep (form Label))) => form Label+ formLabels = to gFormLabels+++ fromForm :: FE.Form -> Either Text (form Identity)+ default fromForm :: (Generic (form Identity), GFromForm (form Identity) (Rep (form Identity))) => FE.Form -> Either Text (form Identity)+ fromForm = genericFromForm defaultFormOptions+++type family Field (context :: Type -> Type) a+type instance Field Identity a = a+type instance Field Label a = InputName+++-- | Automatically derive labels from form field names+class GFormLabels f where+ gFormLabels :: f p+++instance GFormLabels U1 where+ gFormLabels = U1+++instance (GFormLabels f, GFormLabels g) => GFormLabels (f :*: g) where+ gFormLabels = gFormLabels :*: gFormLabels+++instance (Selector s) => GFormLabels (M1 S s (K1 R InputName)) where+ gFormLabels = M1 . K1 $ InputName $ pack (selName (undefined :: M1 S s (K1 R Text) p))+++instance (GFormLabels f) => GFormLabels (M1 D d f) where+ gFormLabels = M1 gFormLabels+++instance (GFormLabels f) => GFormLabels (M1 C c f) where+ gFormLabels = M1 gFormLabels
src/Web/Hyperbole/HyperView.hs view
@@ -47,23 +47,23 @@ :: (HyperView id) => (opt -> action) -> (opt -> Bool)+ -> Mod -> View (Option opt id action) () -> View id ()-dropdown toAction isSel options = do+dropdown toAction isSel f options = do c <- context- tag "select" (att "data-on-change" "" . dataTarget c) $ do+ tag "select" (att "data-on-change" "" . dataTarget c . f) $ do addContext (Option toAction isSel) options option :: (HyperView id, Eq opt) => opt- -> Mod -> View (Option opt id (Action id)) () -> View (Option opt id (Action id)) ()-option opt f cnt = do+option opt cnt = do os <- context- tag "option" (att "value" (toParam (os.toAction opt)) . selected (os.selected opt) . f) cnt+ tag "option" (att "value" (toParam (os.toAction opt)) . selected (os.selected opt)) cnt selected :: Bool -> Mod
− src/Web/Hyperbole/Input.hs
@@ -1,145 +0,0 @@-{-# LANGUAGE DefaultSignatures #-}--module Web.Hyperbole.Input where--import Data.Functor.Identity (Identity)-import Data.Kind (Type)-import Data.Text-import Effectful-import Effectful.Dispatch.Dynamic-import GHC.Generics-import Text.Casing (kebab)-import Web.FormUrlEncoded qualified as FE-import Web.Hyperbole.Effect-import Web.Hyperbole.HyperView (HyperView (..), Param (..), dataTarget)-import Web.Internal.FormUrlEncoded (GFromForm, defaultFormOptions, genericFromForm)-import Web.View hiding (form, input)----- | The only time we can use Fields is inside a form-newtype FormFields f id = FormFields id- deriving newtype (Show)---instance (Param id, Show id) => Param (FormFields f id) where- parseParam t = FormFields <$> parseParam t- toParam (FormFields i) = toParam i---instance (HyperView id, Show id) => HyperView (FormFields f id) where- type Action (FormFields f id) = Action id----- | TODO: there are many more of these: https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes/autocomplete-data FieldInput- = NewPassword- | CurrentPassword- | Username- | Email- | Number- | TextInput- | Name- | OneTimeCode- | Organization- | StreetAddress- | Country- | CountryName- | PostalCode- | Search- deriving (Show)---data Label a---data Input a = Input---newtype InputName = InputName Text---field :: Mod -> View (Input id) () -> View (FormFields form id) ()-field f cnt =- tag "label" (f . flexCol)- $ addContext Input cnt---label :: Text -> View (Input id) ()-label = text---input :: FieldInput -> Mod -> InputName -> View (Input id) ()-input fi f (InputName n) = tag "input" (f . name n . att "type" (typ fi) . att "autocomplete" (auto fi)) none- where- typ NewPassword = "password"- typ CurrentPassword = "password"- typ Number = "number"- typ Email = "email"- typ Search = "search"- typ _ = "text"-- auto :: FieldInput -> Text- auto = pack . kebab . show---form :: forall form id. (Form form, HyperView id) => Action id -> Mod -> (form Label -> View (FormFields form id) ()) -> View id ()-form a f fcnt = do- vid <- context- let frm = formLabels :: form Label- let cnt = fcnt frm- tag "form" (onSubmit a . dataTarget vid . f . flexCol) $ addContext (FormFields vid) cnt- where- onSubmit :: (Param a) => a -> Mod- onSubmit = att "data-on-submit" . toParam---submit :: Mod -> View (FormFields form id) () -> View (FormFields form id) ()-submit f = tag "button" (att "type" "submit" . f)---parseForm :: forall form es. (Form form, Hyperbole :> es) => Eff es (form Identity)-parseForm = do- (f :: FE.Form) <- formData- let ef = fromForm f :: Either Text (form Identity)- either (send . HyperError . ParseError) pure ef---class Form (form :: (Type -> Type) -> Type) where- formLabels :: form Label- default formLabels :: (Generic (form Label), GFormLabels (Rep (form Label))) => form Label- formLabels = to gFormLabels--- fromForm :: FE.Form -> Either Text (form Identity)- default fromForm :: (Generic (form Identity), GFromForm (form Identity) (Rep (form Identity))) => FE.Form -> Either Text (form Identity)- fromForm = genericFromForm defaultFormOptions---type family Field (context :: Type -> Type) a-type instance Field Identity a = a-type instance Field Label a = InputName----- | Automatically derive labels from form field names-class GFormLabels f where- gFormLabels :: f p---instance GFormLabels U1 where- gFormLabels = U1---instance (GFormLabels f, GFormLabels g) => GFormLabels (f :*: g) where- gFormLabels = gFormLabels :*: gFormLabels---instance (Selector s) => GFormLabels (M1 S s (K1 R InputName)) where- gFormLabels = M1 . K1 $ InputName $ pack (selName (undefined :: M1 S s (K1 R Text) p))---instance (GFormLabels f) => GFormLabels (M1 D d f) where- gFormLabels = M1 gFormLabels---instance (GFormLabels f) => GFormLabels (M1 C c f) where- gFormLabels = M1 gFormLabels