@@ -1,68 +0,0 @@
1−
2−module Form where
3−
4−import Data.Maybe (mapMaybe)
5−import Foreign.JavaScript
6−import Signal.Input
7−import Signal.Window as Win
8−
9−foreign export jsevent "redirect"
10− redirectTo :: Signal JSString
11−
12−
13−-- Helpers
14−
15−isEmpty xs = case xs of { [] -> True ; _ -> False }
16−
17−getErrors first last email remail =
18− mapMaybe (\(err,msg) -> if err then Just msg else Nothing)
19− [ (isEmpty first , "First name required.")
20− , (isEmpty last , "Last name required.")
21− , (isEmpty email , "Must enter your email address.")
22− , (isEmpty remail , "Must re-enter your email address.")
23− , (email /= remail, "Email addresses do not match.")
24− ]
25−
26−url first last email =
27− "login?first=" ++ first ++ "&last=" ++ last ++ "&email="++ email
28−
29−
30−-- Signals
31−
32−(firstBox , first) = textField "First Name"
33−(lastBox , last) = textField "Last Name"
34−(emailBox , email) = textField "Your Email"
35−(remailBox, remail) = textField "Re-enter Email"
36−(butn , press) = button "Submit"
37−
38−pressCount = foldp (\p c -> if p then c+1 else c) 0 press
39−errors = lift4 getErrors first last email remail
40−sendable = lift2 (&&) press (lift isEmpty errors)
41−
42−redirectTo = lift castStringToJSString $
43− keepWhen sendable "" (lift3 url first last email)
44−
45−
46−-- Display
47−
48−field txt fld =
49− width 400 . flow right $
50− [ size 120 30 . box 6 $ plainText txt
51− , size 200 30 . box 5 $ size 180 20 fld
52− ]
53−
54−showErrors presses errs =
55− if presses == 0 || isEmpty errs then rectangle 10 10 else
56− flow down $ map (text . Text.color red . toText) errs
57−
58−form presses errs (w,h) =
59− size w h . box 5 . color (rgb 230 230 230) . flow down $
60− [ field "First Name:" firstBox
61− , field "Last Name:" lastBox
62− , field "Your Email:" emailBox
63− , field "Re-enter Email:" remailBox
64− , showErrors presses errs
65− , size 310 40 . box 6 $ size 60 30 butn
66− ]
67−
68−main = lift3 form pressCount errors Win.dimensions