From 075a1730211ed26e227bc8de6ad9a032048e66ee Mon Sep 17 00:00:00 2001 From: Jakub Hampl Date: Tue, 11 Sep 2018 09:50:38 +0100 Subject: Add style generator --- style-generator/elm.json | 33 ++ style-generator/src/Color.elm | 376 +++++++++++++++++++ style-generator/src/Decoder.elm | 776 ++++++++++++++++++++++++++++++++++++++++ style-generator/src/Main.elm | 138 +++++++ style-generator/src/Writer.elm | 640 +++++++++++++++++++++++++++++++++ 5 files changed, 1963 insertions(+) create mode 100644 style-generator/elm.json create mode 100644 style-generator/src/Color.elm create mode 100644 style-generator/src/Decoder.elm create mode 100644 style-generator/src/Main.elm create mode 100644 style-generator/src/Writer.elm (limited to 'style-generator') diff --git a/style-generator/elm.json b/style-generator/elm.json new file mode 100644 index 0000000..4f116f6 --- /dev/null +++ b/style-generator/elm.json @@ -0,0 +1,33 @@ +{ + "type": "application", + "source-directories": [ + "src" + ], + "elm-version": "0.19.0", + "dependencies": { + "direct": { + "elm/browser": "1.0.0", + "elm/core": "1.0.0", + "elm/html": "1.0.0", + "elm/http": "1.0.0", + "elm/json": "1.0.0", + "elm/parser": "1.1.0", + "elm-community/list-extra": "8.0.0", + "stil4m/elm-syntax": "6.1.0", + "stil4m/structured-writer": "1.0.2", + "the-sett/elm-string-case": "1.0.2" + }, + "indirect": { + "elm/time": "1.0.0", + "elm/url": "1.0.0", + "elm/virtual-dom": "1.0.0", + "elm-community/json-extra": "4.0.0", + "rtfeldman/elm-hex": "1.0.0", + "rtfeldman/elm-iso8601-date-strings": "1.1.2" + } + }, + "test-dependencies": { + "direct": {}, + "indirect": {} + } +} \ No newline at end of file diff --git a/style-generator/src/Color.elm b/style-generator/src/Color.elm new file mode 100644 index 0000000..b4e8b73 --- /dev/null +++ b/style-generator/src/Color.elm @@ -0,0 +1,376 @@ +module Color exposing (parse) + +import Bitwise exposing (shiftLeftBy) +import Parser exposing ((|.), (|=), Parser, backtrackable, end, keyword, oneOf, spaces, succeed, symbol) + + +type alias Color = + { r : Int, g : Int, b : Int, a : Float } + + +parser : Parser Color +parser = + oneOf + [ keywords + , hsla + + -- , rgba + -- , hex + ] + |. end + + +fromHSLA hue sat light alpha = + let + ( h, s, l ) = + ( toFloat hue / 360, toFloat sat / 100, toFloat light / 100 ) + + m2 = + if l <= 0.5 then + l * (s + 1) + else + l + s - l * s + + m1 = + l * 2 - m2 + + r = + hueToRgb (h + 1 / 3) + + g = + hueToRgb h + + b = + hueToRgb (h - 1 / 3) + + hueToRgb h__ = + let + h_ = + if h__ < 0 then + h__ + 1 + else if h__ > 1 then + h__ - 1 + else + h__ + in + if h_ * 6 < 1 then + m1 + (m2 - m1) * h_ * 6 + else if h_ * 2 < 1 then + m2 + else if h_ * 3 < 2 then + m1 + (m2 - m1) * (2 / 3 - h_) * 6 + else + m1 + in + Color (r * 255 |> floor) (g * 255 |> floor) (b * 255 |> floor) alpha + + +hsla : Parser Color +hsla = + succeed fromHSLA + |. oneOf [ keyword "hsla", keyword "hsl" ] + |. symbol "(" + |= angle + |. spaces + |. symbol "," + |. spaces + |= percentage + |. spaces + |. symbol "," + |. spaces + |= percentage + |= oneOf + [ succeed identity + |. symbol "," + |. spaces + |= Parser.float + , succeed 1 + ] + |. symbol ")" + + +angle = + Parser.map round Parser.float + + +percentage = + Parser.map round Parser.float + |. symbol "%" + + +fromHexString : String -> Parser Color +fromHexString hexString = + case String.toList hexString of + [ '#', r, g, b ] -> + fromHex8 ( r, r ) ( g, g ) ( b, b ) ( 'f', 'f' ) + + [ r, g, b ] -> + fromHex8 ( r, r ) ( g, g ) ( b, b ) ( 'f', 'f' ) + + [ '#', r, g, b, a ] -> + fromHex8 ( r, r ) ( g, g ) ( b, b ) ( a, a ) + + [ r, g, b, a ] -> + fromHex8 ( r, r ) ( g, g ) ( b, b ) ( a, a ) + + [ '#', r1, r2, g1, g2, b1, b2 ] -> + fromHex8 ( r1, r2 ) ( g1, g2 ) ( b1, b2 ) ( 'f', 'f' ) + + [ r1, r2, g1, g2, b1, b2 ] -> + fromHex8 ( r1, r2 ) ( g1, g2 ) ( b1, b2 ) ( 'f', 'f' ) + + [ '#', r1, r2, g1, g2, b1, b2, a1, a2 ] -> + fromHex8 ( r1, r2 ) ( g1, g2 ) ( b1, b2 ) ( a1, a2 ) + + [ r1, r2, g1, g2, b1, b2, a1, a2 ] -> + fromHex8 ( r1, r2 ) ( g1, g2 ) ( b1, b2 ) ( a1, a2 ) + + _ -> + Parser.problem "Invalid color" + + +maybeToParser : Maybe a -> Parser a +maybeToParser aMaybe = + case aMaybe of + Just a -> + succeed a + + Nothing -> + Parser.problem "something went wrong" + + +fromHex8 : ( Char, Char ) -> ( Char, Char ) -> ( Char, Char ) -> ( Char, Char ) -> Parser Color +fromHex8 ( r1, r2 ) ( g1, g2 ) ( b1, b2 ) ( a1, a2 ) = + Maybe.map4 + (\r g b a -> + Color + r + g + b + (toFloat a / 255) + ) + (hex2ToInt r1 r2) + (hex2ToInt g1 g2) + (hex2ToInt b1 b2) + (hex2ToInt a1 a2) + |> maybeToParser + + +hex2ToInt : Char -> Char -> Maybe Int +hex2ToInt c1 c2 = + Maybe.map2 (\v1 v2 -> shiftLeftBy 4 v1 + v2) (hexToInt c1) (hexToInt c2) + + +hexToInt : Char -> Maybe Int +hexToInt char = + case Char.toLower char of + '0' -> + Just 0 + + '1' -> + Just 1 + + '2' -> + Just 2 + + '3' -> + Just 3 + + '4' -> + Just 4 + + '5' -> + Just 5 + + '6' -> + Just 6 + + '7' -> + Just 7 + + '8' -> + Just 8 + + '9' -> + Just 9 + + 'a' -> + Just 10 + + 'b' -> + Just 11 + + 'c' -> + Just 12 + + 'd' -> + Just 13 + + 'e' -> + Just 14 + + 'f' -> + Just 15 + + _ -> + Nothing + + +keywords : Parser Color +keywords = + oneOf + [ fromHexString "#000000" |. keyword "black" + , fromHexString "#c0c0c0" |. keyword "silver" + , fromHexString "#808080" |. keyword "gray" + , fromHexString "#ffffff" |. keyword "white" + , fromHexString "#800000" |. keyword "maroon" + , fromHexString "#ff0000" |. keyword "red" + , fromHexString "#800080" |. keyword "purple" + , fromHexString "#ff00ff" |. keyword "fuchsia" + , fromHexString "#008000" |. keyword "green" + , fromHexString "#00ff00" |. keyword "lime" + , fromHexString "#808000" |. keyword "olive" + , fromHexString "#ffff00" |. keyword "yellow" + , fromHexString "#000080" |. keyword "navy" + , fromHexString "#0000ff" |. keyword "blue" + , fromHexString "#008080" |. keyword "teal" + , fromHexString "#00ffff" |. keyword "aqua" + , fromHexString "#ffa500" |. keyword "orange" + , fromHexString "#f0f8ff" |. keyword "aliceblue" + , fromHexString "#faebd7" |. keyword "antiquewhite" + , fromHexString "#7fffd4" |. keyword "aquamarine" + , fromHexString "#f0ffff" |. keyword "azure" + , fromHexString "#f5f5dc" |. keyword "beige" + , fromHexString "#ffe4c4" |. keyword "bisque" + , fromHexString "#ffebcd" |. keyword "blanchedalmond" + , fromHexString "#8a2be2" |. keyword "blueviolet" + , fromHexString "#a52a2a" |. keyword "brown" + , fromHexString "#deb887" |. keyword "burlywood" + , fromHexString "#5f9ea0" |. keyword "cadetblue" + , fromHexString "#7fff00" |. keyword "chartreuse" + , fromHexString "#d2691e" |. keyword "chocolate" + , fromHexString "#ff7f50" |. keyword "coral" + , fromHexString "#6495ed" |. keyword "cornflowerblue" + , fromHexString "#fff8dc" |. keyword "cornsilk" + , fromHexString "#dc143c" |. keyword "crimson" + , fromHexString "#00ffff" |. keyword "cyan" + , fromHexString "#00008b" |. keyword "darkblue" + , fromHexString "#008b8b" |. keyword "darkcyan" + , fromHexString "#b8860b" |. keyword "darkgoldenrod" + , fromHexString "#a9a9a9" |. keyword "darkgray" + , fromHexString "#006400" |. keyword "darkgreen" + , fromHexString "#a9a9a9" |. keyword "darkgrey" + , fromHexString "#bdb76b" |. keyword "darkkhaki" + , fromHexString "#8b008b" |. keyword "darkmagenta" + , fromHexString "#556b2f" |. keyword "darkolivegreen" + , fromHexString "#ff8c00" |. keyword "darkorange" + , fromHexString "#9932cc" |. keyword "darkorchid" + , fromHexString "#8b0000" |. keyword "darkred" + , fromHexString "#e9967a" |. keyword "darksalmon" + , fromHexString "#8fbc8f" |. keyword "darkseagreen" + , fromHexString "#483d8b" |. keyword "darkslateblue" + , fromHexString "#2f4f4f" |. keyword "darkslategray" + , fromHexString "#2f4f4f" |. keyword "darkslategrey" + , fromHexString "#00ced1" |. keyword "darkturquoise" + , fromHexString "#9400d3" |. keyword "darkviolet" + , fromHexString "#ff1493" |. keyword "deeppink" + , fromHexString "#00bfff" |. keyword "deepskyblue" + , fromHexString "#696969" |. keyword "dimgray" + , fromHexString "#696969" |. keyword "dimgrey" + , fromHexString "#1e90ff" |. keyword "dodgerblue" + , fromHexString "#b22222" |. keyword "firebrick" + , fromHexString "#fffaf0" |. keyword "floralwhite" + , fromHexString "#228b22" |. keyword "forestgreen" + , fromHexString "#dcdcdc" |. keyword "gainsboro" + , fromHexString "#f8f8ff" |. keyword "ghostwhite" + , fromHexString "#ffd700" |. keyword "gold" + , fromHexString "#daa520" |. keyword "goldenrod" + , fromHexString "#adff2f" |. keyword "greenyellow" + , fromHexString "#808080" |. keyword "grey" + , fromHexString "#f0fff0" |. keyword "honeydew" + , fromHexString "#ff69b4" |. keyword "hotpink" + , fromHexString "#cd5c5c" |. keyword "indianred" + , fromHexString "#4b0082" |. keyword "indigo" + , fromHexString "#fffff0" |. keyword "ivory" + , fromHexString "#f0e68c" |. keyword "khaki" + , fromHexString "#e6e6fa" |. keyword "lavender" + , fromHexString "#fff0f5" |. keyword "lavenderblush" + , fromHexString "#7cfc00" |. keyword "lawngreen" + , fromHexString "#fffacd" |. keyword "lemonchiffon" + , fromHexString "#add8e6" |. keyword "lightblue" + , fromHexString "#f08080" |. keyword "lightcoral" + , fromHexString "#e0ffff" |. keyword "lightcyan" + , fromHexString "#fafad2" |. keyword "lightgoldenrodyellow" + , fromHexString "#d3d3d3" |. keyword "lightgray" + , fromHexString "#90ee90" |. keyword "lightgreen" + , fromHexString "#d3d3d3" |. keyword "lightgrey" + , fromHexString "#ffb6c1" |. keyword "lightpink" + , fromHexString "#ffa07a" |. keyword "lightsalmon" + , fromHexString "#20b2aa" |. keyword "lightseagreen" + , fromHexString "#87cefa" |. keyword "lightskyblue" + , fromHexString "#778899" |. keyword "lightslategray" + , fromHexString "#778899" |. keyword "lightslategrey" + , fromHexString "#b0c4de" |. keyword "lightsteelblue" + , fromHexString "#ffffe0" |. keyword "lightyellow" + , fromHexString "#32cd32" |. keyword "limegreen" + , fromHexString "#faf0e6" |. keyword "linen" + , fromHexString "#ff00ff" |. keyword "magenta" + , fromHexString "#66cdaa" |. keyword "mediumaquamarine" + , fromHexString "#0000cd" |. keyword "mediumblue" + , fromHexString "#ba55d3" |. keyword "mediumorchid" + , fromHexString "#9370db" |. keyword "mediumpurple" + , fromHexString "#3cb371" |. keyword "mediumseagreen" + , fromHexString "#7b68ee" |. keyword "mediumslateblue" + , fromHexString "#00fa9a" |. keyword "mediumspringgreen" + , fromHexString "#48d1cc" |. keyword "mediumturquoise" + , fromHexString "#c71585" |. keyword "mediumvioletred" + , fromHexString "#191970" |. keyword "midnightblue" + , fromHexString "#f5fffa" |. keyword "mintcream" + , fromHexString "#ffe4e1" |. keyword "mistyrose" + , fromHexString "#ffe4b5" |. keyword "moccasin" + , fromHexString "#ffdead" |. keyword "navajowhite" + , fromHexString "#fdf5e6" |. keyword "oldlace" + , fromHexString "#6b8e23" |. keyword "olivedrab" + , fromHexString "#ff4500" |. keyword "orangered" + , fromHexString "#da70d6" |. keyword "orchid" + , fromHexString "#eee8aa" |. keyword "palegoldenrod" + , fromHexString "#98fb98" |. keyword "palegreen" + , fromHexString "#afeeee" |. keyword "paleturquoise" + , fromHexString "#db7093" |. keyword "palevioletred" + , fromHexString "#ffefd5" |. keyword "papayawhip" + , fromHexString "#ffdab9" |. keyword "peachpuff" + , fromHexString "#cd853f" |. keyword "peru" + , fromHexString "#ffc0cb" |. keyword "pink" + , fromHexString "#dda0dd" |. keyword "plum" + , fromHexString "#b0e0e6" |. keyword "powderblue" + , fromHexString "#bc8f8f" |. keyword "rosybrown" + , fromHexString "#4169e1" |. keyword "royalblue" + , fromHexString "#8b4513" |. keyword "saddlebrown" + , fromHexString "#fa8072" |. keyword "salmon" + , fromHexString "#f4a460" |. keyword "sandybrown" + , fromHexString "#2e8b57" |. keyword "seagreen" + , fromHexString "#fff5ee" |. keyword "seashell" + , fromHexString "#a0522d" |. keyword "sienna" + , fromHexString "#87ceeb" |. keyword "skyblue" + , fromHexString "#6a5acd" |. keyword "slateblue" + , fromHexString "#708090" |. keyword "slategray" + , fromHexString "#708090" |. keyword "slategrey" + , fromHexString "#fffafa" |. keyword "snow" + , fromHexString "#00ff7f" |. keyword "springgreen" + , fromHexString "#4682b4" |. keyword "steelblue" + , fromHexString "#d2b48c" |. keyword "tan" + , fromHexString "#d8bfd8" |. keyword "thistle" + , fromHexString "#ff6347" |. keyword "tomato" + , fromHexString "#40e0d0" |. keyword "turquoise" + , fromHexString "#ee82ee" |. keyword "violet" + , fromHexString "#f5deb3" |. keyword "wheat" + , fromHexString "#f5f5f5" |. keyword "whitesmoke" + , fromHexString "#9acd32" |. keyword "yellowgreen" + , fromHexString "#663399" |. keyword "rebeccapurple" + , succeed (Color 0 0 0 0) |. keyword "transparent" + ] + + +parse : String -> Result String Color +parse string = + Parser.run parser string |> Result.mapError Parser.deadEndsToString 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 []) diff --git a/style-generator/src/Main.elm b/style-generator/src/Main.elm new file mode 100644 index 0000000..e46254e --- /dev/null +++ b/style-generator/src/Main.elm @@ -0,0 +1,138 @@ +module Main exposing (main) + +import Browser +import Decoder +import Html exposing (div, input, label, p, pre, text) +import Html.Attributes exposing (style, type_, value) +import Html.Events exposing (onClick, onInput) +import Http +import Json.Decode + + +main = + Browser.document + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + + +init () = + ( { styleUrl = "" + , token = "" + , style = Nothing + , error = Nothing + } + , Cmd.none + ) + + +type Msg + = LoadedStyle (Result Http.Error String) + | LoadStyle + | StyleURLChanged String + | TokenChanged String + + +update msg model = + case msg of + LoadedStyle (Ok style) -> + ( { model | style = Just style }, Cmd.none ) + + LoadedStyle (Err e) -> + ( { model | error = Just (errorToString e) }, Cmd.none ) + + LoadStyle -> + ( model, fetchStyle model.styleUrl model.token ) + + StyleURLChanged s -> + ( { model | styleUrl = s }, Cmd.none ) + + TokenChanged s -> + ( { model | token = s }, Cmd.none ) + + +subscriptions model = + Sub.none + + +fetchStyle styleUrl token = + String.replace "mapbox://styles/" "https://api.mapbox.com/styles/v1/" styleUrl + ++ "?access_token=" + ++ token + |> Http.getString + |> Http.send LoadedStyle + + +form model = + div [] + [ div [] + [ label [] [ text "Style URL:" ] + , input [ type_ "text", value model.styleUrl, onInput StyleURLChanged ] [] + ] + , div [] + [ label [] [ text "Token:" ] + , input [ type_ "text", value model.token, onInput TokenChanged ] [] + ] + , div [] [ input [ type_ "submit", value "Fetch", onClick LoadStyle ] [] ] + ] + + +errorToString : Http.Error -> String +errorToString err = + case err of + Http.BadUrl stringString -> + "Invalid URL. Check the inputs to make sure that it is a valid https url or starts with mapbox://styles/" + + Http.Timeout -> + "Request timed out. Try again later." + + Http.NetworkError -> + "Network error. Are you online?" + + Http.BadStatus response -> + case response.status.code of + 401 -> + "An authentication error occurred. Check your key and try again." + + 404 -> + "Couldn't find that style" + + _ -> + response.status.message + + Http.BadPayload m _ -> + m + + +resultToString r = + case r of + Ok s -> + s + + Err s -> + s + + +view model = + { title = "Style Generator" + , body = + [ form model + , case ( model.error, model.style ) of + ( Just err, _ ) -> + p [ style "color" "red" ] [ text err ] + + ( Nothing, Just styl ) -> + pre + [] + [ Json.Decode.decodeString Decoder.styleCode styl + |> Result.mapError Json.Decode.errorToString + |> resultToString + |> text + ] + + ( Nothing, Nothing ) -> + p [] [ text "This is a tool that helps you generate elm-mapbox styles from Mapbox Studio. In Studio, hit the share button. This will give you the above two pieces of information. Then hit fetch. This tool will attempt to generate an elm-mapbox style for you. It is not perfect, but should give a nice head-start. Run the output through elm-format, than fix any compiler warnings. Then fix any Debug.todo calls." ] + ] + } diff --git a/style-generator/src/Writer.elm b/style-generator/src/Writer.elm new file mode 100644 index 0000000..ad9f3fd --- /dev/null +++ b/style-generator/src/Writer.elm @@ -0,0 +1,640 @@ +module Writer exposing (write, writeDeclaration, writeExpression, writeFile, writePattern, writeTypeAnnotation) + +{-| Copied and tweaked from Elm Syntax. + + +# Elm.Writer + +Write a file to a string. +@docs write, writeFile, writePattern, writeExpression, writeTypeAnnotation, writeDeclaration + +-} + +import Elm.Syntax.Declaration exposing (..) +import Elm.Syntax.Documentation exposing (..) +import Elm.Syntax.Exposing as Exposing exposing (..) +import Elm.Syntax.Expression exposing (..) +import Elm.Syntax.File exposing (..) +import Elm.Syntax.Import exposing (Import) +import Elm.Syntax.Infix exposing (..) +import Elm.Syntax.Module exposing (..) +import Elm.Syntax.ModuleName exposing (..) +import Elm.Syntax.Node as Node exposing (Node(..)) +import Elm.Syntax.Pattern exposing (..) +import Elm.Syntax.Range exposing (Range) +import Elm.Syntax.Signature exposing (Signature) +import Elm.Syntax.Type exposing (..) +import Elm.Syntax.TypeAlias exposing (..) +import Elm.Syntax.TypeAnnotation exposing (..) +import List.Extra as List +import StructuredWriter as Writer exposing (..) + + +{-| Transform a writer to a string +-} +write : Writer -> String +write = + Writer.write + + +{-| Write a file +-} +writeFile : File -> Writer +writeFile file = + breaked + [ writeModule <| Node.value file.moduleDefinition + , breaked (List.map (Node.value >> writeImport) file.imports) + , breaked (List.map writeDeclaration file.declarations) + ] + + +writeModule : Module -> Writer +writeModule m = + case m of + NormalModule defaultModuleData -> + writeDefaultModuleData defaultModuleData + + PortModule defaultModuleData -> + spaced + [ string "port" + , writeDefaultModuleData defaultModuleData + ] + + EffectModule effectModuleData -> + writeEffectModuleData effectModuleData + + +writeDefaultModuleData : DefaultModuleData -> Writer +writeDefaultModuleData { moduleName, exposingList } = + spaced + [ string "module" + , writeModuleName <| Node.value moduleName + , writeExposureExpose <| Node.value exposingList + ] + + +writeEffectModuleData : EffectModuleData -> Writer +writeEffectModuleData { moduleName, exposingList, command, subscription } = + spaced + [ string "effect" + , string "module" + , writeModuleName <| Node.value moduleName + , writeWhere ( command, subscription ) + , writeExposureExpose <| Node.value exposingList + ] + + +writeWhere : ( Maybe (Node String), Maybe (Node String) ) -> Writer +writeWhere input = + case input of + ( Nothing, Nothing ) -> + epsilon + + ( Just x, Nothing ) -> + spaced + [ string "where { command =" + , string <| Node.value x + , string "}" + ] + + ( Nothing, Just x ) -> + spaced + [ string "where { subscription =" + , string <| Node.value x + , string "}" + ] + + ( Just x, Just y ) -> + spaced + [ string "where { command =" + , string <| Node.value x + , string ", subscription =" + , string <| Node.value y + , string "}" + ] + + +writeModuleName : ModuleName -> Writer +writeModuleName moduleName = + string (String.join "." moduleName) + + +writeExposureExpose : Exposing -> Writer +writeExposureExpose x = + case x of + All _ -> + string "exposing (..)" + + Explicit exposeList -> + let + diffLines = + List.map Node.range exposeList + |> startOnDifferentLines + in + spaced + [ string "exposing" + , parensComma diffLines (List.map writeExpose exposeList) + ] + + +writeExpose : Node TopLevelExpose -> Writer +writeExpose (Node _ exp) = + case exp of + InfixExpose x -> + string ("(" ++ x ++ ")") + + FunctionExpose f -> + string f + + TypeOrAliasExpose t -> + string t + + TypeExpose { name, open } -> + case open of + Just _ -> + spaced + [ string name + , string "(..)" + ] + + Nothing -> + string name + + +startOnDifferentLines : List Range -> Bool +startOnDifferentLines xs = + List.length (List.unique (List.map (.start >> .row) xs)) > 1 + + +writeImport : Import -> Writer +writeImport { moduleName, moduleAlias, exposingList } = + spaced + [ string "import" + , writeModuleName <| Node.value moduleName + , maybe (Maybe.map (Node.value >> writeModuleName >> (\x -> spaced [ string "as", x ])) moduleAlias) + , maybe (Maybe.map writeExposureExpose exposingList) + ] + + +writeLetDeclaration : Node LetDeclaration -> Writer +writeLetDeclaration (Node _ letDeclaration) = + case letDeclaration of + LetFunction function -> + writeFunction function + + LetDestructuring pattern expression -> + writeDestructuring pattern expression + + +{-| Write a declaration +-} +writeDeclaration : Node Declaration -> Writer +writeDeclaration (Node _ decl) = + case decl of + FunctionDeclaration function -> + writeFunction function + + AliasDeclaration typeAlias -> + writeTypeAlias typeAlias + + CustomTypeDeclaration type_ -> + writeType type_ + + PortDeclaration p -> + writePortDeclaration p + + InfixDeclaration i -> + writeInfix i + + Destructuring pattern expression -> + writeDestructuring pattern expression + + +writeFunction : Function -> Writer +writeFunction { documentation, signature, declaration } = + breaked + [ maybe (Maybe.map writeDocumentation documentation) + , maybe (Maybe.map (Node.value >> writeSignature) signature) + , writeFunctionImplementation <| Node.value declaration + ] + + +writeFunctionImplementation : FunctionImplementation -> Writer +writeFunctionImplementation declaration = + breaked + [ spaced + [ string <| Node.value declaration.name + , spaced (List.map writePattern declaration.arguments) + , string "=" + ] + , indent 4 (writeExpression declaration.expression) + ] + + +writeSignature : Signature -> Writer +writeSignature signature = + spaced + [ string <| Node.value signature.name + , string ":" + , writeTypeAnnotation signature.typeAnnotation + ] + + +writeDocumentation : Node Documentation -> Writer +writeDocumentation = + Node.value >> string + + +writeTypeAlias : TypeAlias -> Writer +writeTypeAlias typeAlias = + breaked + [ spaced + [ string "type alias" + , string <| Node.value typeAlias.name + , spaced (List.map (Node.value >> string) typeAlias.generics) + , string "=" + ] + , indent 4 (writeTypeAnnotation typeAlias.typeAnnotation) + ] + + +writeType : Type -> Writer +writeType type_ = + breaked + [ spaced + [ string "type" + , string <| Node.value type_.name + , spaced (List.map (Node.value >> string) type_.generics) + ] + , let + diffLines = + List.map Node.range type_.constructors + |> startOnDifferentLines + in + sepBy ( "=", "|", "" ) + diffLines + (List.map (Node.value >> writeValueConstructor) type_.constructors) + ] + + +writeValueConstructor : ValueConstructor -> Writer +writeValueConstructor { name, arguments } = + spaced + [ string <| Node.value name + , spaced (List.map writeTypeAnnotation arguments) + ] + + +writePortDeclaration : Signature -> Writer +writePortDeclaration signature = + spaced [ string "port", writeSignature signature ] + + +writeInfix : Infix -> Writer +writeInfix { direction, precedence, operator, function } = + spaced + [ string "infix" + , case Node.value direction of + Left -> + string "left" + + Right -> + string "right" + + Non -> + string "non" + , string (String.fromInt (Node.value precedence)) + , string (Node.value operator) + , string "=" + , string (Node.value function) + ] + + +writeDestructuring : Node Pattern -> Node Expression -> Writer +writeDestructuring pattern expression = + breaked + [ spaced [ writePattern pattern, string "=" ] + , indent 4 (writeExpression expression) + ] + + +{-| Write a type annotation +-} +writeTypeAnnotation : Node TypeAnnotation -> Writer +writeTypeAnnotation (Node _ typeAnnotation) = + case typeAnnotation of + GenericType s -> + string s + + Typed moduleNameAndName args -> + let + moduleName = + Node.value moduleNameAndName |> Tuple.first + + k = + Node.value moduleNameAndName |> Tuple.second + in + spaced + ((string <| String.join "." (moduleName ++ [ k ])) + :: List.map (writeTypeAnnotation >> parensIfContainsSpaces) args + ) + + Unit -> + string "()" + + Tupled xs -> + parensComma False (List.map writeTypeAnnotation xs) + + Record xs -> + bracesComma False (List.map writeRecordField xs) + + GenericRecord name fields -> + spaced + [ string "{" + , string <| Node.value name + , string "|" + , sepByComma False (List.map writeRecordField <| Node.value fields) + , string "}" + ] + + FunctionTypeAnnotation left right -> + let + addParensForSubTypeAnnotation type_ = + case type_ of + Node _ (FunctionTypeAnnotation _ _) -> + join [ string "(", writeTypeAnnotation type_, string ")" ] + + _ -> + writeTypeAnnotation type_ + in + spaced + [ addParensForSubTypeAnnotation left + , string "->" + , addParensForSubTypeAnnotation right + ] + + +writeRecordField : Node RecordField -> Writer +writeRecordField (Node _ ( name, ref )) = + spaced + [ string <| Node.value name + , string ":" + , writeTypeAnnotation ref + ] + + +{-| Writer an expression +-} +writeExpression : Node Expression -> Writer +writeExpression (Node range inner) = + let + recurRangeHelper (Node x y) = + ( x, writeExpression (Node x y) ) + + writeRecordSetter : RecordSetter -> ( Range, Writer ) + writeRecordSetter ( name, expr ) = + ( Node.range expr + , spaced [ string <| Node.value name, string "=", writeExpression expr ] + ) + + sepHelper : (Bool -> List Writer -> Writer) -> List ( Range, Writer ) -> Writer + sepHelper f l = + let + diffLines = + List.map Tuple.first l + |> startOnDifferentLines + in + f diffLines (List.map Tuple.second l) + + fakeSepHelper : (Bool -> List Writer -> Writer) -> List ( Range, Writer ) -> Writer + fakeSepHelper f l = + f True (List.map Tuple.second l) + in + case inner of + UnitExpr -> + string "()" + + Application xs -> + case xs of + [] -> + epsilon + + [ x ] -> + writeExpression x + + x :: rest -> + spaced + [ writeExpression x + , sepHelper sepBySpace (List.map recurRangeHelper rest) + ] + + OperatorApplication x dir left right -> + case dir of + Left -> + sepHelper sepBySpace + [ ( Node.range left, writeExpression left ) + , ( range, spaced [ string x, writeExpression right ] ) + ] + + Right -> + sepHelper sepBySpace + [ ( Node.range left, spaced [ writeExpression left, string x ] ) + , ( Node.range right, writeExpression right ) + ] + + Non -> + sepHelper sepBySpace + [ ( Node.range left, spaced [ writeExpression left, string x ] ) + , ( Node.range right, writeExpression right ) + ] + + FunctionOrValue moduleName name -> + case moduleName of + [] -> + string name + + _ -> + join + [ writeModuleName <| moduleName + , string "." + , string <| name + ] + + IfBlock condition thenCase elseCase -> + breaked + [ spaced [ string "if", writeExpression condition, string "then" ] + , indent 2 (writeExpression thenCase) + , string "else" + , indent 2 (writeExpression elseCase) + ] + + PrefixOperator x -> + string ("(" ++ x ++ ")") + + Operator x -> + string x + + Hex h -> + string "TODO" + + Integer i -> + string (String.fromInt i) + + Floatable f -> + string (String.fromFloat f) + + Negation x -> + append (string "-") (writeExpression x) + + Literal s -> + string ("\"" ++ s ++ "\"") + + CharLiteral c -> + string ("'" ++ String.fromList [ c ] ++ "'") + + TupledExpression t -> + sepHelper sepByComma (List.map recurRangeHelper t) + + ParenthesizedExpression x -> + join [ string "(", writeExpression x, string ")" ] + + LetExpression letBlock -> + breaked + [ string "let" + , indent 2 (breaked (List.map writeLetDeclaration letBlock.declarations)) + , string "in" + , indent 2 (writeExpression letBlock.expression) + ] + + CaseExpression caseBlock -> + let + writeCaseBranch ( pattern, expression ) = + indent 2 <| + breaked + [ spaced [ writePattern pattern, string "->" ] + , indent 2 (writeExpression expression) + ] + in + breaked + [ spaced [ string "case", writeExpression caseBlock.expression, string "of" ] + , breaked (List.map writeCaseBranch caseBlock.cases) + ] + + LambdaExpression lambda -> + spaced + [ join + [ string "\\" + , spaced (List.map writePattern lambda.args) + ] + , string "->" + , writeExpression lambda.expression + ] + + RecordExpr setters -> + --sepHelper bracesComma (List.map (Node.value >> writeRecordSetter) setters) + bracesComma True (List.map (Node.value >> (\( name, expr ) -> spaced [ string <| Node.value name, string "=", writeExpression expr ])) setters) + + ListExpr xs -> + fakeSepHelper bracketsComma (List.map recurRangeHelper xs) + + RecordAccess expression accessor -> + join [ writeExpression expression, string ".", string <| Node.value accessor ] + + RecordAccessFunction s -> + join [ string ".", string s ] + + RecordUpdateExpression name updates -> + spaced + [ string "{" + , string <| Node.value name + , string "|" + , sepHelper sepByComma (List.map (Node.value >> writeRecordSetter) updates) + , string "}" + ] + + GLSLExpression s -> + join + [ string "[glsl|" + , string s + , string "|]" + ] + + +{-| Write a pattern +-} +writePattern : Node Pattern -> Writer +writePattern (Node _ p) = + case p of + AllPattern -> + string "_" + + UnitPattern -> + string "()" + + CharPattern c -> + string ("'" ++ String.fromList [ c ] ++ "'") + + StringPattern s -> + string s + + HexPattern h -> + string "TODO" + + IntPattern i -> + string (String.fromInt i) + + FloatPattern f -> + string (String.fromFloat f) + + TuplePattern inner -> + parensComma False (List.map writePattern inner) + + RecordPattern inner -> + bracesComma False (List.map (Node.value >> string) inner) + + UnConsPattern left right -> + spaced [ writePattern left, string "::", writePattern right ] + + ListPattern inner -> + bracketsComma False (List.map writePattern inner) + + VarPattern var -> + string var + + NamedPattern qnr others -> + spaced + [ writeQualifiedNameRef qnr + , spaced (List.map writePattern others) + ] + + AsPattern innerPattern asName -> + spaced [ writePattern innerPattern, string "as", string <| Node.value asName ] + + ParenthesizedPattern innerPattern -> + spaced [ string "(", writePattern innerPattern, string ")" ] + + +writeQualifiedNameRef : QualifiedNameRef -> Writer +writeQualifiedNameRef { moduleName, name } = + case moduleName of + [] -> + string name + + _ -> + join + [ writeModuleName moduleName + , string "." + , string name + ] + + + +-- Helpers + + +parensIfContainsSpaces : Writer -> Writer +parensIfContainsSpaces w = + if Writer.write w |> String.contains " " then + join [ string "(", w, string ")" ] + else + w -- cgit v1.2.3