Elm Example: basic multitabbed text entry form

Elm example: Multitab GUI

import Graphics.Input (input, button, Input)
import Graphics.Input.Field (input, button, defaultStyle, noContent, Content)
import Graphics.Input.Field
import Graphics.Element
import List
import Dict (Dict)
import Dict
import Maybe (maybe)

data DDict k v = DDict v (Dict k v)
data RDict k v = RDict (DDict k (RDict k v -> v))
data RInputDict k v = RInputDict (DDict k (Input (RDict k v -> v)))

makeDict : (() -> v) -> [comparable] -> DDict comparable v
makeDict f keys =
  DDict (f()) <| List.foldl (\k dict -> Dict.insert k (f()) dict) Dict.empty keys

getDict : comparable -> DDict comparable v -> v
getDict k (DDict v dict) = Dict.getOrElse v k dict

getRDict : comparable -> RDict comparable v -> (RDict comparable v -> v)
getRDict k (RDict dict) = getDict k dict

getRInputDict : comparable -> RInputDict comparable v ->
  Input (RDict comparable v -> v)
getRInputDict k (RInputDict dict) = getDict k dict

liftDict : DDict comparable (Input v) -> Signal (DDict comparable v)
liftDict (DDict v dict) = DDict <~ v.signal ~
  List.foldl liftValue (constant Dict.empty) (Dict.toList dict)
liftValue (k,v) dict = Dict.insert k <~ v.signal ~ dict

liftRDict : RInputDict comparable v -> Signal (RDict comparable v)
liftRDict (RInputDict dict) = RDict <~ liftDict dict

fields : DDict String (Input Content)
fields = makeDict (\_ -> input noContent)
  ["Name", "Address Line 1", "Address Line 2", "Address Line 3", "Postcode",
          "Question 1", "Question 2", "Question 3"]

screens : RInputDict String (DDict String Content -> Element)
screens = RInputDict <|
  makeDict (\_ -> input (\_ _ -> Graphics.Element.empty))
  ["Main", "Text", "Shapes"]

type Screen = RDict String (DDict String Content -> Element)
  -> DDict String Content -> Element

getScreenInput : String -> Input Screen
getScreenInput k = getRInputDict k screens

field name info = plainText (name ++ ": ") `beside`
  Graphics.Input.Field.field defaultStyle
    (getDict name fields).handle id "" (getDict name info)
    


main = mainmenu <~ liftRDict screens ~ liftDict fields

mainmenu contents info =
  let screen = getScreenInput "Main" in
  flow down [
    flow right [ button screen.handle menu "Text",
                 button screen.handle shapes "Shapes",
                 button screen.handle address "Address",
                 button screen.handle pentagon "Pentagon"],
    (getRDict "Main" contents) contents info
  ]

menu contents info =
  let screen = getScreenInput "Text" in
  flow down [
    flow right [ button screen.handle address "Address screen",
                 button screen.handle quiz "Quiz screen" ],
    (getRDict "Text" contents) contents info
  ]
  
address contents info =
  flow down [
    field "Name" info,
    field "Address Line 1" info,
    field "Address Line 2" info,
    field "Address Line 3" info,
    field "Postcode" info
  ]
quiz contents info =
  flow down [
    field "Question 1" info,
    field "Question 2" info,
    field "Question 3" info
  ]
  
shapes contents info =
  let screen = getScreenInput "Shapes" in
  flow down [
    flow right [ button screen.handle square "Square screen",
                 button screen.handle pentagon "Pentagon screen" ],
    (getRDict "Shapes" contents) contents info
  ]
  
square contents info = collage 200 200 [filled blue <| ngon 4 100]

pentagon contents info = collage 200 200 [filled purple <| ngon 5 100]