/src/Parameters/Parser.elm at 1837da51943a92285a3d084d104e7bf63de9e9af

-- 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 exposing (Dict)
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
    | NotABool
    | UnsupportedParametersVersion String


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


parseFieldWithDefault : Key -> a -> (String -> Result Error a) -> ParametersDict -> Result Error a
parseFieldWithDefault key default f fields =
    getKey key fields
        |> Maybe.map f
        |> Maybe.withDefault (Ok default)


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


parseBuckle : ParametersDict -> Result Errors Parameters.Buckle
parseBuckle fields =
    case
        parseField BuckleSpringBarDiameter (parseLength constraints.shortPiece.buckle.springBarDiameter) fields
    of
        Ok springBarDiameter ->
            Ok { springBarDiameter = springBarDiameter }

        Err err ->
            Err (mkErrors [ ( BuckleSpringBarDiameter, Just 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 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 }

        ( ( 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 ) ])
                )


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 )
                    ]
                )


parse : ParametersDict -> Result Errors Parameters
parse fields =
    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
                  , parseFieldWithDefault Taper (mm 0) (parseLength constraints.taper) fields
                  )
                , parseRendering fields
                )
            of
                ( ( Ok lugWidth, Ok lining, Ok thickness ), ( Ok longPiece, Ok shortPiece, Ok taper ), Ok rendering ) ->
                    Ok
                        { lugWidth = lugWidth
                        , lining = lining
                        , thickness = thickness
                        , longPiece = longPiece
                        , shortPiece = shortPiece
                        , rendering = rendering
                        , taper = taper
                        }

                ( ( lugWidth, lining, thickness ), ( longPiece, shortPiece, taper ), rendering ) ->
                    [ mkErrors
                        [ ( LugWidth, getError lugWidth )
                        , ( LiningThickness, getError lining )
                        , ( SurfaceThickness, getError thickness )
                        , ( Taper, getError taper )
                        ]
                    , 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 ) ])