aboutsummaryrefslogtreecommitdiff
path: root/lib/Lucid/Forms.hs
diff options
context:
space:
mode:
authorstuebinm2022-08-14 15:44:19 +0200
committerstuebinm2022-08-14 15:44:19 +0200
commitce14bc010a8f97cd3bab6f5cbd998f614b811546 (patch)
tree854b2726c68b9be3925d8ad222f6afce8b2378a7 /lib/Lucid/Forms.hs
parentf13e72076dbdcf0cd53d8558fccbedb98b8ea492 (diff)
controlroom: replace servant/lucid with yesod
aka use something meant for webapps to write the webapp
Diffstat (limited to 'lib/Lucid/Forms.hs')
-rw-r--r--lib/Lucid/Forms.hs115
1 files changed, 0 insertions, 115 deletions
diff --git a/lib/Lucid/Forms.hs b/lib/Lucid/Forms.hs
deleted file mode 100644
index 918c942..0000000
--- a/lib/Lucid/Forms.hs
+++ /dev/null
@@ -1,115 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeOperators #-}
-
-
-module Lucid.Forms ( GToHtmlForm(..)
- , GToHtmlFormInput(..)
- , ToHtmlForm(..)
- , ToHtmlFormInput(..)
- , HtmlFormOptions(..)
- ) where
-
-import Data.Maybe (maybeToList)
-import Data.Proxy (Proxy (..))
-import Data.Text (Text)
-import qualified Data.Text as T
-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, 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
- gtoHtmlFormInput :: Text -> Proxy (a p) -> Html ()
-
-instance (KnownSymbol name)
- => GToHtmlFormInput (C1 (MetaCons name f s) U1) where
- gtoHtmlFormInput group _ = do
- input_ [type_ "radio", id_ name, value_ name, name_ group] -- need a shared name for all options here
- label_ [for_ name] (toHtml name)
- where name = T.pack (symbolVal (Proxy @name))
-
-instance (GToHtmlFormInput l, GToHtmlFormInput r) => GToHtmlFormInput (l :+: r) where
- gtoHtmlFormInput group _ = do
- gtoHtmlFormInput group (Proxy @(l _))
- gtoHtmlFormInput group (Proxy @(r _))
-
--- | ignore constructor & type metainfo
-instance GToHtmlFormInput a => GToHtmlFormInput (D1 r a) where
- gtoHtmlFormInput group _ = gtoHtmlFormInput group (Proxy @(a _))
-
--- | class for things which can be (single) options (i.e. a single input-tag or
--- | a group of radio buttons) in an html form
-class ToHtmlFormInput a where
- toFormInput :: Text -> Proxy a -> Html ()
- default toFormInput :: (GToHtmlFormInput (Rep a)) => Text -> Proxy a -> Html ()
- toFormInput group p = gtoHtmlFormInput group (Proxy @(Rep a _))
-
-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
-class GToHtmlForm a where
- gtoHtmlForm :: Proxy (a p) -> Html ()
-
--- | each record field is a form input
-instance (KnownSymbol name, ToHtmlFormInput a)
- => GToHtmlForm (S1 (MetaSel (Just name) su ss ds) (Rec0 a)) where
- gtoHtmlForm _ = toFormInput (T.pack (symbolVal (Proxy @name))) (Proxy @a)
-
--- | just chain all fields
-instance (GToHtmlForm l, GToHtmlForm r) => GToHtmlForm (l :*: r) where
- gtoHtmlForm _ = do
- gtoHtmlForm (Proxy @(l _))
- gtoHtmlForm (Proxy @(r _))
-
--- | ignore constructor & type metainfo
-instance GToHtmlForm a => GToHtmlForm (D1 r a) where
- gtoHtmlForm _ = gtoHtmlForm (Proxy @(a _))
-instance GToHtmlForm a => GToHtmlForm (C1 r a) where
- gtoHtmlForm _ = gtoHtmlForm (Proxy @(a _))
-
--- | class for things which can be entered via html forms
-class ToHtmlForm a where
- 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
- { formAction :: Maybe Text
- , formMethod :: Text
- , formSubmitButtonText :: Text
- }
-
-defaultOptions ::HtmlFormOptions
-defaultOptions = HtmlFormOptions Nothing "post" "Ok"
-
-instance Default HtmlFormOptions where
- defaultValue = defaultOptions
-
-genericToHtmlForm :: (GToHtmlForm (Rep a2)) => HtmlFormOptions -> Proxy a2 -> Html ()
-genericToHtmlForm HtmlFormOptions{..} (Proxy :: Proxy a) =
- form_ ((method_ formMethod) : maybeToList (fmap action_ formAction)) $ do
- gtoHtmlForm (Proxy @(Rep a _))
- input_ [type_ "submit", value_ formSubmitButtonText]