path: root/style-generator/src/Decoder.elm

module Decoder exposing (styleCode)

import Color
import Elm.Syntax.Declaration exposing (Declaration(..))
import Elm.Syntax.Exposing exposing (Exposing(..), TopLevelExpose(..))
import Elm.Syntax.Expression exposing (Expression(..), RecordSetter)
import Elm.Syntax.Infix exposing (InfixDirection(..))
import Elm.Syntax.Module exposing (Module(..))
import Elm.Syntax.Node exposing (Node(..))
import Elm.Syntax.Pattern
import Elm.Syntax.Range exposing (emptyRange)
import Elm.Syntax.TypeAnnotation exposing (TypeAnnotation(..))
import Json.Decode as D exposing (Decoder)
import Json.Encode
import String.Case exposing (toCamelCaseLower)
import Writer


node =
    Node emptyRange


wrapNodes =
    List.map node


styleCode : Decoder String
styleCode =
    D.map (file >> Writer.writeFile >> Writer.write) style


declarations styleDec =
    [ FunctionDeclaration
        { documentation = Nothing
        , signature =
            Just
                (node
                    { name = node "style"
                    , typeAnnotation = node (Typed (node ( [], "Style" )) [])
                    }
                )
        , declaration =
            node
                { name = node "style"
                , arguments = []
                , expression =
                    node <|
                        Application <|
                            wrapNodes
                                [ FunctionOrValue [] "Style"
                                , RecordExpr styleDec
                                ]
                }
        }
    ]


file styleDec =
    { moduleDefinition =
        node
            (NormalModule
                { moduleName = node [ "Style" ]
                , exposingList = node (Explicit [ node (FunctionExpose "style") ])
                }
            )
    , imports =
        [ node
            { moduleName = node [ "Mapbox", "Style" ]
            , moduleAlias = Just (node [ "Style" ])
            , exposingList = Just (Explicit [ node (TypeExpose { name = "Style", open = Just emptyRange }) ])
            }
        , node
            { moduleName = node [ "Mapbox", "Source" ]
            , moduleAlias = Just (node [ "Source" ])
            , exposingList = Nothing
            }
        , node
            { moduleName = node [ "Mapbox", "Layer" ]
            , moduleAlias = Just (node [ "Layer" ])
            , exposingList = Nothing
            }
        , node
            { moduleName = node [ "Mapbox", "Expression" ]
            , moduleAlias = Just (node [ "E" ])
            , exposingList = Just (Explicit [ node (FunctionExpose "str"), node (FunctionExpose "float"), node (FunctionExpose "int"), node (FunctionExpose "true"), node (FunctionExpose "false") ])
            }
        ]
    , declarations = List.map node (declarations styleDec)
    , comments = []
    }


style : Decoder (List (Node RecordSetter))
style =
    D.map5
        (\transition light layers sources misc ->
            [ node ( node "transition", transition )
            , node ( node "light", light )
            , node ( node "layers", layers )
            , node ( node "sources", sources )
            , node ( node "misc", misc )
            ]
        )
        (D.oneOf
            [ D.field "transition" decodeTransition
            , valueDecoder "Style" "defaultTransition"
            ]
        )
        (D.oneOf
            [ D.field "light" decodeLight
            , valueDecoder "Style" "defaultLight"
            ]
        )
        (D.field "layers" decodeLayers)
        (D.field "sources" decodeSources)
        decodeMisc


decodeTransition : Decoder (Node Expression)
decodeTransition =
    D.map2
        (\duration delay ->
            node
                (RecordExpr
                    [ node ( node "duration", node (Integer duration) )
                    , node ( node "delay", node (Integer delay) )
                    ]
                )
        )
        (D.oneOf [ D.field "duration" D.int, D.succeed 300 ])
        (D.oneOf [ D.field "delay" D.int, D.succeed 0 ])


decodeLight : Decoder (Node Expression)
decodeLight =
    valueDecoder "Style" "defaultLight"


addBogusRange index (Node _ v) =
    Node { start = { row = index, column = 0 }, end = { row = index + 1, column = 0 } } v


