Move Dict / Parameters conversion into generic modules I'll use these in URL parsing / serializing too.

Changes

3 changed files (+375/-374)

• src/Parameters.elm
  • @@ -9,7 +9,9 @@
    module Parameters exposing (..) - import Length exposing (Length, mm) + import Dict exposing (Dict) + import Length exposing (Length, mm, toMM) + import Parameters.Key as Key exposing (Key(..)) type TipShape
  • @@ -218,3 +220,70 @@ , lineWidth = mm 0.3
    , colorSchema = BlackOnWhite } } + + + type alias ParametersDict = + Dict String String + + + toDict : Parameters -> Dict String String + toDict params = + [ Just ( Key.toString LugWidth, String.fromFloat (toMM params.lugWidth) ) + , Just ( Key.toString SurfaceThickness, String.fromFloat (toMM params.thickness) ) + , Just ( Key.toString LiningThickness, String.fromFloat (toMM params.lining) ) + , Just ( Key.toString BuckleHoleOffset, String.fromFloat (toMM params.longPiece.buckleHole.offset) ) + , Just ( Key.toString BuckleHoleCount, String.fromInt params.longPiece.buckleHole.count ) + , Just ( Key.toString BuckleHoleInterval, String.fromFloat (toMM params.longPiece.buckleHole.interval) ) + , Just ( Key.toString BuckleHoleDiameter, String.fromFloat (toMM params.longPiece.buckleHole.diameter) ) + , Just ( Key.toString LongPieceLength, String.fromFloat (toMM params.longPiece.length) ) + , Just ( Key.toString LoopThickness, String.fromFloat (toMM params.shortPiece.loops.thickness) ) + , Just ( Key.toString LoopStyle, loopStyleToString params.shortPiece.loops.style ) + , params.shortPiece.loops.fixed |> Maybe.map (\_ -> ( Key.toString HasFixedLoop, "" )) + , Just + ( Key.toString FixedLoopWidth + , params.shortPiece.loops.fixed |> Maybe.withDefault defaultFixedLoop |> .width |> toMM |> String.fromFloat + ) + , Just + ( Key.toString FixedLoopPlay + , params.shortPiece.loops.fixed |> Maybe.withDefault defaultFixedLoop |> .play |> toMM |> String.fromFloat + ) + , params.shortPiece.loops.free |> Maybe.map (\_ -> ( Key.toString HasFreeLoop, "" )) + , Just + ( Key.toString FreeLoopWidth + , params.shortPiece.loops.free |> Maybe.withDefault defaultFreeLoop |> .width |> toMM |> String.fromFloat + ) + , Just + ( Key.toString FreeLoopPlay + , params.shortPiece.loops.free |> Maybe.withDefault defaultFreeLoop |> .play |> toMM |> String.fromFloat + ) + , Just + ( Key.toString FreeLoopOverlap + , params.shortPiece.loops.free |> Maybe.withDefault defaultFreeLoop |> .overlap |> toMM |> String.fromFloat + ) + , Just ( Key.toString BuckleSpringBarDiameter, String.fromFloat (toMM params.shortPiece.buckle.springBarDiameter) ) + , params.shortPiece.buckle.tongue |> Maybe.map (\_ -> ( Key.toString HasBuckleTongue, "" )) + , Just + ( Key.toString BuckleTongueThickness + , params.shortPiece.buckle.tongue |> Maybe.withDefault defaultBuckleTongue |> .thickness |> toMM |> String.fromFloat + ) + , Just + ( Key.toString BuckleTongueWidth + , params.shortPiece.buckle.tongue |> Maybe.withDefault defaultBuckleTongue |> .width |> toMM |> String.fromFloat + ) + , Just ( Key.toString ShortPieceLength, String.fromFloat (toMM params.shortPiece.length) ) + , Just ( Key.toString CanvasMargin, String.fromFloat (toMM params.rendering.margin) ) + , Just ( Key.toString LineWidth, String.fromFloat (toMM params.rendering.lineWidth) ) + , Just ( Key.toString ColorSchema, colorSchemaToString params.rendering.colorSchema ) + ] + |> List.filterMap identity + |> Dict.fromList + + + getKey : Key -> ParametersDict -> Maybe String + getKey key fields = + Dict.get (Key.toString key) fields + + + hasKey : Key -> ParametersDict -> Bool + hasKey key fields = + not (getKey key fields == Nothing)
