Changes
7 changed files (+281/-64)
-
-
@@ -60,25 +60,25 @@ , preferences : Preferences.App.Model} parseParameters : Url -> Key -> ( Result QueryHealer.Model Parameters.App.Model, Cmd Msg ) parseParameters url key = parseParameters : Url -> Key -> Preferences.Preferences -> ( Result QueryHealer.Model Parameters.App.Model, Cmd Msg ) parseParameters url key preferences = case Maybe.map Url.SearchParams.parse url.query of Just dict -> case Parameters.Parser.parse dict of Ok params -> let ( model, cmd ) = Parameters.App.init url key params Parameters.App.init url key preferences params in ( Ok model, Cmd.map ParametersMsg cmd ) Err errors -> ( Err (QueryHealer.init url errors), Cmd.none ) ( Err (QueryHealer.init url preferences errors), Cmd.none ) Nothing -> let ( model, cmd ) = Parameters.App.init url key Parameters.default Parameters.App.init url key preferences Parameters.default in ( Ok model, Cmd.map ParametersMsg cmd )
-
@@ -86,13 +86,16 @@init : Flags -> Url -> Key -> ( Model, Cmd Msg ) init flags url key = let preferences = Preferences.App.init flags.preferences ( parameters, parametersCmd ) = parseParameters url key parseParameters url key preferences.preferences in ( { url = url , key = key , parameters = parameters , preferences = Preferences.App.init flags.preferences , preferences = preferences } , parametersCmd )
-
@@ -139,7 +142,19 @@ ( model, Cmd.none )PreferencesMsg subMsg -> Preferences.App.update subMsg model.preferences |> Tuple.mapFirst (\p -> { model | preferences = p }) |> Tuple.mapFirst (\p -> { model | preferences = p , parameters = case model.parameters of Ok parameters -> Ok { parameters | preferences = p.preferences } Err queryHealer -> Err { queryHealer | preferences = p.preferences } } ) |> Tuple.mapSecond (Cmd.map PreferencesMsg) UrlRequested (Browser.Internal url) ->
-
@@ -160,7 +175,7 @@Err _ -> let ( parameters, parametersCmd ) = parseParameters url model.key parseParameters url model.key model.preferences.preferences in ( { model | url = url, parameters = parameters }, parametersCmd )
-
-
-
@@ -215,23 +215,37 @@ type alias ParametersDict =Dict String String toDict : Parameters -> ParametersDict toDict params = type DictKeyMode = Regular | Compact toDict : DictKeyMode -> Parameters -> ParametersDict toDict mode params = let toString = case mode of Regular -> Key.toString Compact -> Key.toCompactID in [ ( "version", "1.0" ) , ( Key.toString TipStyle, tipStyleToString params.longPiece.tip ) , ( Key.toString ShoulderWidth, String.fromFloat (toMM params.shoulderWidth) ) , ( Key.toString PaddingOffset, String.fromFloat (toMM params.paddingOffset) ) , ( Key.toString LongPieceLength, String.fromFloat (toMM params.longPiece.length) ) , ( Key.toString LoopStyle, loopStyleToString params.shortPiece.loops.style ) , ( 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 BuckleHoleAdjustments, String.fromInt params.longPiece.buckleHole.adjustments ) , ( Key.toString BuckleHoleDistance, String.fromFloat (toMM params.longPiece.buckleHole.distance) ) , ( Key.toString BuckleHoleInterval, String.fromFloat (toMM params.longPiece.buckleHole.interval) ) , ( Key.toString BuckleHoleDiameter, String.fromFloat (toMM params.longPiece.buckleHole.diameter) ) , ( Key.toString Profile, profileKind params.profile ) , ( toString TipStyle, tipStyleToString params.longPiece.tip ) , ( toString ShoulderWidth, String.fromFloat (toMM params.shoulderWidth) ) , ( toString PaddingOffset, String.fromFloat (toMM params.paddingOffset) ) , ( toString LongPieceLength, String.fromFloat (toMM params.longPiece.length) ) , ( toString LoopStyle, loopStyleToString params.shortPiece.loops.style ) , ( toString ShortPieceLength, String.fromFloat (toMM params.shortPiece.length) ) , ( toString CanvasMargin, String.fromFloat (toMM params.rendering.margin) ) , ( toString LineWidth, String.fromFloat (toMM params.rendering.lineWidth) ) , ( toString ColorSchema, colorSchemaToString params.rendering.colorSchema ) , ( toString BuckleHoleAdjustments, String.fromInt params.longPiece.buckleHole.adjustments ) , ( toString BuckleHoleDistance, String.fromFloat (toMM params.longPiece.buckleHole.distance) ) , ( toString BuckleHoleInterval, String.fromFloat (toMM params.longPiece.buckleHole.interval) ) , ( toString BuckleHoleDiameter, String.fromFloat (toMM params.longPiece.buckleHole.diameter) ) , ( toString Profile, profileKind params.profile ) ] |> (++) (case params.longPiece.tip of
-
@@ -239,7 +253,7 @@ Round ->[] Pointed sharpness -> [ ( Key.toString TipSharpness, String.fromInt sharpness ) ] [ ( toString TipSharpness, String.fromInt sharpness ) ] ) |> (++) (case params.profile of
-
@@ -247,14 +261,14 @@ Straight ->[] Tapered to -> [ ( Key.toString TaperTo, String.fromFloat (toMM to) ) ] [ ( toString TaperTo, String.fromFloat (toMM to) ) ] ) |> (++) (case params.shortPiece.loops.fixed of Just fixed -> [ ( Key.toString HasFixedLoop, "" ) , ( Key.toString FixedLoopWidth, String.fromFloat (toMM fixed.width) ) , ( Key.toString FixedLoopLength, String.fromFloat (toMM fixed.length) ) [ ( toString HasFixedLoop, "" ) , ( toString FixedLoopWidth, String.fromFloat (toMM fixed.width) ) , ( toString FixedLoopLength, String.fromFloat (toMM fixed.length) ) ] Nothing ->
-
@@ -263,10 +277,10 @@ )|> (++) (case params.shortPiece.loops.free of Just free -> [ ( Key.toString HasFreeLoop, "" ) , ( Key.toString FreeLoopWidth, String.fromFloat (toMM free.width) ) , ( Key.toString FreeLoopLength, String.fromFloat (toMM free.length) ) , ( Key.toString FreeLoopOverlap, String.fromFloat (toMM free.overlap) ) [ ( toString HasFreeLoop, "" ) , ( toString FreeLoopWidth, String.fromFloat (toMM free.width) ) , ( toString FreeLoopLength, String.fromFloat (toMM free.length) ) , ( toString FreeLoopOverlap, String.fromFloat (toMM free.overlap) ) ] Nothing ->
-
@@ -274,7 +288,7 @@ []) |> (++) (if params.rendering.qrCode then [ ( Key.toString QRCode, "" ) ] [ ( toString QRCode, "" ) ] else []
-
@@ -285,22 +299,36 @@{-| 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 TaperTo, "18" ) , ( Key.toString TipSharpness, String.fromInt defaultTipSharpness ) , ( Key.toString FixedLoopWidth, String.fromFloat (toMM defaultFixedLoop.width) ) , ( Key.toString FixedLoopLength, String.fromFloat (toMM defaultFixedLoop.length) ) , ( Key.toString FreeLoopWidth, String.fromFloat (toMM defaultFreeLoop.width) ) , ( Key.toString FreeLoopLength, String.fromFloat (toMM defaultFreeLoop.length) ) , ( Key.toString FreeLoopOverlap, String.fromFloat (toMM defaultFreeLoop.overlap) ) fallbackValues : DictKeyMode -> ParametersDict fallbackValues mode = let toString = case mode of Regular -> Key.toString Compact -> Key.toCompactID in [ ( toString TaperTo, "18" ) , ( toString TipSharpness, String.fromInt defaultTipSharpness ) , ( toString FixedLoopWidth, String.fromFloat (toMM defaultFixedLoop.width) ) , ( toString FixedLoopLength, String.fromFloat (toMM defaultFixedLoop.length) ) , ( toString FreeLoopWidth, String.fromFloat (toMM defaultFreeLoop.width) ) , ( toString FreeLoopLength, String.fromFloat (toMM defaultFreeLoop.length) ) , ( toString FreeLoopOverlap, String.fromFloat (toMM defaultFreeLoop.overlap) ) ] |> Dict.fromList getKey : Key -> ParametersDict -> Maybe String getKey key fields = Dict.get (Key.toString key) fields case Dict.get (Key.toCompactID key) fields of Just value -> Just value Nothing -> Dict.get (Key.toString key) fields hasKey : Key -> ParametersDict -> Bool
-
-
-
@@ -22,6 +22,7 @@ import Parameters.Constraints exposing (NumberConstraints, constraints)import Parameters.Key as Key exposing (Key(..)) import Parameters.Parser exposing (..) import Platform.Cmd as Cmd import Preferences exposing (Preferences) import Process import Task import Time
-
@@ -48,16 +49,17 @@ , navigation : Browser.Navigation.Key, baseUrl : Url , currentUrl : Url , urlUpdate : UrlUpdate , preferences : Preferences } init : Url -> Browser.Navigation.Key -> Parameters -> ( Model, Cmd Msg ) init baseUrl key params = init : Url -> Browser.Navigation.Key -> Preferences -> Parameters -> ( Model, Cmd Msg ) init baseUrl key preferences params = let fields = Dict.union (Parameters.toDict params) Parameters.fallbackValues (Parameters.toDict Parameters.Regular params) (Parameters.fallbackValues Parameters.Regular) in ( { fields = fields , errors =
-
@@ -73,6 +75,7 @@ , navigation = key, baseUrl = baseUrl , currentUrl = baseUrl , urlUpdate = Idle , preferences = preferences } , Task.perform UrlRewriteRequested Time.now )
-
@@ -148,7 +151,7 @@ modelquery = model.parameters |> Parameters.toDict |> Parameters.toDict model.preferences.urlKeyMode |> Url.SearchParams.build url =
-
-
-
@@ -7,7 +7,7 @@ ---- SPDX-License-Identifier: MPL-2.0 module Parameters.Key exposing (Key(..), toLabel, toString) module Parameters.Key exposing (Key(..), toCompactID, toLabel, toString) type Key
-
@@ -194,3 +194,82 @@ "Color schema"QRCode -> "QR code" toCompactID : Key -> String toCompactID key = case key of Version -> "v" TipStyle -> "0" TipSharpness -> "1" Profile -> "2" TaperTo -> "3" ShoulderWidth -> "4" PaddingOffset -> "5" BuckleHoleDistance -> "6" BuckleHoleAdjustments -> "7" BuckleHoleDiameter -> "8" BuckleHoleInterval -> "9" LongPieceLength -> "a" LoopStyle -> "b" HasFixedLoop -> "c" FixedLoopWidth -> "d" FixedLoopLength -> "e" HasFreeLoop -> "f" FreeLoopWidth -> "g" FreeLoopLength -> "h" FreeLoopOverlap -> "i" ShortPieceLength -> "j" CanvasMargin -> "k" LineWidth -> "l" ColorSchema -> "m" QRCode -> "n"
-
-
-
@@ -11,6 +11,7 @@ module Preferences exposing (FieldHighlight(..), Preferences, PreviewTheme(..), decoder, defaultPreferences, encode)import Json.Decode as Decode import Json.Encode as Encode import Parameters exposing (DictKeyMode(..)) type PreviewTheme
-
@@ -81,11 +82,41 @@ "do_not_highlight") dictKeyModeDecoder : Decode.Decoder DictKeyMode dictKeyModeDecoder = Decode.string |> Decode.andThen (\str -> case str of "regular" -> Decode.succeed Regular "compact" -> Decode.succeed Compact _ -> Decode.fail ("\"" ++ str ++ "\" is not a valid DictKeyMode value") ) encodeDictKeyMode : DictKeyMode -> Encode.Value encodeDictKeyMode mode = Encode.string (case mode of Regular -> "regular" Compact -> "compact" ) {-| User preferences. This is not supposed to be shared. -} type alias Preferences = { previewTheme : PreviewTheme , fieldHighlight : FieldHighlight , urlKeyMode : DictKeyMode }
-
@@ -93,6 +124,7 @@ defaultPreferences : PreferencesdefaultPreferences = { previewTheme = SystemTheme , fieldHighlight = DoNotHighlight , urlKeyMode = Compact }
-
@@ -101,7 +133,7 @@ Always fallback to safe defaults.-} decoder : Decode.Decoder Preferences decoder = Decode.map2 Decode.map3 Preferences (Decode.oneOf [ Decode.field "preview_theme" previewThemeDecoder
-
@@ -113,6 +145,11 @@ [ Decode.field "field_highlight" fieldHighlightDecoder, Decode.succeed defaultPreferences.fieldHighlight ] ) (Decode.oneOf [ Decode.field "url_key_mode" dictKeyModeDecoder , Decode.succeed defaultPreferences.urlKeyMode ] ) encode : Preferences -> Encode.Value
-
@@ -120,4 +157,5 @@ encode p =Encode.object [ ( "preview_theme", encodePreviewTheme p.previewTheme ) , ( "field_highlight", encodeFieldHighlight p.fieldHighlight ) , ( "url_key_mode", encodeDictKeyMode p.urlKeyMode ) ]
-
-
-
@@ -15,6 +15,7 @@ import Html.Eventsimport Html.LivingStandard exposing (..) import Json.Decode as Decode import Json.Encode as Encode import Parameters exposing (DictKeyMode(..)) import Preferences exposing (FieldHighlight(..), Preferences, PreviewTheme(..))
-
@@ -53,6 +54,7 @@ type Msg= NoOp | SetPreviewTheme PreviewTheme | SetFieldHighlight FieldHighlight | SetUrlKeyMode DictKeyMode | WritePreferences
-
@@ -71,6 +73,9 @@ update WritePreferences { model | preferences = { preferences | previewTheme = theme } }SetFieldHighlight highlight -> update WritePreferences { model | preferences = { preferences | fieldHighlight = highlight } } SetUrlKeyMode mode -> update WritePreferences { model | preferences = { preferences | urlKeyMode = mode } } WritePreferences -> ( model, writePreferences (Preferences.encode model.preferences) )
-
@@ -88,6 +93,11 @@fieldHighlightId : String fieldHighlightId = "field-highlight" urlKeyModeId : String urlKeyModeId = "url-key-mode" descriptionId : String -> String
-
@@ -192,6 +202,36 @@ , name = fieldHighlightId, value = "do-not-highlight" , checked = model.preferences.fieldHighlight == DoNotHighlight , onCheck = SetFieldHighlight DoNotHighlight } [] ] , node "x-field" [] [ span [ slot "title" ] [ text "URL Parameter Mode" ] , p [ slot "description" , id (descriptionId urlKeyModeId) ] [ text "This affects QR code generation and its performance." ] , radioBox { label = [ text "Compact" ] , description = [ text "Use shortened parameter names. Cryptic but compact. Recommended." ] , name = urlKeyModeId , value = "compact" , checked = model.preferences.urlKeyMode == Compact , onCheck = SetUrlKeyMode Compact } [] , radioBox { label = [ text "Long" ] , description = [ text "Use descriptive but verbose parameter names. " , text "Generates big QR code and significantly slows down QR code generation." ] , name = urlKeyModeId , value = "regular" , checked = model.preferences.urlKeyMode == Regular , onCheck = SetUrlKeyMode Regular } [] ]
-
-
-
@@ -17,6 +17,7 @@ import Html.LivingStandard exposing (..)import Parameters import Parameters.Key as Key exposing (Key) import Parameters.Parser exposing (Error(..)) import Preferences exposing (Preferences) import Url exposing (Url) import Url.SearchParams as SearchParams
-
@@ -29,17 +30,19 @@ type alias Model ={ errors : Parameters.Parser.Errors , searchParams : Dict String String , url : Url , preferences : Preferences } init : Url -> Parameters.Parser.Errors -> Model init url errors = init : Url -> Preferences -> Parameters.Parser.Errors -> Model init url preferences errors = { errors = errors , searchParams = url.query |> Maybe.map SearchParams.parse |> Maybe.withDefault Dict.empty , url = url , preferences = preferences }
-
@@ -62,22 +65,22 @@-- VIEW defaults : Dict String String defaults = defaults : Parameters.DictKeyMode -> Dict String String defaults mode = Dict.union (Parameters.toDict Parameters.default) Parameters.fallbackValues (Parameters.toDict mode Parameters.default) (Parameters.fallbackValues mode) row : Model -> Key -> Error -> Html Msg row { searchParams, url } key error = row { searchParams, url, preferences } key error = let setLinkText : String -> Html msg setLinkText value = text ("Set to \"" ++ value ++ "\". ") withDefault = case Parameters.getKey key defaults of case Parameters.getKey key (defaults preferences.urlKeyMode) of Just value -> Dict.insert (Key.toString key) value searchParams
-
@@ -89,7 +92,7 @@ a[ slot "action" , href (Url.toString { url | query = Just (SearchParams.build withDefault) }) ] [ setLinkText (Parameters.getKey key defaults |> Maybe.withDefault "") [ setLinkText (Parameters.getKey key (defaults preferences.urlKeyMode) |> Maybe.withDefault "") , text "(default value)" ] in
-
@@ -154,7 +157,12 @@ [ span [ slot "description" ] [ text "Unsupported version." ], defaultLink , a [ slot "action" , href (Url.toString { url | query = Just (SearchParams.build (Parameters.default |> Parameters.toDict)) }) , href (Url.toString { url | query = Just (SearchParams.build (Parameters.default |> Parameters.toDict preferences.urlKeyMode)) } ) ] [ text "Use default parameters" ] ]
-
@@ -165,7 +173,7 @@view : Model -> Html Msg view model = let { url } = { url, preferences } = model in node "x-error-page"
-
@@ -176,7 +184,13 @@ [ slot "description" ][ text "This URL is not a valid URL for WWSTB." , text " Fix erroneous parameters or start with " , a [ href (Url.toString { url | query = Just (SearchParams.build (Parameters.default |> Parameters.toDict)) }) ] [ href (Url.toString { url | query = Just (SearchParams.build (Parameters.default |> Parameters.toDict preferences.urlKeyMode)) } ) ] [ text "default parameters" ] , text "." ]
-