decodeLayers : Decoder (Node Expression)
decodeLayers =
    D.list decodeLayer
        |> D.map (\layers -> node (ListExpr (List.indexedMap addBogusRange layers)))


layerDecodeHelp t =
    D.map3 (\id source attrs -> call "Layer" t [ str id, str source, list attrs ]) (D.field "id" D.string) (D.field "source" D.string) decodeAttrs


decodeLayer : Decoder (Node Expression)
decodeLayer =
    D.field "type" D.string
        |> D.andThen
            (\t ->
                case t of
                    "background" ->
                        D.map2 (\id attrs -> call "Layer" "background" [ str id, list attrs ]) (D.field "id" D.string) decodeAttrs

                    "fill" ->
                        layerDecodeHelp "fill"

                    "symbol" ->
                        layerDecodeHelp "symbol"

                    "line" ->
                        layerDecodeHelp "line"

                    "raster" ->
                        layerDecodeHelp "raster"

                    "circle" ->
                        layerDecodeHelp "circle"

                    "fill-extrusion" ->
                        layerDecodeHelp "fillExtrusion"

                    "heatmap" ->
                        layerDecodeHelp "heatmap"

                    "hillshade" ->
                        layerDecodeHelp "hillshade"

                    other ->
                        D.fail ("Layer type " ++ t ++ " not supported")
            )


decodeAttrs : Decoder (List (Node Expression))
decodeAttrs =
    D.map3 (\top paint layout -> top ++ paint ++ layout) (D.keyValuePairs D.value) (D.field "paint" (D.keyValuePairs D.value)) (D.field "layout" (D.keyValuePairs D.value))
        |> D.andThen
            (List.filterMap
                (\( attrName, attrValue ) ->
                    case attrName of
                        "id" ->
                            Nothing

                        "type" ->
                            Nothing

                        "source" ->
                            Nothing

                        "paint" ->
                            Nothing

                        "layout" ->
                            Nothing

                        "source-layer" ->
                            decodeAttr "sourceLayer" (D.map str D.string) attrValue

                        "minzoom" ->
                            decodeAttr "minzoom" (D.map float D.float) attrValue

                        "maxzoom" ->
                            decodeAttr "maxzoom" (D.map float D.float) attrValue

                        "filter" ->
                            decodeAttr "filter" (D.oneOf [ decodeLegacyFilter, decodeValue ]) attrValue

                        other ->
                            decodeAttr (toCamelCaseLower attrName) decodeValue attrValue
                )
                >> combine
            )
        |> D.map (List.indexedMap addBogusRange)


decodeAttr : String -> Decoder (Node Expression) -> D.Value -> Maybe (Decoder (Node Expression))
decodeAttr attrName expressionNodeDecoder attrValue =
    Just
        (D.decodeValue expressionNodeDecoder attrValue
            |> resultToDecoder
            |> D.map (\v -> call "Layer" (toCamelCaseLower attrName) [ v ])
        )


resultToDecoder : Result D.Error a -> Decoder a
resultToDecoder res =
    case res of
        Ok a ->
            D.succeed a

        Err e ->
            D.fail (D.errorToString e)


decodeBool : Decoder (Node Expression)
decodeBool =
    D.bool
        |> D.map
            (\b ->
                if b then
                    evalue "true"
                else
                    evalue "false"
            )


decodeValue : Decoder (Node Expression)
decodeValue =
    D.oneOf
        [ D.string |> D.map makeConstant
        , decodeBool
        , D.float |> D.map (Floatable >> node >> ecall "float")
        , D.int |> D.map (Integer >> node >> ecall "int")
        , D.index 0 D.string |> D.andThen decodeExpression
        , todo
        ]
        |> D.map (ParenthesizedExpression >> node)


