1
\$\begingroup\$

With the dynamic/reactive UI Elm seems like an ideal language for writing this kind of thing, but the code is coming out a lot messier than I thought it would - but then this is my first time seriously using Elm. Can anyone suggest improvements?

import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events exposing (..)
import List exposing (map, head, length, filter, sortBy)
import Html.App as Html
import Json.Decode exposing (Decoder, decodeString, (:=), object4, string, list, int, at)
import Http exposing (getString, Error)
import Task exposing (perform)
import Result exposing (withDefault)

main = Html.program { init = init, view = view, update = update, subscriptions = subscriptions }

type Msg =
    SkillChanged String Bool 
  | BackgroundChanged String 
  | OriginChanged String
  | BackgroundsLoaded String
  | HTTPLoadError Error 

subscriptions : Model -> Sub Msg
subscriptions _ = Sub.none

-- Some utilities for quickly making strings into HTML options for use in selects.
stringToOption : String -> Html msg
stringToOption s = option [] [text s]

stringsToOptions : List String -> List (Html msg)
stringsToOptions = map stringToOption

type alias Model =
    { character : Character,
      database : Database }

type alias Character = 
    { background : Background,
      origin : Origin,  
      skills : List Skill,
      kits : List Kit,
      kitadvances : List KitAdvance }

type alias Database = 
    { backgrounds : List Background }

type alias Skill =
    { active : Bool,
      name : String,
      source : Int }

type alias Background =
    { name : String,
      skillNames : List String,
      wealth : Int,
      trick : String }

type alias Origin =
    { name : String,
      skillNames : List String,
      complications : List String }

type alias Kit =
  { name : String,
    base : String,
    advances : List KitAdvance }

type alias KitAdvance = 
  { name : String,
    desc : String }


nullBackground : Background
nullBackground = { name="<Not Selected>", skillNames=[], wealth=0, trick=""}
nullOrigin : Origin
nullOrigin = { name="<Not Selected>",skillNames=[],complications=[]}
nullKit : Kit
nullKit = { name="<Not Selected>",base="",advances=[]}

blankCharacter = { skills = [],
          background = nullBackground,
          origin = nullOrigin,
          kits = [nullKit],
          kitadvances = [] }

blankDatabase = { backgrounds = [] }

init = ({character = blankCharacter,
         database = blankDatabase},
         perform (\e -> HTTPLoadError e) (\s -> BackgroundsLoaded s) (getString "backgrounds.json"))

origins : List Origin
origins = [ nullOrigin,
 {name="Shade", skillNames=["Stealth","Ancient History"],complications=[]}
 ]

sourceName : Int -> String
sourceName s = case s of 
    0 -> "Background"
    1 -> "Origin"
    _ -> "Broken"



