/src/Parameters/Parser.elm at 7763db6a008a4ba3eb78077e8f46381e687cd363

-- 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 Parameters.Parser exposing (Error(..), Errors, parse)

import Dict.Any exposing (AnyDict)
import Length exposing (Length, mm, toMM)
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
    = MissingValue
    | BelowMin Float
    | AboveMax Float
    | NotALength
    | NotAnInt
    | NonexistentVariant String
    | UnsupportedParametersVersion String


type alias Errors =
    AnyDict String Key Error


mkErrors : List ( Key, Maybe Error ) -> Errors
mkErrors list =
    list
        |> List.filterMap (\( key, error ) -> Maybe.map (Tuple.pair key) error)
        |> Dict.Any.fromList Key.toString


unwrapErrors : Result Errors a -> Errors
unwrapErrors r =
    case r of
        Ok _ ->
            Dict.Any.empty Key.toString

        Err errs ->
            errs


getError : Result a b -> Maybe a
getError r =
    case r of
        Err e ->
            Just e

        _ ->
            Nothing


parseInt : Constraints.NumberConstraints Int -> String -> Result Error Int
parseInt constraints text =
    case text of
        "" ->
            Err MissingValue

        _ ->
            let
                min =
                    constraints.min
                        |> Maybe.map
                            (\m ->
                                Result.andThen
                                    (\x ->
                                        if x >= m then
                                            Ok x

                                        else
                                            Err (BelowMin (toFloat m))
                                    )
                            )
                        |> Maybe.withDefault identity

                max =
                    constraints.max
                        |> Maybe.map
                            (\m ->
                                Result.andThen
                                    (\x ->
                                        if x <= m then
                                            Ok x

                                        else
                                            Err (AboveMax (toFloat m))
                                    )
                            )
                        |> Maybe.withDefault identity
            in
            String.toInt text
                |> Result.fromMaybe NotAnInt
                |> min
                |> max


parseLength : Constraints.NumberConstraints Length -> String -> Result Error Length
parseLength constraints text =
    case text of
        "" ->
            Err MissingValue

        _ ->
            let
                min =
                    constraints.min
                        |> Maybe.map toMM
                        |> Maybe.map
                            (\m ->
                                Result.andThen
                                    (\x ->
                                        if toMM x >= m then
                                            Ok x

                                        else
                                            Err (BelowMin m)
                                    )
                            )
                        |> Maybe.withDefault identity

                max =
                    constraints.max
                        |> Maybe.map toMM
                        |> Maybe.map
                            (\m ->
                                Result.andThen
                                    (\x ->
                                        if toMM x <= m then
                                            Ok x

                                        else
                                            Err (AboveMax m)
                                    )
                            )
                        |> Maybe.withDefault identity
            in
            String.toFloat text
                |> Maybe.map mm
                |> Result.fromMaybe NotALength
                |> min
                |> max


parseColorSchema : String -> Result Error ColorSchema
parseColorSchema text =
    case text of
        "white-on-black" ->
            Ok WhiteOnBlack

        "black-on-white" ->
            Ok BlackOnWhite

        _ ->
            Err (NonexistentVariant text)


parseLoopStyle : String -> Result Error LoopStyle
parseLoopStyle text =
    case text of
        "simple" ->
            Ok Simple

        "folded" ->
            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