makeConstant s =
    case s of
        "map" ->
            value "E" "anchorMap"

        "viewport" ->
            value "E" "anchorViewport"

        "auto" ->
            value "E" "anchorAuto"

        "center" ->
            value "E" "positionCenter"

        "left" ->
            value "E" "positionLeft"

        "right" ->
            value "E" "positionRight"

        "top" ->
            value "E" "positionTop"

        "bottom" ->
            value "E" "positionBottom"

        "topRight" ->
            value "E" "positionTopRight"

        "topLeft" ->
            value "E" "positionTopLeft"

        "bottomLeft" ->
            value "E" "positionBottomLeft"

        "bottomRight" ->
            value "E" "positionBottomRight"

        "none" ->
            value "E" "textFitNone"

        "width" ->
            value "E" "textFitWidth"

        "height" ->
            value "E" "textFitHeight"

        "both" ->
            value "E" "textFitBoth"

        "butt" ->
            value "E" "lineCapButt"

        "round" ->
            value "E" "lineCapRound"

        "square" ->
            value "E" "lineCapSquare"

        "bevel" ->
            value "E" "lineJoinBevel"

        "miter" ->
            value "E" "lineJoinMiter"

        "point" ->
            value "E" "symbolPlacementPoint"

        "line-center" ->
            value "E" "symbolPlacementLineCenter"

        "line" ->
            value "E" "symbolPlacementLine"

        "uppercase" ->
            value "E" "textTransformUppercase"

        "lowercase" ->
            value "E" "textTransformLowercase"

        "linear" ->
            value "E" "rasterResamplingLinear"

        "nearest" ->
            value "E" "rasterResamplingNearest"

        _ ->
            case Color.parse s of
                Ok { r, g, b, a } ->
                    call "E" "rgba" [ integer r, integer g, integer b, float a ]

                Err err ->
                    str s |> ecall "str"



-- legacy filter


decodeLegacyFilter : Decoder (Node Expression)
decodeLegacyFilter =
    let
        decodeProp =
            D.index 1 D.string
                |> D.map
                    (\prop ->
                        case prop of
                            "$type" ->
                                value "E" "geometryType"

                            "$id" ->
                                value "E" "id"

                            _ ->
                                call "E" "getProperty" [ ecall "str" (str prop) ]
                    )

        decodeVal =
            D.index 2 <|
                D.oneOf
                    [ D.map (str >> ecall "str") D.string
                    , D.map (float >> ecall "float") D.float
                    , decodeBool
                    ]

        decodeVals =
            D.list <|
                D.oneOf
                    [ D.map (str >> ecall "str") D.string
                    , D.map (float >> ecall "float") D.float
                    , decodeBool
                    ]
    in
    D.index 0 D.string
        |> D.andThen
            (\filter ->
                case filter of
                    "all" ->
                        decodeTail decodeLegacyFilter |> D.map (\filters -> call "E" "all" [ list filters ])

                    "any" ->
                        decodeTail decodeLegacyFilter |> D.map (\filters -> call "E" "any" [ list filters ])

                    "none" ->
                        decodeTail decodeLegacyFilter |> D.map (\filters -> call "E" "all" [ list (List.map (\f -> call "E" "not" [ f ]) filters) ])

                    "has" ->
                        D.index 1 D.string |> D.map (\prop -> call "E" "hasProperty" [ ecall "str" (str prop) ])

                    "!has" ->
                        D.index 1 D.string |> D.map (\prop -> call "E" "not" [ call "E" "hasProperty" [ ecall "str" (str prop) ] ])

                    "==" ->
                        D.map2 (\prop val -> pipelineCall "E" "isEqual" [ prop, val ]) decodeProp decodeVal

                    "!=" ->
                        D.map2 (\prop val -> pipelineCall "E" "notEqual" [ prop, val ]) decodeProp decodeVal

                    ">" ->
                        D.map2 (\prop val -> pipelineCall "E" "greaterThan" [ prop, val ]) decodeProp decodeVal

                    ">=" ->
                        D.map2 (\prop val -> pipelineCall "E" "greaterThanOrEqual" [ prop, val ]) decodeProp decodeVal

                    "<" ->
                        D.map2 (\prop val -> pipelineCall "E" "lessThan" [ prop, val ]) decodeProp decodeVal

                    "<=" ->
                        D.map2 (\prop val -> pipelineCall "E" "lessThanOrEqual" [ prop, val ]) decodeProp decodeVal

                    "in" ->
                        D.map2
                            (\prop values ->
                                List.drop 2 values
                                    |> List.map (\v -> pipelineCall "E" "isEqual" [ prop, v ])
                                    |> list
                                    |> List.singleton
                                    |> call "E" "any"
                            )
                            decodeProp
                            decodeVals

                    "!in" ->
                        D.map2
                            (\prop values ->
                                List.drop 2 values
                                    |> List.map (\v -> pipelineCall "E" "notEqual" [ prop, v ])
                                    |> list
                                    |> List.singleton
                                    |> call "E" "all"
                            )
                            decodeProp
                            decodeVals

                    _ ->
                        D.fail "not actually a legacy filter"
            )



