1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
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]
|
