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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
|
module Form.Input
( inputText,
inputNumber,
inputUnion,
TypeName (..),
Type (..),
typeName,
stringToTypeName,
)
where
import Control.Applicative
import Control.Arrow (first, second)
import Data.Aeson qualified as A
import Data.Map qualified as M
import Data.Maybe (fromMaybe)
import Form.Internal
import GHC.Generics (Generic)
import Miso
import Miso.String (MisoString, fromMisoString, null, strip, toMisoString)
data TypeName = StringType | NumberType
deriving (Eq, Ord, Generic)
instance IsEmpty (TypeName, M.Map TypeName MisoString) where
isEmpty (k, kvs) = isEmpty (fromMaybe "" (M.lookup k kvs))
instance A.FromJSON TypeName
instance A.ToJSON TypeName
instance A.FromJSONKey TypeName
instance A.ToJSONKey TypeName
data Type = IsNumber Double | IsString MisoString
instance A.ToJSON Type where
toJSON (IsNumber x) = A.Number (realToFrac x)
toJSON (IsString x) = A.String x
instance A.FromJSON Type where
parseJSON = \case
A.Number x -> pure (IsNumber (realToFrac x))
A.String x -> pure (IsString x)
_ -> fail ""
typeName :: Type -> TypeName
typeName (IsNumber _) = NumberType
typeName (IsString _) = StringType
stringToTypeName :: MisoString -> TypeName
stringToTypeName "number" = NumberType
stringToTypeName "string" = StringType
stringToTypeName _ = StringType
inputUnion :: MisoString -> [TypeName] -> Form (TypeName, M.Map TypeName MisoString) (Maybe Type)
inputUnion label types =
foldl1 (<|>)
<$> mapM
( \case
StringType ->
mapValues
( \(selectedType, typeInputs) ->
( selectedType == StringType,
M.findWithDefault "" StringType typeInputs
)
)
( \(checked, inputString) (selectedType, typeInputs) ->
( if checked then StringType else selectedType,
M.insert StringType inputString typeInputs
)
)
$ fmap (fmap IsString)
$ withRadio
$ inputText label
NumberType ->
mapValues
( \(selectedType, typeInputs) ->
( selectedType == NumberType,
M.findWithDefault "" NumberType typeInputs
)
)
( \(checked, inputString) (selectedType, typeInputs) ->
( if checked then NumberType else selectedType,
M.insert NumberType inputString typeInputs
)
)
$ fmap (fmap IsNumber)
$ withRadio
$ inputNumber label
)
types
radio :: Form Bool Bool
radio =
Form
{ view = \checked ->
[ div_ [] $
[ input_
[ type_ "radio",
checked_ checked,
onClick (not checked)
]
]
],
fill = Right
}
withRadio :: Form i o -> Form (Bool, i) (Maybe o)
withRadio form =
(\(checked, x) -> if checked then Just x else Nothing)
<$> liftA2
(,)
(mapValues fst (first . const) radio)
(mapValues snd (second . const) form)
inputNumber :: MisoString -> Form MisoString Double
inputNumber label =
let parse :: MisoString -> Either MisoString Double
parse i =
let i' = strip i
in if Miso.String.null i' then Left "required" else Right (read (fromMisoString i'))
in Form
{ view = \i ->
[ div_ [] $
[ label_ [] $
[ text label,
div_ [] $
[ input_
[ type_ "number",
value_ (toMisoString (show i)),
onInput id
],
div_ [] $
[either text (\_ -> text "") (parse i)]
]
]
]
],
fill = parse
}
inputText :: MisoString -> Form MisoString MisoString
inputText label =
let parse :: MisoString -> Either MisoString MisoString
parse i =
let i' = strip i
in if Miso.String.null i' then Left "required" else Right i'
in Form
{ view = \i ->
[ div_ [] $
[ label_ [] $
[ text label,
div_ [] $
[ input_
[ type_ "text",
value_ i,
onInput id
],
div_ [] $
[either text (\_ -> text "") (parse i)]
]
]
]
],
fill = parse
}
|
