diff options
Diffstat (limited to 'lib/Lucid')
-rw-r--r-- | lib/Lucid/Forms.hs | 105 |
1 files changed, 105 insertions, 0 deletions
diff --git a/lib/Lucid/Forms.hs b/lib/Lucid/Forms.hs new file mode 100644 index 0000000..26be845 --- /dev/null +++ b/lib/Lucid/Forms.hs @@ -0,0 +1,105 @@ +{-# 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(..)) 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, ToHtml (toHtml), action_, div_, + for_, form_, id_, input_, label_, + method_, name_, placeholder_, type_, + value_) +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] + + +-- | 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 :: Proxy a -> Html () + default toHtmlForm :: (GToHtmlForm (Rep a)) => Proxy a -> Html () + toHtmlForm = genericToHtmlForm defaultOptions + +data HtmlFormOptions = HtmlFormOptions + { htmlFormAction :: Maybe Text + , htmlFormMethod :: Text + , htmlFormSubmitButtonText :: 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_ htmlFormMethod) : maybeToList (fmap action_ htmlFormAction)) $ do + gtoHtmlForm (Proxy @(Rep a _)) + input_ [type_ "submit", value_ htmlFormSubmitButtonText] |