aboutsummaryrefslogtreecommitdiffstats
path: root/frontend/app/Form/Internal.hs
blob: 35d59e7445d1125eef400bd72c1f0e4537883f42 (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
module Form.Internal
  ( Form (..),
    mapValues,
    runForm,
    optional,
  )
where

import Miso
import Miso.String (MisoString, null, strip)

data Form i o = Form
  { view :: i -> [View i],
    fill :: i -> Either MisoString o
  }

instance Functor (Form i) where
  fmap f (Form {view, fill}) =
    Form
      { fill = fmap f . fill,
        ..
      }

instance Applicative (Form i) where
  pure x =
    Form
      { view = const [],
        fill = const (Right x)
      }

  f <*> x =
    Form
      { view = liftA2 (<>) f.view x.view,
        fill = \i -> ($) <$> f.fill i <*> x.fill i
      }

instance Monad (Form i) where
  form >>= mkForm =
    Form
      { view = \i ->
          form.view i
            <> case form.fill i of
              Right x -> (mkForm x).view i
              Left _ -> [],
        fill = \i -> case form.fill i of
          Right x -> (mkForm x).fill i
          Left e -> Left e
      }

mapValues :: (i' -> i) -> (i -> i' -> i') -> Form i o -> Form i' o
mapValues get set (Form {view, fill}) =
  Form
    { view = \i -> fmap (flip set i) <$> view (get i),
      fill = fill . get
    }

runForm :: Form i o -> i -> View (Either i o)
runForm form i =
  form_ [onSubmit (either (\_ -> Left i) (Right) (form.fill i))] $
    (fmap Left <$> form.view i)
      <> [button_ [type_ "submit"] [text "submit"]]

class IsEmpty i where
  isEmpty :: i -> Bool

instance IsEmpty MisoString where
  isEmpty = Miso.String.null . strip

optional :: (IsEmpty i) => Form i o -> Form i (Maybe o)
optional form =
  Form
    { view = \i -> form.view i,
      fill = \i -> if isEmpty i then Right Nothing else Just <$> form.fill i
    }