aboutsummaryrefslogtreecommitdiff
path: root/lib/Lucid/Forms.hs
blob: 918c942f6e864382c5a6c2adbbbe57b911f1c013 (plain)
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
106
107
108
109
110
111
112
113
114
115
{-# 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]