aboutsummaryrefslogtreecommitdiffstats
path: root/style-generator/src/Decoder.elm
diff options
context:
space:
mode:
Diffstat (limited to 'style-generator/src/Decoder.elm')
-rw-r--r--style-generator/src/Decoder.elm776
1 files changed, 776 insertions, 0 deletions
diff --git a/style-generator/src/Decoder.elm b/style-generator/src/Decoder.elm
new file mode 100644
index 0000000..65dc0a2
--- /dev/null
+++ b/style-generator/src/Decoder.elm
@@ -0,0 +1,776 @@
+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 [])
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-29 00:02:04 +0000