parseOptionalField : Key -> (String -> Result Error a) -> ParametersDict -> Result Error (Maybe a)
parseOptionalField key f fields =
    case getKey key fields of
        Just value ->
            f value |> Result.map Just

        Nothing ->
            Ok Nothing


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 FixedLoopLength (parseLength constraints.shortPiece.loops.fixed.length) fields
            )
        of
            ( Ok width, Ok length ) ->
                let
                    base =
                        Parameters.defaultFixedLoop
                in
                Ok (Just { base | width = width, length = length })

            ( width, length ) ->
                Err
                    (mkErrors
                        [ ( FixedLoopWidth, getError width )
                        , ( FixedLoopLength, getError length )
                        ]
                    )

    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 FreeLoopLength (parseLength constraints.shortPiece.loops.free.length) fields
            , parseField FreeLoopOverlap (parseLength constraints.shortPiece.loops.free.overlap) fields
            )
        of
            ( Ok width, Ok length, Ok overlap ) ->
                Ok (Just { width = width, length = length, overlap = overlap })

            ( width, length, overlap ) ->
                Err
                    (mkErrors
                        [ ( FreeLoopWidth, getError width )
                        , ( FreeLoopLength, getError length )
                        , ( FreeLoopOverlap, getError overlap )
                        ]
                    )

    else
        Ok Nothing


parseLoops : ParametersDict -> Result Errors Parameters.Loops
parseLoops fields =
    case
        ( ( parseFixedLoop fields, parseFreeLoop fields )
        , parseField LoopStyle parseLoopStyle fields
        )
    of
        ( ( Ok fixed, Ok free ), Ok style ) ->
            Ok { fixed = fixed, free = free, style = style }

        ( ( fixed, free ), style ) ->
            [ unwrapErrors fixed
            , unwrapErrors free
            , mkErrors [ ( LoopStyle, getError style ) ]
            ]
                |> List.map Dict.Any.toList
                |> List.concat
                |> Dict.Any.fromList Key.toString
                |> Err


parseShortPiece : ParametersDict -> Result Errors Parameters.ShortPiece
parseShortPiece fields =
    case
        ( parseLoops fields
        , parseField ShortPieceLength (parseLength constraints.shortPiece.length) fields
        )
    of
        ( Ok loops, Ok length ) ->
            let
                base =
                    Parameters.default.shortPiece
            in
            Ok { base | loops = loops, length = length }

        ( loops, length ) ->
            [ unwrapErrors loops
            , mkErrors [ ( ShortPieceLength, getError length ) ]
            ]
                |> List.map Dict.Any.toList
                |> List.concat
                |> Dict.Any.fromList Key.toString
                |> Err


parseBuckleHole : ParametersDict -> Result Errors Parameters.BuckleHole
parseBuckleHole fields =
    case
        ( ( parseField BuckleHoleAdjustments (parseInt constraints.longPiece.buckleHole.adjustments) fields
          , parseField BuckleHoleDiameter (parseLength constraints.longPiece.buckleHole.diameter) fields
          )
        , ( parseField BuckleHoleDistance (parseLength constraints.longPiece.buckleHole.distance) fields
          , parseField BuckleHoleInterval (parseLength constraints.longPiece.buckleHole.interval) fields
          )
        )
    of
        ( ( Ok adjustments, Ok diameter ), ( Ok distance, Ok interval ) ) ->
            Ok { adjustments = adjustments, diameter = diameter, distance = distance, interval = interval }

        ( ( adjustments, diameter ), ( distance, interval ) ) ->
            Err
                (mkErrors
                    [ ( BuckleHoleAdjustments, getError adjustments )
                    , ( BuckleHoleDiameter, getError diameter )
                    , ( BuckleHoleDistance, getError distance )
                    , ( BuckleHoleInterval, getError interval )
                    ]
                )


parseTipStyle : ParametersDict -> Result Errors Parameters.TipStyle
parseTipStyle fields =
    case getKey TipStyle fields of
        Just "round" ->
            Ok Parameters.Round

        Just "pointed" ->
            case parseField TipSharpness (parseInt constraints.longPiece.tipSharpness) fields of
                Ok sharpness ->
                    Ok (Parameters.Pointed sharpness)

                Err err ->
                    mkErrors [ ( TipSharpness, Just err ) ]
                        |> Err

        Just text ->
            mkErrors [ ( TipStyle, Just (NonexistentVariant text) ) ]
                |> Err

        Nothing ->
            mkErrors [ ( TipStyle, Just MissingValue ) ]
                |> Err


