Add highlighting feature Sometimes I myself wonder "how does this field's value affect the generated template?"

Changes

7 changed files (+212/-54)

• src/Main.elm
  • @@ -17,7 +17,7 @@ import Html.LivingStandard exposing (..)
    import Json.Decode import Parameters import Parameters.App - import Preferences + import Preferences exposing (FieldHighlight(..)) import Preferences.App import Template exposing (template) import Url exposing (Url)
  • @@ -115,6 +115,15 @@
    view : Model -> Browser.Document Msg view model = + let + highlighting = + case model.preferences.preferences.fieldHighlight of + HighlightOnPreview -> + model.parameters.highlighting + + DoNotHighlight -> + Nothing + in { title = "" , body = [ node "x-app-layout"
  • @@ -138,7 +147,7 @@ Preferences.PrintTheme ->
    "print" ) ] - [ template model.parameters.parameters [] ] + [ template model.parameters.parameters highlighting [] ] , node "x-panel" [ slot "parameters" ] [ node "x-parameters"
• src/Parameters/App.elm
  • @@ -12,13 +12,14 @@
    import Dict exposing (Dict) import Html exposing (hr, input, label, node, p, span, text) import Html.Attributes exposing (..) - import Html.Events exposing (onInput) + import Html.Events exposing (onBlur, onFocus, onInput) import Html.LivingStandard exposing (..) import Length exposing (Length, toMM) import Parameters exposing (ColorSchema(..), LoopStyle(..), Parameters, colorSchemaToString, defaultFixedLoop, defaultFreeLoop, loopStyleToString) import Parameters.Constraints exposing (NumberConstraints, constraints) import Parameters.Key as Key exposing (Key(..)) import Parameters.Parser exposing (..) + import Platform.Cmd as Cmd
  • @@ -37,6 +38,7 @@ type alias Model =
    { fields : Fields , errors : Errors , parameters : Parameters + , highlighting : Maybe Key }
  • @@ -99,6 +101,7 @@
    Err errors -> errors , parameters = params + , highlighting = Nothing }
  • @@ -109,6 +112,8 @@
    type Msg = FieldChanged Key String | ColorSchemaChanged ColorSchema + | Highlight Key + | Unhighlight Key parseField : Key -> (String -> Result Error a) -> Fields -> Result Error a
  • @@ -373,6 +378,16 @@ ( { model | parameters = { parameters | rendering = { rendering | colorSchema = schema } } }
    , Cmd.none ) + Highlight key -> + ( { model | highlighting = Just key }, Cmd.none ) + + Unhighlight key -> + if model.highlighting == Just key then + ( { model | highlighting = Nothing }, Cmd.none ) + + else + ( model, Cmd.none ) + -- VIEW
  • @@ -507,6 +522,8 @@ [ input
    (id (Key.toString key) :: value (model.fields |> Dict.get (Key.toString key) |> Maybe.withDefault "") :: onInput (FieldChanged key) + :: onFocus (Highlight key) + :: onBlur (Unhighlight key) :: ariaInvalid (not (Dict.get (Key.toString key) model.errors == Nothing)) :: ariaDescribedBy [ errorId key, descriptionId key ] :: Html.Attributes.disabled disabled
• src/Preferences.elm
  • @@ -7,7 +7,7 @@ --
    -- SPDX-License-Identifier: MPL-2.0 - module Preferences exposing (Preferences, PreviewTheme(..), decoder, defaultPreferences, encode) + module Preferences exposing (FieldHighlight(..), Preferences, PreviewTheme(..), decoder, defaultPreferences, encode) import Json.Decode as Decode import Json.Encode as Encode
  • @@ -47,29 +47,70 @@ "print"
    ) + type FieldHighlight + = HighlightOnPreview + | DoNotHighlight + + + fieldHighlightDecoder : Decode.Decoder FieldHighlight + fieldHighlightDecoder = + Decode.string + |> Decode.andThen + (\str -> + case str of + "highlight_on_preview" -> + Decode.succeed HighlightOnPreview + + "do_not_highlight" -> + Decode.succeed DoNotHighlight + + _ -> + Decode.fail ("\"" ++ str ++ "\" is not a valid FieldHighlight value") + ) + + + encodeFieldHighlight : FieldHighlight -> Decode.Value + encodeFieldHighlight status = + Encode.string + (case status of + HighlightOnPreview -> + "highlight_on_preview" + + DoNotHighlight -> + "do_not_highlight" + ) + + {-| User preferences. This is not supposed to be shared. -} type alias Preferences = { previewTheme : PreviewTheme + , fieldHighlight : FieldHighlight } defaultPreferences : Preferences defaultPreferences = { previewTheme = SystemTheme + , fieldHighlight = DoNotHighlight } decoder : Decode.Decoder Preferences decoder = - Decode.map + Decode.map2 Preferences (Decode.field "preview_theme" (Decode.oneOf [ previewThemeDecoder, Decode.succeed defaultPreferences.previewTheme ]) ) + (Decode.field "field_highlight" + (Decode.oneOf [ fieldHighlightDecoder, Decode.succeed defaultPreferences.fieldHighlight ]) + ) encode : Preferences -> Encode.Value encode p = Encode.object - [ ( "preview_theme", encodePreviewTheme p.previewTheme ) ] + [ ( "preview_theme", encodePreviewTheme p.previewTheme ) + , ( "field_highlight", encodeFieldHighlight p.fieldHighlight ) + ]
• src/Preferences/App.elm
  • @@ -15,7 +15,7 @@ import Html.Events
    import Html.LivingStandard exposing (..) import Json.Decode as Decode import Json.Encode as Encode - import Preferences exposing (Preferences, PreviewTheme(..)) + import Preferences exposing (FieldHighlight(..), Preferences, PreviewTheme(..))
  • @@ -52,6 +52,8 @@
    type Msg = NoOp | SetPreviewTheme PreviewTheme + | SetFieldHighlight FieldHighlight + | WritePreferences update : Msg -> Model -> ( Model, Cmd Msg )
  • @@ -65,13 +67,13 @@ NoOp ->
    ( model, Cmd.none ) SetPreviewTheme theme -> - let - nextPreferences = - { preferences | previewTheme = theme } - in - ( { model | preferences = { preferences | previewTheme = theme } } - , writePreferences (Preferences.encode nextPreferences) - ) + update WritePreferences { model | preferences = { preferences | previewTheme = theme } } + + SetFieldHighlight highlight -> + update WritePreferences { model | preferences = { preferences | fieldHighlight = highlight } } + + WritePreferences -> + ( model, writePreferences (Preferences.encode model.preferences) )
  • @@ -81,6 +83,11 @@
    previewThemeId : String previewThemeId = "preview-theme" + + + fieldHighlightId : String + fieldHighlightId = + "field-highlight" descriptionId : String -> String
  • @@ -157,6 +164,34 @@ , name = previewThemeId
    , value = "print" , checked = model.preferences.previewTheme == PrintTheme , onCheck = SetPreviewTheme PrintTheme + } + [] + ] + , node "x-field" + [] + [ span [ slot "title" ] [ text "Field Highlight" ] + , p + [ slot "description" + , id (descriptionId fieldHighlightId) + ] + [ text "This does not affect print output." ] + , radioBox + { label = [ text "Enabled" ] + , description = + [ text "Highlight lines on preview relevant to the focused field." ] + , name = fieldHighlightId + , value = "highlight-on-preview" + , checked = model.preferences.fieldHighlight == HighlightOnPreview + , onCheck = SetFieldHighlight HighlightOnPreview + } + [] + , radioBox + { label = [ text "Disabled" ] + , description = [ text "Do not highlight on field focus." ] + , name = fieldHighlightId + , value = "do-not-highlight" + , checked = model.preferences.fieldHighlight == DoNotHighlight + , onCheck = SetFieldHighlight DoNotHighlight } [] ]