-- Expressions


decodeTail : Decoder a -> Decoder (List a)
decodeTail itemDecoder =
    D.list D.value
        |> D.andThen
            (\l ->
                case l of
                    [] ->
                        D.fail "Can't get tail of empty"

                    head :: t ->
                        List.map (subdecode itemDecoder) t |> combine
            )


subdecode : Decoder a -> D.Value -> Decoder a
subdecode d v =
    D.decodeValue d v |> resultToDecoder


decodeMatch : Bool -> any -> Decoder (Node Expression)
decodeMatch isString _ =
    decodeTail D.value
        |> D.andThen
            (\args ->
                case args of
                    [] ->
                        todo

                    head :: tail ->
                        D.map2
                            (\cond rest ->
                                parens
                                    (node
                                        (OperatorApplication "|>"
                                            Right
                                            cond
                                            (call "E"
                                                (if isString then
                                                    "matchesStr"
                                                 else
                                                    "matchesFloat"
                                                )
                                                rest
                                            )
                                        )
                                    )
                            )
                            (subdecode decodeValue head)
                            (organizeArgs
                                (if isString then
                                    D.map str D.string
                                 else
                                    D.map float D.float
                                )
                                []
                                tail
                            )
            )


organizeArgs : Decoder (Node Expression) -> List (Decoder (Node Expression)) -> List D.Value -> Decoder (List (Node Expression))
organizeArgs inpDec accu args =
    case args of
        [] ->
            combine [ D.map list (List.reverse accu |> combine) ]

        [ default ] ->
            combine [ D.map list (List.reverse accu |> combine), subdecode decodeValue default ]

        a :: b :: rest ->
            let
                newAccu =
                    D.map2
                        (\inp out ->
                            parens (node (TupledExpression [ inp, out ]))
                        )
                        (subdecode inpDec a)
                        (subdecode decodeValue b)
                        :: accu
            in
            organizeArgs inpDec newAccu rest


