diff options
Diffstat (limited to 'lib/Lucid')
-rw-r--r-- | lib/Lucid/Forms.hs | 115 |
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] |