-- Generates the HTML skill table row for a skill.
skillToHtmlTableRow : Skill -> Html Msg
skillToHtmlTableRow s = tr [] [(td [] [input [ type' "checkbox", checked s.active, onCheck (SkillChanged s.name)] []]),
                               (td [] [text s.name]),
                               (td [] [text (sourceName s.source)])]

quickTh : String -> Html Msg
quickTh s = th [] [text s]

skillTableHeader : Html Msg
skillTableHeader = tr [] (map quickTh ["Active?", "Name", "Source"])

skillTable : Model -> Html Msg
skillTable m = table [] [thead [] [skillTableHeader], (tbody [] (map skillToHtmlTableRow (sortBy .name m.character.skills)))]





-- For some reason Elm modified the HTML library so that instead of passing Html.Events.on a function to apply
-- to the decoded value, you have to roll it into the decoder. So here's a function that rolls another function
-- into a targetvalue decoder.
targetAndWrap : (String -> Msg) -> Decoder Msg
targetAndWrap f = Json.Decode.map f targetValue

maybeToResult : String -> (Maybe a) -> (Result String a)
maybeToResult err may = case may of
    Just x -> Ok x
    Nothing -> Err err

-- Gets the one member of a list that satisfies a condition, or throws an error if there's none or more than
-- one.
theOne : (a -> Bool) -> List a -> (Result String a)
theOne f l = 
    let filteredList = (filter f l) in
    case (length filteredList) of
        2 -> Err "Multiple entries matched theOne"
        _ -> maybeToResult "No entry matched theOne" (head filteredList)



-- Used within genericListPicker to generate the individual options.
genericListOption : (a -> String) -> (Model -> a) -> Model -> a -> Html Msg
genericListOption nameExtractor modelComponent model x =
    option [selected ((modelComponent model) == x)] [text (nameExtractor x)]


-- Generates a list picker.
-- nameExtractor: function to apply to a model member to get the name to show in the list.
-- modelComponent: function to apply to a model to get the member to refer to.
-- messageGenerator: function to apply to the chosen option to get the message to send.
-- theList: list of components to pick from.
genericListPicker : (a -> String) -> (Model -> a) -> (String -> Msg) -> List a -> Model -> Html Msg
genericListPicker nameExtractor modelComponent messageGenerator theList model =
    select [(Html.Events.on "change" (targetAndWrap messageGenerator))] (map (genericListOption nameExtractor modelComponent model) theList)

backgroundPicker : Model -> Html Msg
backgroundPicker model = genericListPicker .name (.character >> .background) BackgroundChanged model.database.backgrounds model

originPicker : Model -> Html Msg
originPicker = genericListPicker .name (.character >> .origin) OriginChanged origins

skillNameToSkill source name = { active = False, name = name, source = source }

addSkillsWithSource source newskills skills =
   skills ++ map (skillNameToSkill source) newskills

wipeSkillsWithSource : Int -> List Skill -> List Skill 
wipeSkillsWithSource target = filter (\s -> s.source /= target) 

switchSkillsWithSource source newskills oldskills =
    addSkillsWithSource source (newskills) (wipeSkillsWithSource source oldskills)

fetchAndUpdate : List a -> String -> (a -> String) -> (a -> Model -> Model) -> Model -> Model
fetchAndUpdate theList target nameExtractor updater model =
    case (theOne (\x -> (nameExtractor x) == target) theList) of
        Ok x -> updater x model
        Err _ -> model


updateCharacter : (a -> Character -> Character) -> a -> Model -> Model
updateCharacter updater updata model = let oldchar = model.character in {model | character = (updater updata oldchar) }

updateDatabase : (Database -> Database) -> Model -> Model
updateDatabase updater model = let olddb = model.database in {model | database = (updater olddb) }



updateForNewBackground : Background -> Character -> Character 
updateForNewBackground newbg model = 
    { model | background = newbg, skills = (switchSkillsWithSource 0 newbg.skillNames model.skills) } 

applyBackgroundChange : String -> Model -> Model
applyBackgroundChange newname model =
    fetchAndUpdate model.database.backgrounds newname .name (updateCharacter updateForNewBackground) model

updateForNewOrigin newo model =
    { model  | origin = newo, skills = (switchSkillsWithSource 1 newo.skillNames model.skills) }

applyOriginChange newname model =
    fetchAndUpdate origins newname .name (updateCharacter updateForNewOrigin) model

httpError : Model -> Model
httpError model = (updateDatabase (\db -> { db | backgrounds = [nullBackground] } )) model



dbDebug model = div [] (map (.name >> text) model.database.backgrounds)

backgroundsDecoder : Decoder (List Background)
backgroundsDecoder = "backgrounds" := (Json.Decode.list backgroundDecoder)

backgroundDecoder : Decoder Background
backgroundDecoder = 
  object4 Background
    ("name" := string)
    ("skillNames" := Json.Decode.list string)
    ("wealth" := int)
    ("trick" := string)

unpackBackgrounds : String -> Model -> Model
unpackBackgrounds s model = updateDatabase ( \d -> 
       { d | backgrounds = [nullBackground] ++ (withDefault [] (decodeString backgroundsDecoder s))}) model

view : Model -> Html Msg
view model = div [] [backgroundPicker model, originPicker model, skillTable model, dbDebug model]

update : Msg -> Model -> (Model, Cmd Msg)
update msg model = case msg of 
    BackgroundChanged x -> (applyBackgroundChange x model, Cmd.none)
    OriginChanged x -> (applyOriginChange x model, Cmd.none)
    HTTPLoadError e -> (httpError model, Cmd.none)
    BackgroundsLoaded bgs -> (unpackBackgrounds bgs model, Cmd.none)
    _ -> (model, Cmd.none)
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.