parseLongPiece : ParametersDict -> Result Errors Parameters.LongPiece
parseLongPiece fields =
    case
        ( ( parseBuckleHole fields
          , parseField LongPieceLength (parseLength constraints.longPiece.length) fields
          )
        , parseTipStyle fields
        )
    of
        ( ( Ok buckleHole, Ok length ), Ok tip ) ->
            Ok { buckleHole = buckleHole, length = length, tip = tip }

        ( ( buckleHole, length ), tip ) ->
            [ mkErrors [ ( LongPieceLength, getError length ) ]
            , unwrapErrors buckleHole
            , unwrapErrors tip
            ]
                |> List.map Dict.Any.toList
                |> List.concat
                |> Dict.Any.fromList Key.toString
                |> Err


parseRendering : ParametersDict -> Result Errors Parameters.Rendering
parseRendering fields =
    case
        ( ( parseField CanvasMargin (parseLength constraints.rendering.margin) fields
          , parseField LineWidth (parseLength constraints.rendering.lineWidth) fields
          , parseField ColorSchema parseColorSchema fields
          )
        , hasKey QRCode fields
        )
    of
        ( ( Ok margin, Ok lineWidth, Ok colorSchema ), qrCode ) ->
            let
                base =
                    Parameters.default.rendering
            in
            Ok
                { base
                    | margin = margin
                    , lineWidth = lineWidth
                    , colorSchema = colorSchema
                    , qrCode = qrCode
                }

        ( ( margin, lineWidth, colorSchema ), _ ) ->
            Err
                (mkErrors
                    [ ( CanvasMargin, getError margin )
                    , ( LineWidth, getError lineWidth )
                    , ( ColorSchema, getError colorSchema )
                    ]
                )


parseProfile : ParametersDict -> Result Errors Parameters.Profile
parseProfile fields =
    case getKey Profile fields of
        Just "straight" ->
            Ok Parameters.Straight

        Just "tapered" ->
            case parseField TaperTo (parseLength constraints.taperTo) fields of
                Ok taperTo ->
                    Ok (Parameters.Tapered taperTo)

                Err err ->
                    Err (mkErrors [ ( TaperTo, Just err ) ])

        profile ->
            Err (mkErrors [ ( Profile, Just (NonexistentVariant (Maybe.withDefault "" profile)) ) ])


parse : ParametersDict -> Result Errors Parameters
parse fields =
    case getKey Version fields of
        Just "1.0" ->
            case
                ( ( parseField ShoulderWidth (parseLength constraints.shoulderWidth) fields
                  , parseOptionalField PaddingOffset (parseLength constraints.paddingOffset) fields
                        |> Result.map (Maybe.withDefault (mm 0))
                  )
                , ( parseLongPiece fields
                  , parseShortPiece fields
                  , parseProfile fields
                  )
                , parseRendering fields
                )
            of
                ( ( Ok shoulderWidth, Ok paddingOffset ), ( Ok longPiece, Ok shortPiece, Ok profile ), Ok rendering ) ->
                    Ok
                        { shoulderWidth = shoulderWidth
                        , longPiece = longPiece
                        , shortPiece = shortPiece
                        , paddingOffset = paddingOffset
                        , rendering = rendering
                        , profile = profile
                        }

                ( ( shoulderWidth, paddingOffset ), ( longPiece, shortPiece, profile ), rendering ) ->
                    [ mkErrors
                        [ ( ShoulderWidth, getError shoulderWidth )
                        , ( PaddingOffset, getError paddingOffset )
                        ]
                    , unwrapErrors longPiece
                    , unwrapErrors shortPiece
                    , unwrapErrors rendering
                    , unwrapErrors profile
                    ]
                        |> List.map Dict.Any.toList
                        |> List.concat
                        |> Dict.Any.fromList Key.toString
                        |> Err

        Just str ->
            Err (mkErrors [ ( Version, Just (UnsupportedParametersVersion str) ) ])

        Nothing ->
            Err (mkErrors [ ( Version, Just MissingValue ) ])