• src/Parameters/App.elm
  • @@ -9,13 +9,13 @@
    module Parameters.App exposing (Model, Msg, init, update, view) - import Dict exposing (Dict) + import Dict import Html exposing (hr, input, label, node, p, span, text) import Html.Attributes exposing (..) import Html.Events exposing (onBlur, onFocus, onInput) import Html.LivingStandard exposing (..) import Length exposing (Length, toMM) - import Parameters exposing (ColorSchema(..), LoopStyle(..), Parameters, colorSchemaToString, defaultBuckleTongue, defaultFixedLoop, defaultFreeLoop, loopStyleToString) + import Parameters exposing (ColorSchema(..), LoopStyle(..), Parameters, ParametersDict, colorSchemaToString, getKey, hasKey, loopStyleToString) import Parameters.Constraints exposing (NumberConstraints, constraints) import Parameters.Key as Key exposing (Key(..)) import Parameters.Parser exposing (..)
  • @@ -24,18 +24,10 @@
    -- MODEL - - - type alias Fields = - Dict String String - - - type alias Errors = - Dict String Error type alias Model = - { fields : Fields + { fields : ParametersDict , errors : Errors , parameters : Parameters , highlighting : Maybe Key
  • @@ -46,55 +38,7 @@ init : Parameters -> Model
    init params = let fields = - [ Just ( Key.toString LugWidth, String.fromFloat (toMM params.lugWidth) ) - , Just ( Key.toString SurfaceThickness, String.fromFloat (toMM params.thickness) ) - , Just ( Key.toString LiningThickness, String.fromFloat (toMM params.lining) ) - , Just ( Key.toString BuckleHoleOffset, String.fromFloat (toMM params.longPiece.buckleHole.offset) ) - , Just ( Key.toString BuckleHoleCount, String.fromInt params.longPiece.buckleHole.count ) - , Just ( Key.toString BuckleHoleInterval, String.fromFloat (toMM params.longPiece.buckleHole.interval) ) - , Just ( Key.toString BuckleHoleDiameter, String.fromFloat (toMM params.longPiece.buckleHole.diameter) ) - , Just ( Key.toString LongPieceLength, String.fromFloat (toMM params.longPiece.length) ) - , Just ( Key.toString LoopThickness, String.fromFloat (toMM params.shortPiece.loops.thickness) ) - , Just ( Key.toString LoopStyle, loopStyleToString params.shortPiece.loops.style ) - , params.shortPiece.loops.fixed |> Maybe.map (\_ -> ( Key.toString HasFixedLoop, "" )) - , Just - ( Key.toString FixedLoopWidth - , params.shortPiece.loops.fixed |> Maybe.withDefault defaultFixedLoop |> .width |> toMM |> String.fromFloat - ) - , Just - ( Key.toString FixedLoopPlay - , params.shortPiece.loops.fixed |> Maybe.withDefault defaultFixedLoop |> .play |> toMM |> String.fromFloat - ) - , params.shortPiece.loops.free |> Maybe.map (\_ -> ( Key.toString HasFreeLoop, "" )) - , Just - ( Key.toString FreeLoopWidth - , params.shortPiece.loops.free |> Maybe.withDefault defaultFreeLoop |> .width |> toMM |> String.fromFloat - ) - , Just - ( Key.toString FreeLoopPlay - , params.shortPiece.loops.free |> Maybe.withDefault defaultFreeLoop |> .play |> toMM |> String.fromFloat - ) - , Just - ( Key.toString FreeLoopOverlap - , params.shortPiece.loops.free |> Maybe.withDefault defaultFreeLoop |> .overlap |> toMM |> String.fromFloat - ) - , Just ( Key.toString BuckleSpringBarDiameter, String.fromFloat (toMM params.shortPiece.buckle.springBarDiameter) ) - , params.shortPiece.buckle.tongue |> Maybe.map (\_ -> ( Key.toString HasBuckleTongue, "" )) - , Just - ( Key.toString BuckleTongueThickness - , params.shortPiece.buckle.tongue |> Maybe.withDefault defaultBuckleTongue |> .thickness |> toMM |> String.fromFloat - ) - , Just - ( Key.toString BuckleTongueWidth - , params.shortPiece.buckle.tongue |> Maybe.withDefault defaultBuckleTongue |> .width |> toMM |> String.fromFloat - ) - , Just ( Key.toString ShortPieceLength, String.fromFloat (toMM params.shortPiece.length) ) - , Just ( Key.toString CanvasMargin, String.fromFloat (toMM params.rendering.margin) ) - , Just ( Key.toString LineWidth, String.fromFloat (toMM params.rendering.lineWidth) ) - , Just ( Key.toString ColorSchema, colorSchemaToString params.rendering.colorSchema ) - ] - |> List.filterMap identity - |> Dict.fromList + Parameters.toDict params in { fields = fields , errors =
  • @@ -121,289 +65,6 @@ | Highlight Key
    | Unhighlight Key - parseField : Key -> (String -> Result Error a) -> Fields -> Result Error a - parseField key f fields = - Dict.get (Key.toString key) fields - |> Maybe.withDefault "" - |> f - - - mkErrors : List ( Key, Maybe Error ) -> Errors - mkErrors list = - list - |> List.filterMap (\( key, error ) -> Maybe.map (\e -> ( Key.toString key, e )) error) - |> Dict.fromList - - - getError : Result a b -> Maybe a - getError r = - case r of - Err e -> - Just e - - _ -> - Nothing - - - hasField : Key -> Fields -> Bool - hasField key fields = - not (Dict.get (Key.toString key) fields == Nothing) - - - parseFixedLoop : Fields -> Result Errors (Maybe Parameters.FixedLoop) - parseFixedLoop fields = - if hasField HasFixedLoop fields then - case - ( parseField FixedLoopWidth (parseLength constraints.shortPiece.loops.fixed.width) fields - , parseField FixedLoopPlay (parseLength constraints.shortPiece.loops.fixed.play) fields - ) - of - ( Ok width, Ok play ) -> - let - base = - Parameters.defaultFixedLoop - in - Ok (Just { base | width = width, play = play }) - - ( width, play ) -> - Err - (mkErrors - [ ( FixedLoopWidth, getError width ) - , ( FixedLoopPlay, getError play ) - ] - ) - - else - Ok Nothing - - - parseFreeLoop : Fields -> Result Errors (Maybe Parameters.FreeLoop) - parseFreeLoop fields = - if hasField HasFreeLoop fields then - case - ( parseField FreeLoopWidth (parseLength constraints.shortPiece.loops.free.width) fields - , parseField FreeLoopPlay (parseLength constraints.shortPiece.loops.free.play) fields - , parseField FreeLoopOverlap (parseLength constraints.shortPiece.loops.free.overlap) fields - ) - of - ( Ok width, Ok play, Ok overlap ) -> - Ok (Just { width = width, play = play, overlap = overlap }) - - ( width, play, overlap ) -> - Err - (mkErrors - [ ( FreeLoopWidth, getError width ) - , ( FreeLoopPlay, getError play ) - , ( FreeLoopOverlap, getError overlap ) - ] - ) - - else - Ok Nothing - - - parseLoops : Fields -> Result Errors Parameters.Loops - parseLoops fields = - case - ( ( parseFixedLoop fields, parseFreeLoop fields ) - , ( parseField LoopStyle parseLoopStyle fields - , parseField LoopThickness (parseLength constraints.shortPiece.loops.thickness) fields - ) - ) - of - ( ( Ok fixed, Ok free ), ( Ok style, Ok thickness ) ) -> - Ok { fixed = fixed, free = free, style = style, thickness = thickness } - - ( ( fixed, free ), ( style, thickness ) ) -> - [ getError fixed |> Maybe.withDefault Dict.empty - , getError free |> Maybe.withDefault Dict.empty - , mkErrors [ ( LoopStyle, getError style ), ( LoopThickness, getError thickness ) ] - ] - |> List.map Dict.toList - |> List.concat - |> Dict.fromList - |> Err - - - parseBuckleTongue : Fields -> Result Errors (Maybe Parameters.BuckleTongue) - parseBuckleTongue fields = - if hasField HasBuckleTongue fields then - case - ( parseField BuckleTongueWidth (parseLength constraints.shortPiece.buckle.tongue.width) fields - , parseField BuckleTongueThickness (parseLength constraints.shortPiece.buckle.tongue.thickness) fields - ) - of - ( Ok width, Ok thickness ) -> - Ok (Just { width = width, thickness = thickness }) - - ( width, thickness ) -> - Err - (mkErrors - [ ( BuckleTongueWidth, getError width ) - , ( BuckleTongueThickness, getError thickness ) - ] - ) - - else - Ok Nothing - - - parseBuckle : Fields -> Result Errors Parameters.Buckle - parseBuckle fields = - case - ( parseBuckleTongue fields - , parseField BuckleSpringBarDiameter (parseLength constraints.shortPiece.buckle.springBarDiameter) fields - ) - of - ( Ok tongue, Ok springBarDiameter ) -> - Ok { tongue = tongue, springBarDiameter = springBarDiameter } - - ( tongue, springBarDiameter ) -> - [ getError tongue |> Maybe.withDefault Dict.empty - , mkErrors [ ( BuckleSpringBarDiameter, getError springBarDiameter ) ] - ] - |> List.map Dict.toList - |> List.concat - |> Dict.fromList - |> Err - - - parseShortPiece : Fields -> Result Errors Parameters.ShortPiece - parseShortPiece fields = - case - ( parseLoops fields - , parseField ShortPieceLength (parseLength constraints.shortPiece.length) fields - , parseBuckle fields - ) - of - ( Ok loops, Ok length, Ok buckle ) -> - let - base = - Parameters.default.shortPiece - in - Ok { base | loops = loops, length = length, buckle = buckle } - - ( loops, length, buckle ) -> - [ getError loops |> Maybe.withDefault Dict.empty - , mkErrors [ ( ShortPieceLength, getError length ) ] - , getError buckle |> Maybe.withDefault Dict.empty - ] - |> List.map Dict.toList - |> List.concat - |> Dict.fromList - |> Err - - - parseBuckleHole : Fields -> Result Errors Parameters.BuckleHole - parseBuckleHole fields = - case - ( ( parseField BuckleHoleCount (parseInt constraints.longPiece.buckleHole.count) fields - , parseField BuckleHoleDiameter (parseLength constraints.longPiece.buckleHole.diameter) fields - ) - , ( parseField BuckleHoleOffset (parseLength constraints.longPiece.buckleHole.offset) fields - , parseField BuckleHoleInterval (parseLength constraints.longPiece.buckleHole.interval) fields - ) - ) - of - ( ( Ok count, Ok diameter ), ( Ok offset, Ok interval ) ) -> - Ok { count = count, diameter = diameter, offset = offset, interval = interval } - - ( ( count, diameter ), ( offset, interval ) ) -> - Err - (mkErrors - [ ( BuckleHoleCount, getError count ) - , ( BuckleHoleDiameter, getError diameter ) - , ( BuckleHoleOffset, getError offset ) - , ( BuckleHoleInterval, getError interval ) - ] - ) - - - parseLongPiece : Fields -> Result Errors Parameters.LongPiece - parseLongPiece fields = - case ( parseBuckleHole fields, parseField LongPieceLength (parseLength constraints.longPiece.length) fields ) of - ( Ok buckleHole, Ok length ) -> - let - base = - Parameters.default.longPiece - in - Ok { base | buckleHole = buckleHole, length = length } - - ( buckleHole, length ) -> - Err - (Dict.union - (getError buckleHole |> Maybe.withDefault Dict.empty) - (mkErrors [ ( LongPieceLength, getError length ) ]) - ) - - - parseCanvas : Fields -> Result Errors Parameters.Rendering - parseCanvas fields = - case - ( parseField CanvasMargin (parseLength constraints.rendering.margin) fields - , parseField LineWidth (parseLength constraints.rendering.lineWidth) fields - , parseField ColorSchema parseColorSchema fields - ) - of - ( Ok margin, Ok lineWidth, Ok colorSchema ) -> - let - base = - Parameters.default.rendering - in - Ok { base | margin = margin, lineWidth = lineWidth, colorSchema = colorSchema } - - ( margin, lineWidth, colorSchema ) -> - Err - (mkErrors - [ ( CanvasMargin, getError margin ) - , ( LineWidth, getError lineWidth ) - , ( ColorSchema, getError colorSchema ) - ] - ) - - - parse : Fields -> Result Errors Parameters - parse fields = - case - ( ( parseField LugWidth (parseLength constraints.lugWidth) fields - , parseField LiningThickness (parseLength constraints.lining) fields - , parseField SurfaceThickness (parseLength constraints.thickness) fields - ) - , ( parseLongPiece fields - , parseShortPiece fields - ) - , parseCanvas fields - ) - of - ( ( Ok lugWidth, Ok lining, Ok thickness ), ( Ok longPiece, Ok shortPiece ), Ok rendering ) -> - let - base = - Parameters.default - in - Ok - { base - | lugWidth = lugWidth - , lining = lining - , thickness = thickness - , longPiece = longPiece - , shortPiece = shortPiece - , rendering = rendering - } - - ( ( lugWidth, lining, thickness ), ( longPiece, shortPiece ), rendering ) -> - [ mkErrors [ ( LugWidth, getError lugWidth ) ] - , mkErrors [ ( LiningThickness, getError lining ) ] - , mkErrors [ ( SurfaceThickness, getError thickness ) ] - , getError longPiece |> Maybe.withDefault Dict.empty - , getError shortPiece |> Maybe.withDefault Dict.empty - , getError rendering |> Maybe.withDefault Dict.empty - ] - |> List.map Dict.toList - |> List.concat - |> Dict.fromList - |> Err - - update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case msg of
  • @@ -597,7 +258,7 @@ , node "x-number-input"
    [] [ input (id (Key.toString key) - :: value (model.fields |> Dict.get (Key.toString key) |> Maybe.withDefault "") + :: value (model.fields |> getKey key |> Maybe.withDefault "") :: onInput (FieldChanged key) :: onFocus (Highlight key) :: onBlur (Unhighlight key)
  • @@ -659,7 +320,7 @@ choiceDescriptionId =
    id ++ "__description" checked = - Dict.get (Key.toString key) model.fields + getKey key model.fields |> Maybe.withDefault "" |> (==) choice.value in
  • @@ -705,7 +366,7 @@ boolField : Model -> BoolFieldProps Msg -> Html.Html Msg
    boolField model { key, title, disabled, description, attrs, true, false } = let isTrue = - not (Dict.get (Key.toString key) model.fields == Nothing) + hasKey key model.fields id : Bool -> String id v =
  • @@ -923,7 +584,7 @@ , title = [ text "Buckle Tongue Width" ]
    , description = [ text "Width of the buckle tongue / pin." ] , unit = Just "mm" - , disabled = not (hasField HasBuckleTongue model.fields) + , disabled = not (hasKey HasBuckleTongue model.fields) , attrs = step "0.1" :: lengthFieldAttrs constraints.shortPiece.buckle.tongue.width }
  • @@ -933,7 +594,7 @@ , title = [ text "Buckle Tongue Thickness" ]
    , description = [ text "Thickness of the buckle tongue / pin, to add to the cutout depth." ] , unit = Just "mm" - , disabled = not (hasField HasBuckleTongue model.fields) + , disabled = not (hasKey HasBuckleTongue model.fields) , attrs = step "0.1" :: lengthFieldAttrs constraints.shortPiece.buckle.tongue.thickness }
  • @@ -946,8 +607,8 @@ { key = LoopStyle
    , title = [ text "Loop Style" ] , description = [ text "Style of the fixed loop and the free loop." ] , disabled = - not (hasField HasFixedLoop model.fields) - && not (hasField HasFreeLoop model.fields) + not (hasKey HasFixedLoop model.fields) + && not (hasKey HasFreeLoop model.fields) , attrs = [] , choices = [ { label = [ text "Simple" ]
  • @@ -966,8 +627,8 @@ , title = [ text "Loop Leather Thickness" ]
    , description = [ text "Thickness of the leather to use for loops. Final thickness will be doubled if you choose \"Folded\" style." ] , unit = Just "mm" , disabled = - not (hasField HasFixedLoop model.fields) - && not (hasField HasFreeLoop model.fields) + not (hasKey HasFixedLoop model.fields) + && not (hasKey HasFreeLoop model.fields) , attrs = step "0.1" :: lengthFieldAttrs constraints.shortPiece.loops.thickness }
  • @@ -991,7 +652,7 @@ { key = FixedLoopWidth
    , title = [ text "Fixed Loop Width" ] , description = [ text "Width of the fixed loop." ] , unit = Just "mm" - , disabled = not (hasField HasFixedLoop model.fields) + , disabled = not (hasKey HasFixedLoop model.fields) , attrs = step "0.1" :: lengthFieldAttrs constraints.shortPiece.loops.fixed.width }
  • @@ -1000,7 +661,7 @@ { key = FixedLoopPlay
    , title = [ text "Fixed Loop Play" ] , description = [ text "Extra length to add to the fixed loop, for adjusting tightness." ] , unit = Just "mm" - , disabled = not (hasField HasFixedLoop model.fields) + , disabled = not (hasKey HasFixedLoop model.fields) , attrs = step "0.1" :: lengthFieldAttrs constraints.shortPiece.loops.fixed.play }
  • @@ -1024,7 +685,7 @@ { key = FreeLoopWidth
    , title = [ text "Free Loop Width" ] , description = [ text "Width of the free loop." ] , unit = Just "mm" - , disabled = not (hasField HasFreeLoop model.fields) + , disabled = not (hasKey HasFreeLoop model.fields) , attrs = step "0.1" :: lengthFieldAttrs constraints.shortPiece.loops.free.width }
  • @@ -1033,7 +694,7 @@ { key = FreeLoopPlay
    , title = [ text "Free Loop Play" ] , description = [ text "Extra length to add to the free loop, for adjusting tightness." ] , unit = Just "mm" - , disabled = not (hasField HasFreeLoop model.fields) + , disabled = not (hasKey HasFreeLoop model.fields) , attrs = step "0.1" :: lengthFieldAttrs constraints.shortPiece.loops.free.play }
  • @@ -1042,7 +703,7 @@ { key = FreeLoopOverlap
    , title = [ text "Free Loop Overlap" ] , description = [ text "Length of overlapping section of the free loop for gluing and/or stitching." ] , unit = Just "mm" - , disabled = not (hasField HasFreeLoop model.fields) + , disabled = not (hasKey HasFreeLoop model.fields) , attrs = step "0.1" :: lengthFieldAttrs constraints.shortPiece.loops.free.overlap }
• src/Parameters/Parser.elm
  • @@ -7,11 +7,13 @@ --
    -- SPDX-License-Identifier: MPL-2.0 - module Parameters.Parser exposing (Error(..), parseBool, parseColorSchema, parseInt, parseLength, parseLoopStyle) + module Parameters.Parser exposing (Error(..), Errors, parse) + import Dict exposing (Dict) import Length exposing (Length, mm, toMM) - import Parameters exposing (ColorSchema(..), LoopStyle(..)) - import Parameters.Constraints as Constraints + import Parameters exposing (ColorSchema(..), LoopStyle(..), Parameters, ParametersDict, getKey, hasKey) + import Parameters.Constraints as Constraints exposing (constraints) + import Parameters.Key as Key exposing (Key(..)) type Error
  • @@ -22,6 +24,27 @@ | NotALength
    | NotAnInt | NonexistentVariant String | NotABool + + + type alias Errors = + Dict String Error + + + mkErrors : List ( Key, Maybe Error ) -> Errors + mkErrors list = + list + |> List.filterMap (\( key, error ) -> Maybe.map (\e -> ( Key.toString key, e )) error) + |> Dict.fromList + + + getError : Result a b -> Maybe a + getError r = + case r of + Err e -> + Just e + + _ -> + Nothing parseInt : Constraints.NumberConstraints Int -> String -> Result Error Int
  • @@ -115,19 +138,6 @@ |> min
    |> max - parseBool : String -> Result Error Bool - parseBool text = - case text of - "true" -> - Ok True - - "false" -> - Ok False - - _ -> - Err NotABool - - parseColorSchema : String -> Result Error ColorSchema parseColorSchema text = case text of
  • @@ -152,3 +162,264 @@ Ok Folded
    _ -> Err (NonexistentVariant text) + + + parseField : Key -> (String -> Result Error a) -> ParametersDict -> Result Error a + parseField key f fields = + getKey key fields + |> Maybe.withDefault "" + |> f + + + parseFixedLoop : ParametersDict -> Result Errors (Maybe Parameters.FixedLoop) + parseFixedLoop fields = + if hasKey HasFixedLoop fields then + case + ( parseField FixedLoopWidth (parseLength constraints.shortPiece.loops.fixed.width) fields + , parseField FixedLoopPlay (parseLength constraints.shortPiece.loops.fixed.play) fields + ) + of + ( Ok width, Ok play ) -> + let + base = + Parameters.defaultFixedLoop + in + Ok (Just { base | width = width, play = play }) + + ( width, play ) -> + Err + (mkErrors + [ ( FixedLoopWidth, getError width ) + , ( FixedLoopPlay, getError play ) + ] + ) + + else + Ok Nothing + + + parseFreeLoop : ParametersDict -> Result Errors (Maybe Parameters.FreeLoop) + parseFreeLoop fields = + if hasKey HasFreeLoop fields then + case + ( parseField FreeLoopWidth (parseLength constraints.shortPiece.loops.free.width) fields + , parseField FreeLoopPlay (parseLength constraints.shortPiece.loops.free.play) fields + , parseField FreeLoopOverlap (parseLength constraints.shortPiece.loops.free.overlap) fields + ) + of + ( Ok width, Ok play, Ok overlap ) -> + Ok (Just { width = width, play = play, overlap = overlap }) + + ( width, play, overlap ) -> + Err + (mkErrors + [ ( FreeLoopWidth, getError width ) + , ( FreeLoopPlay, getError play ) + , ( FreeLoopOverlap, getError overlap ) + ] + ) + + else + Ok Nothing + + + parseLoops : ParametersDict -> Result Errors Parameters.Loops + parseLoops fields = + case + ( ( parseFixedLoop fields, parseFreeLoop fields ) + , ( parseField LoopStyle parseLoopStyle fields + , parseField LoopThickness (parseLength constraints.shortPiece.loops.thickness) fields + ) + ) + of + ( ( Ok fixed, Ok free ), ( Ok style, Ok thickness ) ) -> + Ok { fixed = fixed, free = free, style = style, thickness = thickness } + + ( ( fixed, free ), ( style, thickness ) ) -> + [ getError fixed |> Maybe.withDefault Dict.empty + , getError free |> Maybe.withDefault Dict.empty + , mkErrors [ ( LoopStyle, getError style ), ( LoopThickness, getError thickness ) ] + ] + |> List.map Dict.toList + |> List.concat + |> Dict.fromList + |> Err + + + parseBuckleTongue : ParametersDict -> Result Errors (Maybe Parameters.BuckleTongue) + parseBuckleTongue fields = + if hasKey HasBuckleTongue fields then + case + ( parseField BuckleTongueWidth (parseLength constraints.shortPiece.buckle.tongue.width) fields + , parseField BuckleTongueThickness (parseLength constraints.shortPiece.buckle.tongue.thickness) fields + ) + of + ( Ok width, Ok thickness ) -> + Ok (Just { width = width, thickness = thickness }) + + ( width, thickness ) -> + Err + (mkErrors + [ ( BuckleTongueWidth, getError width ) + , ( BuckleTongueThickness, getError thickness ) + ] + ) + + else + Ok Nothing + + + parseBuckle : ParametersDict -> Result Errors Parameters.Buckle + parseBuckle fields = + case + ( parseBuckleTongue fields + , parseField BuckleSpringBarDiameter (parseLength constraints.shortPiece.buckle.springBarDiameter) fields + ) + of + ( Ok tongue, Ok springBarDiameter ) -> + Ok { tongue = tongue, springBarDiameter = springBarDiameter } + + ( tongue, springBarDiameter ) -> + [ getError tongue |> Maybe.withDefault Dict.empty + , mkErrors [ ( BuckleSpringBarDiameter, getError springBarDiameter ) ] + ] + |> List.map Dict.toList + |> List.concat + |> Dict.fromList + |> Err + + + parseShortPiece : ParametersDict -> Result Errors Parameters.ShortPiece + parseShortPiece fields = + case + ( parseLoops fields + , parseField ShortPieceLength (parseLength constraints.shortPiece.length) fields + , parseBuckle fields + ) + of + ( Ok loops, Ok length, Ok buckle ) -> + let + base = + Parameters.default.shortPiece + in + Ok { base | loops = loops, length = length, buckle = buckle } + + ( loops, length, buckle ) -> + [ getError loops |> Maybe.withDefault Dict.empty + , mkErrors [ ( ShortPieceLength, getError length ) ] + , getError buckle |> Maybe.withDefault Dict.empty + ] + |> List.map Dict.toList + |> List.concat + |> Dict.fromList + |> Err + + + parseBuckleHole : ParametersDict -> Result Errors Parameters.BuckleHole + parseBuckleHole fields = + case + ( ( parseField BuckleHoleCount (parseInt constraints.longPiece.buckleHole.count) fields + , parseField BuckleHoleDiameter (parseLength constraints.longPiece.buckleHole.diameter) fields + ) + , ( parseField BuckleHoleOffset (parseLength constraints.longPiece.buckleHole.offset) fields + , parseField BuckleHoleInterval (parseLength constraints.longPiece.buckleHole.interval) fields + ) + ) + of + ( ( Ok count, Ok diameter ), ( Ok offset, Ok interval ) ) -> + Ok { count = count, diameter = diameter, offset = offset, interval = interval } + + ( ( count, diameter ), ( offset, interval ) ) -> + Err + (mkErrors + [ ( BuckleHoleCount, getError count ) + , ( BuckleHoleDiameter, getError diameter ) + , ( BuckleHoleOffset, getError offset ) + , ( BuckleHoleInterval, getError interval ) + ] + ) + + + parseLongPiece : ParametersDict -> Result Errors Parameters.LongPiece + parseLongPiece fields = + case ( parseBuckleHole fields, parseField LongPieceLength (parseLength constraints.longPiece.length) fields ) of + ( Ok buckleHole, Ok length ) -> + let + base = + Parameters.default.longPiece + in + Ok { base | buckleHole = buckleHole, length = length } + + ( buckleHole, length ) -> + Err + (Dict.union + (getError buckleHole |> Maybe.withDefault Dict.empty) + (mkErrors [ ( LongPieceLength, getError length ) ]) + ) + + + parseCanvas : ParametersDict -> Result Errors Parameters.Rendering + parseCanvas fields = + case + ( parseField CanvasMargin (parseLength constraints.rendering.margin) fields + , parseField LineWidth (parseLength constraints.rendering.lineWidth) fields + , parseField ColorSchema parseColorSchema fields + ) + of + ( Ok margin, Ok lineWidth, Ok colorSchema ) -> + let + base = + Parameters.default.rendering + in + Ok { base | margin = margin, lineWidth = lineWidth, colorSchema = colorSchema } + + ( margin, lineWidth, colorSchema ) -> + Err + (mkErrors + [ ( CanvasMargin, getError margin ) + , ( LineWidth, getError lineWidth ) + , ( ColorSchema, getError colorSchema ) + ] + ) + + + parse : ParametersDict -> Result Errors Parameters + parse fields = + case + ( ( parseField LugWidth (parseLength constraints.lugWidth) fields + , parseField LiningThickness (parseLength constraints.lining) fields + , parseField SurfaceThickness (parseLength constraints.thickness) fields + ) + , ( parseLongPiece fields + , parseShortPiece fields + ) + , parseCanvas fields + ) + of + ( ( Ok lugWidth, Ok lining, Ok thickness ), ( Ok longPiece, Ok shortPiece ), Ok rendering ) -> + let + base = + Parameters.default + in + Ok + { base + | lugWidth = lugWidth + , lining = lining + , thickness = thickness + , longPiece = longPiece + , shortPiece = shortPiece + , rendering = rendering + } + + ( ( lugWidth, lining, thickness ), ( longPiece, shortPiece ), rendering ) -> + [ mkErrors [ ( LugWidth, getError lugWidth ) ] + , mkErrors [ ( LiningThickness, getError lining ) ] + , mkErrors [ ( SurfaceThickness, getError thickness ) ] + , getError longPiece |> Maybe.withDefault Dict.empty + , getError shortPiece |> Maybe.withDefault Dict.empty + , getError rendering |> Maybe.withDefault Dict.empty + ] + |> List.map Dict.toList + |> List.concat + |> Dict.fromList + |> Err