decodeExpression : String -> Decoder (Node Expression)
decodeExpression funName =
    case funName of
        "literal" ->
            D.index 1
                (D.oneOf
                    [ D.list D.string |> D.map (\strs -> call "E" "strings" [ list (List.map str strs) ])
                    , D.list D.float |> D.map (\floats -> call "E" "floats" [ list (List.map float floats) ])
                    ]
                )

        "match" ->
            D.oneOf
                [ D.index 2 D.string |> D.andThen (decodeMatch True)
                , D.index 2 D.float |> D.andThen (decodeMatch False)
                ]

        "exponential" ->
            D.map (\base -> call "E" "Exponential" [ float base ]) (D.index 1 D.float)

        "interpolate" ->
            D.map3
                (\interpolation options input ->
                    pipelineCall "E" "interpolate" (input :: interpolation :: options)
                )
                (D.index 1 decodeValue)
                (decodeTail D.value |> D.map (List.drop 2) |> D.andThen (organizeArgs (D.map float D.float) []))
                (D.index 2 decodeValue)

        "step" ->
            D.map3
                (\inp def stps ->
                    pipelineCall "E" "step" (inp :: def :: stps)
                )
                (D.index 1 decodeValue)
                (D.index 2 decodeValue)
                (decodeTail D.value |> D.map (List.drop 2) |> D.andThen (organizeArgs (D.map float D.float) []))

        _ ->
            let
                fallback =
                    decodeTail decodeValue
                        |> D.map
                            (\arguments ->
                                case funName of
                                    "==" ->
                                        pipelineCall "E" "isEqual" arguments

                                    "!=" ->
                                        pipelineCall "E" "notEqual" arguments

                                    "!has" ->
                                        todoExpr "!has is not supported"

                                    "!in" ->
                                        todoExpr "!in is not supported"

                                    "in" ->
                                        todoExpr "in is not supported"

                                    ">=" ->
                                        pipelineCall "E" "greaterThanOrEqual" arguments

                                    "<=" ->
                                        pipelineCall "E" "lessThanOrEqual" arguments

                                    "concat" ->
                                        pipelineCall "E" "append" arguments

                                    "linear" ->
                                        call "E" "Linear" arguments

                                    "rgb" ->
                                        call "E" "makeRGBColor" arguments

                                    "rgba" ->
                                        call "E" "makeRGBAColor" arguments

                                    "to-rgba" ->
                                        call "E" "rgbaChannels" arguments

                                    "-" ->
                                        pipelineCall "E" "minus" arguments

                                    "*" ->
                                        pipelineCall "E" "multiply" arguments

                                    "+" ->
                                        pipelineCall "E" "plus" arguments

                                    "/" ->
                                        pipelineCall "E" "divideBy" arguments

                                    "%" ->
                                        pipelineCall "E" "modBy" arguments

                                    "^" ->
                                        pipelineCall "E" "raiseBy" arguments

                                    "get" ->
                                        if List.length arguments == 1 then
                                            call "E" "getProperty" arguments
                                        else
                                            call "E" "get" arguments

                                    _ ->
                                        call "E" (toCamelCaseLower funName) arguments
                            )
            in
            if String.toLower funName /= funName then
                D.oneOf
                    [ D.map (\strs -> call "E" "strings" [ list (List.map str strs) ]) <| D.list D.string
                    , fallback
                    ]
            else
                fallback


decodeSources : Decoder (Node Expression)
decodeSources =
    D.keyValuePairs decodeSource
        |> D.map (List.map (\( key, fn ) -> fn key))
        |> D.map (\sources -> node (ListExpr sources))


decodeSource : Decoder (String -> Node Expression)
decodeSource =
    D.field "type" D.string
        |> D.andThen
            (\t ->
                case t of
                    "vector" ->
                        D.field "url" D.string
                            |> D.map
                                (\url ->
                                    \id ->
                                        call "Source"
                                            "vectorFromUrl"
                                            [ str id
                                            , str url
                                            ]
                                )

                    _ ->
                        D.succeed (\a -> todoExpr ("type " ++ t ++ "not yet supported"))
            )


decodeMisc : Decoder (Node Expression)
decodeMisc =
    D.succeed (node (ListExpr []))


list l =
    node (ListExpr l)


str s =
    node (Literal s)


ecall name arg =
    parens (node (Application [ node (FunctionOrValue [] name), arg ]))


call ns name args =
    parens (node (Application (node (FunctionOrValue [ ns ] name) :: args)))


pipelineCall ns name args =
    case args of
        fst :: rest ->
            parens (node (OperatorApplication "|>" Left fst (call ns name rest)))

        _ ->
            todoExpr <| "Wrong number of arguments passed to " ++ ns ++ "." ++ name


value ns name =
    node (FunctionOrValue [ ns ] name)


evalue name =
    node (FunctionOrValue [] name)


integer =
    Integer >> node


float =
    Floatable >> node


parens =
    ParenthesizedExpression >> node


valueDecoder ns name =
    D.succeed (node (FunctionOrValue [ ns ] name))


todo : Decoder (Node Expression)
todo =
    D.map (\val -> todoExpr ("The expression " ++ Json.Encode.encode 0 val ++ " is not yet supported")) D.value


todoExpr msg =
    node (ParenthesizedExpression (call "Debug" "todo" [ str msg ]))


combine : List (Decoder a) -> Decoder (List a)
combine =
    List.foldr (D.map2 (::)) (D.succeed [])