• src/Template.elm
  • @@ -11,6 +11,7 @@ module Template exposing (template)
    import Length exposing (toMM) import Parameters exposing (LoopStyle(..), Parameters, canvasSizeDimension) + import Parameters.Key exposing (Key) import String import Svg exposing (..) import Svg.Attributes exposing (..)
  • @@ -22,8 +23,8 @@ import Template.Layout.Container as Container
    import Template.Layout.Coordinate exposing (Request(..)) - template : Parameters -> List (Svg.Attribute msg) -> Svg.Svg msg - template params attrs = + template : Parameters -> Maybe Key -> List (Svg.Attribute msg) -> Svg.Svg msg + template params highlighting attrs = let ( canvasWidth, canvasHeight ) = canvasSizeDimension params.rendering.size
  • @@ -66,7 +67,7 @@ |> Container.gapped 10
    |> Container.aligned Container.Center |> Container.padded margin |> Container.build - [ cuts params + [ cuts params highlighting , infoArea params ] |> Layout.render { width = canvasWidth, height = canvasHeight }
• src/Template/Cuts.elm
  • @@ -11,6 +11,7 @@ module Template.Cuts exposing (cuts)
    import Length exposing (Length, toMM) import Parameters exposing (LoopStyle(..), Parameters) + import Parameters.Key exposing (Key(..)) import Svg exposing (..) import Svg.Attributes exposing (..) import Svg.Path as Path exposing (..)
  • @@ -19,8 +20,17 @@ import Template.Layout.Coordinate exposing (Request(..))
    import Template.Layout.Item exposing (Item) - cuts : Parameters -> Item msg - cuts params = + highlightStroke : Bool -> Svg.Attribute msg + highlightStroke enabled = + if enabled then + class "highlight-stroke" + + else + class "highlight-none" + + + cuts : Parameters -> Maybe Key -> Item msg + cuts params highlighting = -- TODO: Pack items more smartly, so it won't push infoArea out rows |> sized (AtLeast 0) (AtLeast 0)
  • @@ -31,21 +41,21 @@ |> Container.build
    ([ columns |> gapped (toMM params.rendering.gap) |> Container.build - ([ surfacePieces params - , linings params + ([ surfacePieces params highlighting + , linings params highlighting ] |> List.map noGrow ) |> Just - , loops params + , loops params highlighting ] |> List.filterMap identity |> List.map noGrow ) - surfacePieces : Parameters -> Item msg - surfacePieces params = + surfacePieces : Parameters -> Maybe Key -> Item msg + surfacePieces params highlighting = rows |> aligned Container.Center |> gapped (toMM params.rendering.gap / 2)
  • @@ -67,7 +77,7 @@ )
    , columns |> gapped (toMM params.rendering.gap) |> Container.build - [ longPiece params, shortPiece params ] + [ longPiece params highlighting, shortPiece params highlighting ] ]
  • @@ -80,8 +90,8 @@ , strokeDasharray "1 0.5"
    ] - longPiece : Parameters -> Item msg - longPiece params = + longPiece : Parameters -> Maybe Key -> Item msg + longPiece params highlighting = let lugWidth = toMM params.lugWidth
  • @@ -117,6 +127,7 @@ ]
    , fill "none" , stroke "currentColor" , strokeWidth (toMM params.rendering.lineWidth |> String.fromFloat) + , highlightStroke (highlighting == Just LongPieceLength || highlighting == Just LugWidth) ] [] :: Svg.path
  • @@ -157,14 +168,25 @@ buckleHole.diameter
    ( p.x + lugWidth / 2 , p.y + offset + interval * toFloat index ) + [ highlightStroke + (highlighting + == Just BuckleHoleDiameter + || highlighting + == Just BuckleHoleCount + || highlighting + == Just BuckleHoleInterval + || highlighting + == Just BuckleHoleOffset + ) + ] ) ) ) } - hole : Parameters -> Length -> ( Float, Float ) -> Svg msg - hole params diameter ( cx, cy ) = + hole : Parameters -> Length -> ( Float, Float ) -> List (Svg.Attribute msg) -> Svg msg + hole params diameter ( cx, cy ) attrs = let radius = toMM diameter / 2
  • @@ -172,13 +194,14 @@ in
    g [] [ circle - [ Svg.Attributes.cx (String.fromFloat cx) - , Svg.Attributes.cy (String.fromFloat cy) - , r (String.fromFloat radius) - , fill "none" - , stroke "currentColor" - , strokeWidth (toMM params.rendering.lineWidth |> String.fromFloat) - ] + (Svg.Attributes.cx (String.fromFloat cx) + :: Svg.Attributes.cy (String.fromFloat cy) + :: r (String.fromFloat radius) + :: fill "none" + :: stroke "currentColor" + :: strokeWidth (toMM params.rendering.lineWidth |> String.fromFloat) + :: attrs + ) [] , g [ fill "none"
  • @@ -203,8 +226,8 @@ ]
    ] - shortPiece : Parameters -> Item msg - shortPiece params = + shortPiece : Parameters -> Maybe Key -> Item msg + shortPiece params highlighting = let lugWidth = toMM params.lugWidth
  • @@ -235,6 +258,7 @@ ]
    , fill "none" , stroke "currentColor" , strokeWidth (toMM params.rendering.lineWidth |> String.fromFloat) + , highlightStroke (highlighting == Just ShortPieceLength || highlighting == Just LugWidth) ] [] , g
  • @@ -281,8 +305,8 @@ ]
    } - linings : Parameters -> Item msg - linings params = + linings : Parameters -> Maybe Key -> Item msg + linings params highlighting = rows |> aligned Container.Center |> gapped (toMM params.rendering.gap / 2)
  • @@ -304,12 +328,12 @@ )
    , columns |> gapped (toMM params.rendering.gap) |> Container.build - [ longLining params, shortLining params ] + [ longLining params highlighting, shortLining params highlighting ] ] - longLining : Parameters -> Item msg - longLining params = + longLining : Parameters -> Maybe Key -> Item msg + longLining params highlighting = let lugWidth = toMM params.lugWidth
  • @@ -341,13 +365,14 @@ ]
    , fill "none" , stroke "currentColor" , strokeWidth (toMM params.rendering.lineWidth |> String.fromFloat) + , highlightStroke (highlighting == Just LugWidth || highlighting == Just LongPieceLength) ] [] } - shortLining : Parameters -> Item msg - shortLining params = + shortLining : Parameters -> Maybe Key -> Item msg + shortLining params highlighting = let lugWidth = toMM params.lugWidth
  • @@ -370,13 +395,14 @@ ]
    , fill "none" , stroke "currentColor" , strokeWidth (toMM params.rendering.lineWidth |> String.fromFloat) + , highlightStroke (highlighting == Just LugWidth || highlighting == Just ShortPieceLength) ] [] } - loops : Parameters -> Maybe (Item msg) - loops params = + loops : Parameters -> Maybe Key -> Maybe (Item msg) + loops params highlighting = let root = params.shortPiece.loops
  • @@ -407,8 +433,8 @@ )
    , columns |> gapped (toMM params.rendering.gap) |> Container.build - ([ fixedLoop params - , freeLoop params + ([ fixedLoop params highlighting + , freeLoop params highlighting ] |> List.filterMap identity )
  • @@ -416,8 +442,8 @@ ]
    |> Just - fixedLoop : Parameters -> Maybe (Item msg) - fixedLoop params = + fixedLoop : Parameters -> Maybe Key -> Maybe (Item msg) + fixedLoop params highlighting = Maybe.map (\{ width, play } -> let
  • @@ -457,6 +483,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x, p.y + yOffset ) , HorizontalLineTo Relative lugWidth ] + , highlightStroke (highlighting == Just LugWidth) ] [] , Svg.path
  • @@ -464,6 +491,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x + lugWidth, p.y + yOffset ) , HorizontalLineTo Relative strapThickness ] + , highlightStroke (highlighting == Just SurfaceThickness || highlighting == Just LiningThickness) ] [] , Svg.path
  • @@ -471,6 +499,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x + lugWidth + strapThickness, p.y + yOffset ) , HorizontalLineTo Relative lugWidth ] + , highlightStroke (highlighting == Just LugWidth) ] [] , Svg.path
  • @@ -478,6 +507,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x + lugWidth * 2 + strapThickness, p.y + yOffset ) , HorizontalLineTo Relative strapThickness ] + , highlightStroke (highlighting == Just SurfaceThickness || highlighting == Just LiningThickness) ] [] , Svg.path
  • @@ -485,6 +515,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x + lugWidth * 2 + strapThickness * 2, p.y + yOffset ) , HorizontalLineTo Relative (toMM play) ] + , highlightStroke (highlighting == Just FixedLoopPlay) ] [] ]
  • @@ -505,6 +536,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x, p.y ) , VerticalLineTo Relative (toMM width) ] + , highlightStroke (highlighting == Just FixedLoopWidth) ] [] , Svg.path
  • @@ -512,6 +544,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x + length, p.y ) , VerticalLineTo Relative (toMM width) ] + , highlightStroke (highlighting == Just FixedLoopWidth) ] [] ]
  • @@ -550,6 +583,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x, p.y ) , VerticalLineTo Relative (toMM width * 2) ] + , highlightStroke (highlighting == Just FixedLoopWidth) ] [] , Svg.path
  • @@ -557,6 +591,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x + length, p.y ) , VerticalLineTo Relative (toMM width * 2) ] + , highlightStroke (highlighting == Just FixedLoopWidth) ] [] ]
  • @@ -567,8 +602,8 @@ )
    params.shortPiece.loops.fixed - freeLoop : Parameters -> Maybe (Item msg) - freeLoop params = + freeLoop : Parameters -> Maybe Key -> Maybe (Item msg) + freeLoop params highlighting = Maybe.map (\{ width, play, overlap } -> let
  • @@ -606,6 +641,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x, p.y + yOffset ) , HorizontalLineTo Relative lugWidth ] + , highlightStroke (highlighting == Just LugWidth) ] [] , Svg.path
  • @@ -613,6 +649,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x + lugWidth, p.y + yOffset ) , HorizontalLineTo Relative strapThickness ] + , highlightStroke (highlighting == Just SurfaceThickness || highlighting == Just LiningThickness) ] [] , Svg.path
  • @@ -620,6 +657,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x + lugWidth + strapThickness, p.y + yOffset ) , HorizontalLineTo Relative lugWidth ] + , highlightStroke (highlighting == Just LugWidth) ] [] , Svg.path
  • @@ -627,6 +665,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x + lugWidth * 2 + strapThickness, p.y + yOffset ) , HorizontalLineTo Relative strapThickness ] + , highlightStroke (highlighting == Just SurfaceThickness || highlighting == Just LiningThickness) ] [] , Svg.path
  • @@ -634,6 +673,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x + lugWidth * 2 + strapThickness * 2, p.y + yOffset ) , HorizontalLineTo Relative (toMM play) ] + , highlightStroke (highlighting == Just FreeLoopPlay) ] [] , Svg.path
  • @@ -641,6 +681,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x + lugWidth * 2 + strapThickness * 2 + toMM play, p.y + yOffset ) , HorizontalLineTo Relative (toMM overlap) ] + , highlightStroke (highlighting == Just FreeLoopOverlap) ] [] ]
  • @@ -651,7 +692,7 @@ [ hCutLine 0
    , hCutLine materialWidth , Svg.path [ Path.d - [ MoveTo Absolute ( p.x + toMM overlap, p.y ) + [ MoveTo Absolute ( p.x + length - toMM overlap, p.y ) , VerticalLineTo Relative materialWidth ] , fill "none"
  • @@ -672,6 +713,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x, p.y ) , VerticalLineTo Relative (toMM width) ] + , highlightStroke (highlighting == Just FreeLoopWidth) ] [] , Svg.path
  • @@ -679,6 +721,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x + length, p.y ) , VerticalLineTo Relative (toMM width) ] + , highlightStroke (highlighting == Just FreeLoopWidth) ] [] ]
  • @@ -717,6 +760,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x, p.y ) , VerticalLineTo Relative (toMM width * 2) ] + , highlightStroke (highlighting == Just FreeLoopWidth) ] [] , Svg.path
  • @@ -724,6 +768,7 @@ [ Path.d
    [ MoveTo Absolute ( p.x + length, p.y ) , VerticalLineTo Relative (toMM width * 2) ] + , highlightStroke (highlighting == Just FreeLoopWidth) ] [] ]
• src/index.html
  • @@ -50,6 +50,10 @@ box-sizing: border-box;
    margin: 0; } + :root { + --_highlight-color: oklch(50% 0.4 0deg); + } + @font-face { font-family: "Barlow"; font-weight: normal;
  • @@ -78,6 +82,12 @@
    @page { size: A4; margin: 0; + } + } + + @media not print { + x-preview > svg .highlight-stroke { + stroke: var(--_highlight-color); } } </style>