Changes
8 changed files (+312/-121)
-
-
@@ -43,6 +43,7 @@ compile.addElmSourceFile(b.path("src/Template/Layout/Container.elm"));compile.addElmSourceFile(b.path("src/Template/Layout/Coordinate.elm")); compile.addElmSourceFile(b.path("src/Template/Layout/Item.elm")); compile.addElmSourceFile(b.path("src/Svg/Path.elm")); compile.addElmSourceFile(b.path("src/Url/SearchParams.elm")); break :elm_main compile.output_js; };
-
-
-
@@ -11,10 +11,10 @@ "elm/core": "1.0.5","elm/html": "1.0.1", "elm/json": "1.1.4", "elm/svg": "1.0.1", "elm/time": "1.0.0", "elm/url": "1.0.0" }, "indirect": { "elm/time": "1.0.0", "elm/virtual-dom": "1.0.5" } },
-
-
-
@@ -17,10 +17,12 @@ import Html.LivingStandard exposing (..)import Json.Decode import Parameters import Parameters.App import Parameters.Parser import Preferences exposing (FieldHighlight(..)) import Preferences.App import Template exposing (template) import Url exposing (Url) import Url.SearchParams main : Program Flags Model Msg
-
@@ -60,14 +62,24 @@ init : Flags -> Url -> Key -> ( Model, Cmd Msg )init flags url key = let parameters = Parameters.default case Maybe.map Url.SearchParams.parse url.query of Just dict -> -- TODO: Handle and present errors to a user Parameters.Parser.parse dict |> Result.withDefault Parameters.default Nothing -> Parameters.default ( parametersModel, parametersCmd ) = Parameters.App.init url key parameters in ( { url = url , key = key , parameters = Parameters.App.init parameters , parameters = parametersModel , preferences = Preferences.App.init flags.preferences } , Cmd.none , Cmd.map ParametersMsg parametersCmd )
-
@@ -77,7 +89,7 @@type Msg = NoOp | ParametersFormMsg Parameters.App.Msg | ParametersMsg Parameters.App.Msg | PreferencesMsg Preferences.App.Msg | UrlRequested Browser.UrlRequest | UrlChanged Url
-
@@ -89,10 +101,10 @@ case msg ofNoOp -> ( model, Cmd.none ) ParametersFormMsg subMsg -> ParametersMsg subMsg -> Parameters.App.update subMsg model.parameters |> Tuple.mapFirst (\p -> { model | parameters = p }) |> Tuple.mapSecond (Cmd.map ParametersFormMsg) |> Tuple.mapSecond (Cmd.map ParametersMsg) PreferencesMsg subMsg -> Preferences.App.update subMsg model.preferences
-
@@ -154,7 +166,7 @@ [ node "x-parameters"[] ((Parameters.App.view model.parameters |> List.map (Html.map ParametersFormMsg) |> List.map (Html.map ParametersMsg) ) ++ hr [] [] :: (Preferences.App.panelItems model.preferences |> List.map (Html.map PreferencesMsg))
-
-
-
@@ -226,56 +226,85 @@ type alias ParametersDict =Dict String String toDict : Parameters -> Dict String String toDict : Parameters -> ParametersDict 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 ) [ ( "version", "1.0" ) , ( Key.toString LugWidth, String.fromFloat (toMM params.lugWidth) ) , ( Key.toString SurfaceThickness, String.fromFloat (toMM params.thickness) ) , ( Key.toString LiningThickness, String.fromFloat (toMM params.lining) ) , ( Key.toString LongPieceLength, String.fromFloat (toMM params.longPiece.length) ) , ( Key.toString LoopThickness, String.fromFloat (toMM params.shortPiece.loops.thickness) ) , ( Key.toString LoopStyle, loopStyleToString params.shortPiece.loops.style ) , ( Key.toString BuckleSpringBarDiameter, String.fromFloat (toMM params.shortPiece.buckle.springBarDiameter) ) , ( Key.toString ShortPieceLength, String.fromFloat (toMM params.shortPiece.length) ) , ( Key.toString CanvasMargin, String.fromFloat (toMM params.rendering.margin) ) , ( Key.toString LineWidth, String.fromFloat (toMM params.rendering.lineWidth) ) , ( Key.toString ColorSchema, colorSchemaToString params.rendering.colorSchema ) , ( Key.toString BuckleHoleCount, String.fromInt params.longPiece.buckleHole.count ) ] |> (++) (if params.longPiece.buckleHole.count > 0 then [ ( Key.toString BuckleHoleOffset, String.fromFloat (toMM params.longPiece.buckleHole.offset) ) , ( Key.toString BuckleHoleInterval, String.fromFloat (toMM params.longPiece.buckleHole.interval) ) , ( Key.toString BuckleHoleDiameter, String.fromFloat (toMM params.longPiece.buckleHole.diameter) ) ] else [] ) |> (++) (case params.shortPiece.loops.fixed of Just fixed -> [ ( Key.toString HasFixedLoop, "" ) , ( Key.toString FixedLoopWidth, String.fromFloat (toMM fixed.width) ) , ( Key.toString FixedLoopPlay, String.fromFloat (toMM fixed.play) ) ] Nothing -> [] ) |> (++) (case params.shortPiece.loops.free of Just free -> [ ( Key.toString HasFreeLoop, "" ) , ( Key.toString FreeLoopWidth, String.fromFloat (toMM free.width) ) , ( Key.toString FreeLoopPlay, String.fromFloat (toMM free.play) ) , ( Key.toString FreeLoopOverlap, String.fromFloat (toMM free.overlap) ) ] Nothing -> [] ) |> (++) (case params.shortPiece.buckle.tongue of Just tongue -> [ ( Key.toString HasBuckleTongue, "" ) , ( Key.toString BuckleTongueThickness, String.fromFloat (toMM tongue.thickness) ) , ( Key.toString BuckleTongueWidth, String.fromFloat (toMM tongue.width) ) ] Nothing -> [] ) |> Dict.fromList {-| Fields under `Maybe` record may be empty when the parsed parent is `Nothing`. These values sets default values for those fields. -} fallbackValues : ParametersDict fallbackValues = [ ( Key.toString FixedLoopWidth, String.fromFloat (toMM defaultFixedLoop.width) ) , ( Key.toString FixedLoopPlay, String.fromFloat (toMM defaultFixedLoop.play) ) , ( Key.toString FreeLoopWidth, String.fromFloat (toMM defaultFreeLoop.width) ) , ( Key.toString FreeLoopPlay, String.fromFloat (toMM defaultFreeLoop.play) ) , ( Key.toString FreeLoopOverlap, String.fromFloat (toMM defaultFreeLoop.overlap) ) , ( Key.toString BuckleTongueThickness, String.fromFloat (toMM defaultBuckleTongue.thickness) ) , ( Key.toString BuckleTongueWidth, String.fromFloat (toMM defaultBuckleTongue.width) ) , ( Key.toString BuckleHoleOffset, String.fromFloat (toMM default.longPiece.buckleHole.offset) ) , ( Key.toString BuckleHoleInterval, String.fromFloat (toMM default.longPiece.buckleHole.interval) ) , ( Key.toString BuckleHoleDiameter, String.fromFloat (toMM default.longPiece.buckleHole.diameter) ) ] |> List.filterMap identity |> Dict.fromList
-
-
-
@@ -9,6 +9,7 @@module Parameters.App exposing (Model, Msg, init, update, view) import Browser.Navigation import Dict import Html exposing (hr, input, label, node, p, span, text) import Html.Attributes exposing (..)
-
@@ -20,37 +21,60 @@ import Parameters.Constraints exposing (NumberConstraints, constraints)import Parameters.Key as Key exposing (Key(..)) import Parameters.Parser exposing (..) import Platform.Cmd as Cmd import Process import Task import Time import Url exposing (Url) import Url.SearchParams -- MODEL type UrlUpdate = Idle | Throttled Time.Posix | Scheduled type alias Model = { fields : ParametersDict , errors : Errors , parameters : Parameters , highlighting : Maybe Key , navigation : Browser.Navigation.Key , baseUrl : Url , currentUrl : Url , urlUpdate : UrlUpdate } init : Parameters -> Model init params = init : Url -> Browser.Navigation.Key -> Parameters -> ( Model, Cmd Msg ) init baseUrl key params = let fields = Parameters.toDict params Dict.union (Parameters.toDict params) Parameters.fallbackValues in { fields = fields , errors = case parse fields of Ok _ -> Dict.empty ( { fields = fields , errors = case parse fields of Ok _ -> Dict.empty Err errors -> errors , parameters = params , highlighting = Nothing } Err errors -> errors , parameters = params , highlighting = Nothing , navigation = key , baseUrl = baseUrl , currentUrl = baseUrl , urlUpdate = Idle } , Task.perform UrlRewriteRequested Time.now )
-
@@ -60,9 +84,11 @@type Msg = FieldChanged Key String | FieldUnset Key | ColorSchemaChanged ColorSchema | Highlight Key | Unhighlight Key | UrlRewriteTriggered | UrlRewriteRequested Time.Posix | RunThrottledUrlRewrite update : Msg -> Model -> ( Model, Cmd Msg )
-
@@ -80,7 +106,7 @@ | fields = fields, errors = Dict.empty , parameters = newParams } , Cmd.none , Task.perform UrlRewriteRequested Time.now ) Err errors ->
-
@@ -98,24 +124,12 @@ | fields = fields, errors = Dict.empty , parameters = newParams } , Cmd.none , Task.perform UrlRewriteRequested Time.now ) Err errors -> ( { model | fields = fields, errors = errors }, Cmd.none ) ColorSchemaChanged schema -> let { parameters } = model { rendering } = parameters in ( { model | parameters = { parameters | rendering = { rendering | colorSchema = schema } } } , Cmd.none ) Highlight key -> ( { model | highlighting = Just key }, Cmd.none )
-
@@ -125,6 +139,56 @@ ( { model | highlighting = Nothing }, Cmd.none )else ( model, Cmd.none ) UrlRewriteRequested now -> let { baseUrl } = model query = model.parameters |> Parameters.toDict |> Url.SearchParams.build url = { baseUrl | query = Just query } next = { model | currentUrl = url } throttledUntil = now |> Time.posixToMillis |> (+) 200 |> Time.millisToPosix in case model.urlUpdate of Idle -> update UrlRewriteTriggered { next | urlUpdate = Throttled throttledUntil } Scheduled -> ( next, Cmd.none ) Throttled until -> let timeout = Time.posixToMillis until - Time.posixToMillis now in if timeout <= 0 then update UrlRewriteTriggered { next | urlUpdate = Throttled throttledUntil } else ( { next | urlUpdate = Scheduled } , Task.perform (\_ -> RunThrottledUrlRewrite) (Process.sleep (toFloat timeout)) ) RunThrottledUrlRewrite -> update UrlRewriteTriggered { model | urlUpdate = Idle } UrlRewriteTriggered -> ( model , Browser.Navigation.replaceUrl model.navigation (Url.toString model.currentUrl) )
-
@@ -224,6 +288,9 @@ [ text "Invalid bool value. Value must be either \"true\" or \"false\"." ]NonexistentVariant str -> [ text ("\"" ++ str ++ "\" is not a valid choice. Did you modify program's source code?") ] UnsupportedParametersVersion str -> [ text ("Parameters version \"" ++ str ++ "\" is not supported.") ] descriptionId : Key -> String
-
-
-
@@ -36,11 +36,15 @@ | ShortPieceLength| CanvasMargin | LineWidth | ColorSchema | Version toString : Key -> String toString key = case key of Version -> "version" LugWidth -> "lug-width"
-
-
-
@@ -24,6 +24,7 @@ | NotALength| NotAnInt | NonexistentVariant String | NotABool | UnsupportedParametersVersion String type alias Errors =
-
@@ -326,6 +327,13 @@ , parseField BuckleHoleInterval (parseLength constraints.longPiece.buckleHole.interval) fields) ) of ( ( Ok 0, _ ), _ ) -> let default = Parameters.default.longPiece.buckleHole in Ok { default | count = 0 } ( ( Ok count, Ok diameter ), ( Ok offset, Ok interval ) ) -> Ok { count = count, diameter = diameter, offset = offset, interval = interval }
-
@@ -385,41 +393,49 @@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 } case getKey Version fields of Just "1.0" -> 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 ( ( 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 Just str -> Err (mkErrors [ ( Version, Just (UnsupportedParametersVersion str) ) ]) Nothing -> Err (mkErrors [ ( Version, Just MissingValue ) ])
-
-
src/Url/SearchParams.elm (new)
-
@@ -0,0 +1,62 @@-- Copyright 2026 Shota FUJI -- -- This Source Code Form is subject to the terms of the Mozilla Public -- License, v. 2.0. If a copy of the MPL was not distributed with this -- file, You can obtain one at https://mozilla.org/MPL/2.0/. -- -- SPDX-License-Identifier: MPL-2.0 module Url.SearchParams exposing (build, parse) import Dict exposing (Dict) import List import String import Url parseParameter : String -> Maybe ( String, String ) parseParameter p = case String.split "=" p of [] -> Nothing [ key ] -> Maybe.map (\k -> ( k, "" )) (Url.percentDecode key) [ key, value ] -> Maybe.map2 Tuple.pair (Url.percentDecode key) (Url.percentDecode value) _ -> Nothing parse : String -> Dict String String parse qs = qs |> String.split "&" |> List.filterMap parseParameter |> Dict.fromList buildParameter : ( String, String ) -> String buildParameter ( key, value ) = case value of "" -> Url.percentEncode key _ -> Url.percentEncode key ++ "=" ++ Url.percentEncode value build : Dict String String -> String build dict = dict |> Dict.toList |> List.map buildParameter |> String.join "&"
-