From 498ae348d120f156c65a89c87d9852393b23e2f4 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Mon, 11 Jul 2022 23:33:01 +0200
Subject: somewhat functioning control room

tbh i've kinda lost track at what has all been changed in this, but the
control room form handling now works, and i can write announcements into
the database. Now on to making it do useful things!
---
 lib/Lucid/Forms.hs | 32 +++++++++++++++++++++-----------
 1 file changed, 21 insertions(+), 11 deletions(-)

(limited to 'lib/Lucid')

diff --git a/lib/Lucid/Forms.hs b/lib/Lucid/Forms.hs
index 26be845..918c942 100644
--- a/lib/Lucid/Forms.hs
+++ b/lib/Lucid/Forms.hs
@@ -11,7 +11,12 @@
 {-# LANGUAGE TypeOperators       #-}
 
 
-module Lucid.Forms (GToHtmlForm(..), GToHtmlFormInput(..), ToHtmlForm(..), ToHtmlFormInput(..)) where
+module Lucid.Forms ( GToHtmlForm(..)
+                   , GToHtmlFormInput(..)
+                   , ToHtmlForm(..)
+                   , ToHtmlFormInput(..)
+                   , HtmlFormOptions(..)
+                   ) where
 
 import           Data.Maybe           (maybeToList)
 import           Data.Proxy           (Proxy (..))
@@ -21,10 +26,11 @@ import           Data.Time            (Day)
 import           GHC.Generics         (C1, D1, Generic (Rep), K1, Meta (..),
                                        Rec0, S1, U1, type (:*:), type (:+:))
 import           GHC.TypeLits         (KnownSymbol, symbolVal)
-import           Lucid                (Html, ToHtml (toHtml), action_, div_,
-                                       for_, form_, id_, input_, label_,
+import           Lucid                (Html, HtmlT, ToHtml (toHtml), action_,
+                                       div_, for_, form_, id_, input_, label_,
                                        method_, name_, placeholder_, type_,
                                        value_)
+import           Lucid.Base           (relaxHtmlT)
 import           Text.ProtocolBuffers (Default (defaultValue))
 
 class GToHtmlFormInput a where
@@ -57,6 +63,10 @@ instance ToHtmlFormInput Text where
   toFormInput name _ = input_ [type_ "text", name_ name, placeholder_ name]
 instance ToHtmlFormInput Day where
   toFormInput name _ = input_ [type_ "text", name_ name]
+instance ToHtmlFormInput Bool where
+  toFormInput name _ = input_ [type_ "checkbox", name_ name]
+instance ToHtmlFormInput (Maybe Bool) where
+  toFormInput name _ = input_ [type_ "checkbox", name_ name]
 
 
 -- | generic conversion of record data types to input forms
@@ -82,14 +92,14 @@ instance GToHtmlForm a => GToHtmlForm (C1 r a) where
 
 -- | class for things which can be entered via html forms
 class ToHtmlForm a where
-  toHtmlForm :: Proxy a -> Html ()
-  default toHtmlForm :: (GToHtmlForm (Rep a)) => Proxy a -> Html ()
-  toHtmlForm = genericToHtmlForm defaultOptions
+  toHtmlForm :: Monad m => HtmlFormOptions -> Proxy a -> HtmlT m ()
+  default toHtmlForm :: (GToHtmlForm (Rep a), Monad m) => HtmlFormOptions -> Proxy a -> HtmlT m ()
+  toHtmlForm options = relaxHtmlT . genericToHtmlForm options
 
 data HtmlFormOptions = HtmlFormOptions
-  { htmlFormAction           :: Maybe Text
-  , htmlFormMethod           :: Text
-  , htmlFormSubmitButtonText :: Text
+  { formAction           :: Maybe Text
+  , formMethod           :: Text
+  , formSubmitButtonText :: Text
   }
 
 defaultOptions ::HtmlFormOptions
@@ -100,6 +110,6 @@ instance Default HtmlFormOptions where
 
 genericToHtmlForm :: (GToHtmlForm (Rep a2)) => HtmlFormOptions -> Proxy a2 -> Html ()
 genericToHtmlForm HtmlFormOptions{..} (Proxy :: Proxy a) =
-  form_ ((method_ htmlFormMethod) : maybeToList (fmap action_ htmlFormAction)) $ do
+  form_ ((method_ formMethod) : maybeToList (fmap action_ formAction)) $ do
     gtoHtmlForm (Proxy @(Rep a _))
-    input_ [type_ "submit", value_ htmlFormSubmitButtonText]
+    input_ [type_ "submit", value_ formSubmitButtonText]
-- 
cgit v1.2.3