From 6bd5f8ccbd8c44c3311ef36b0e2de9ede4fa71ed Mon Sep 17 00:00:00 2001 From: Jakub Hampl Date: Thu, 14 Feb 2019 15:23:49 +0000 Subject: New Style Generator (#8) --- style-generator/src/Color.elm | 104 ++++- style-generator/src/Decoder.elm | 707 ++++------------------------- style-generator/src/Decoder/Expression.elm | 345 ++++++++++++++ style-generator/src/Decoder/Generic.elm | 52 +++ style-generator/src/Decoder/Helpers.elm | 9 + style-generator/src/Decoder/Legacy.elm | 110 +++++ style-generator/src/Lib.elm | 101 +++++ style-generator/src/Main.elm | 209 +++++++-- style-generator/src/MyElm/Advanced.elm | 46 ++ style-generator/src/MyElm/Stringify.elm | 282 ++++++++++++ style-generator/src/MyElm/Syntax.elm | 678 +++++++++++++++++++++++++++ style-generator/src/MyElm/Types.elm | 56 +++ style-generator/src/Writer.elm | 640 -------------------------- 13 files changed, 2039 insertions(+), 1300 deletions(-) create mode 100644 style-generator/src/Decoder/Expression.elm create mode 100644 style-generator/src/Decoder/Generic.elm create mode 100644 style-generator/src/Decoder/Helpers.elm create mode 100644 style-generator/src/Decoder/Legacy.elm create mode 100644 style-generator/src/Lib.elm create mode 100644 style-generator/src/MyElm/Advanced.elm create mode 100644 style-generator/src/MyElm/Stringify.elm create mode 100644 style-generator/src/MyElm/Syntax.elm create mode 100644 style-generator/src/MyElm/Types.elm delete mode 100644 style-generator/src/Writer.elm (limited to 'style-generator/src') diff --git a/style-generator/src/Color.elm b/style-generator/src/Color.elm index b4e8b73..b1c0f59 100644 --- a/style-generator/src/Color.elm +++ b/style-generator/src/Color.elm @@ -13,13 +13,111 @@ parser = oneOf [ keywords , hsla - - -- , rgba - -- , hex + , rgba + , hex ] |. end +hexNumber = + Parser.number + { int = Nothing + , hex = Just identity + , octal = Nothing + , binary = Nothing + , float = Nothing + } + + +hexDigit : Parser Int +hexDigit = + oneOf + [ succeed 0 |. symbol "0" + , succeed 1 |. symbol "1" + , succeed 2 |. symbol "2" + , succeed 3 |. symbol "3" + , succeed 4 |. symbol "4" + , succeed 5 |. symbol "5" + , succeed 6 |. symbol "6" + , succeed 7 |. symbol "7" + , succeed 8 |. symbol "8" + , succeed 9 |. symbol "9" + , succeed 10 |. symbol "A" + , succeed 11 |. symbol "B" + , succeed 12 |. symbol "C" + , succeed 13 |. symbol "D" + , succeed 14 |. symbol "E" + , succeed 15 |. symbol "F" + , succeed 10 |. symbol "a" + , succeed 11 |. symbol "b" + , succeed 12 |. symbol "c" + , succeed 13 |. symbol "d" + , succeed 14 |. symbol "e" + , succeed 15 |. symbol "f" + ] + + +twoDigits : Int -> Int -> Int +twoDigits a b = + Bitwise.shiftLeftBy 4 a + b + + +hex : Parser Color +hex = + succeed + (\a b c maybe -> + case maybe of + Just ( d, e, f ) -> + { r = twoDigits a b + , g = twoDigits c d + , b = twoDigits e f + , a = 1 + } + + Nothing -> + { r = twoDigits a a + , g = twoDigits b b + , b = twoDigits c c + , a = 1 + } + ) + |. symbol "#" + |= hexDigit + |= hexDigit + |= hexDigit + |= oneOf + [ succeed (\a b c -> Just ( a, b, c )) + |= hexDigit + |= hexDigit + |= hexDigit + , succeed Nothing + ] + + +rgba : Parser Color +rgba = + succeed Color + |. oneOf [ keyword "rgba", keyword "rgb" ] + |. symbol "(" + |= Parser.int + |. spaces + |. symbol "," + |. spaces + |= Parser.int + |. spaces + |. symbol "," + |. spaces + |= Parser.int + |= oneOf + [ succeed identity + |. symbol "," + |. spaces + |= Parser.float + , succeed 1 + ] + |. symbol ")" + + fromHSLA hue sat light alpha = let ( h, s, l ) = diff --git a/style-generator/src/Decoder.elm b/style-generator/src/Decoder.elm index 65dc0a2..5acb722 100644 --- a/style-generator/src/Decoder.elm +++ b/style-generator/src/Decoder.elm @@ -1,104 +1,74 @@ 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 Decoder.Expression as Decode +import Decoder.Generic as Decode +import Decoder.Helpers exposing (todo) +import Decoder.Legacy import Json.Decode as D exposing (Decoder) -import Json.Encode +import Lib +import MyElm.Advanced as Advanced +import MyElm.Syntax exposing (..) import String.Case exposing (toCamelCaseLower) -import Writer -node = - Node emptyRange +styleNs = + [ "Mapbox", "Style" ] -wrapNodes = - List.map node +layerNs = + [ "Mapbox", "Layer" ] + + +sourceNs = + [ "Mapbox", "Source" ] + + +styleName nm = + Advanced.aliasedName + { modulePath = styleNs + , aliasName = + "Style" + , name = nm + , typeName = Nothing + } + + +layerName nm = + Advanced.aliasedName + { modulePath = layerNs + , aliasName = + "Layer" + , name = nm + , typeName = Nothing + } styleCode : Decoder String styleCode = - D.map (file >> Writer.writeFile >> Writer.write) style + D.map file 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 - ] - } - } - ] + [ variable "style" (type0 (typeName styleNs "Style")) (call1 (constructorName [ "Mapbox", "Style" ] "Style" "Style") (record 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)) + build + { name = [ "Style" ] + , exposes = [ exposeFn "style" ] + , doc = Nothing + , declarations = declarations styleDec + } + + 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 ) + [ ( "transition", transition ) + , ( "light", light ) + , ( "layers", layers ) + , ( "sources", sources ) + , ( "misc", misc ) ] ) (D.oneOf @@ -116,48 +86,38 @@ style = decodeMisc -decodeTransition : Decoder (Node Expression) decodeTransition = D.map2 (\duration delay -> - node - (RecordExpr - [ node ( node "duration", node (Integer duration) ) - , node ( node "delay", node (Integer delay) ) - ] - ) + record + [ ( "duration", int duration ) + , ( "delay", int 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))) + |> D.map list 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 + D.map3 (\id source attrs -> call3 (layerName t) (string id) (string 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 + D.map2 (\id attrs -> call2 (layerName "background") (string id) (list attrs)) (D.field "id" D.string) decodeAttrs "fill" -> layerDecodeHelp "fill" @@ -188,9 +148,8 @@ decodeLayer = ) -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.map3 (\top paint layout -> top ++ paint ++ layout) (D.keyValuePairs D.value) (Decode.withDefault [] (D.field "paint" (D.keyValuePairs D.value))) (Decode.withDefault [] (D.field "layout" (D.keyValuePairs D.value))) |> D.andThen (List.filterMap (\( attrName, attrValue ) -> @@ -210,8 +169,11 @@ decodeAttrs = "layout" -> Nothing + "metadata" -> + Nothing + "source-layer" -> - decodeAttr "sourceLayer" (D.map str D.string) attrValue + decodeAttr "sourceLayer" (D.map string D.string) attrValue "minzoom" -> decodeAttr "minzoom" (D.map float D.float) attrValue @@ -220,472 +182,29 @@ decodeAttrs = decodeAttr "maxzoom" (D.map float D.float) attrValue "filter" -> - decodeAttr "filter" (D.oneOf [ decodeLegacyFilter, decodeValue ]) attrValue + decodeAttr "filter" (D.oneOf [ Decoder.Legacy.filter, Decode.expression ]) attrValue other -> - decodeAttr (toCamelCaseLower attrName) decodeValue attrValue + decodeAttr (toCamelCaseLower attrName) Decode.expression attrValue ) - >> combine + >> Decode.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 ]) + |> Decode.resultToDecoder + |> D.map (call1 (layerName (toCamelCaseLower attrName))) ) -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)) + |> D.map list -decodeSource : Decoder (String -> Node Expression) decodeSource = D.field "type" D.string |> D.andThen @@ -696,81 +215,45 @@ decodeSource = |> D.map (\url -> \id -> - call "Source" - "vectorFromUrl" - [ str id - , str url - ] + call2 (Advanced.aliasedName { modulePath = sourceNs, aliasName = "Source", name = "vectorFromUrl", typeName = Nothing }) + (string id) + (string url) ) + "raster" -> + D.map + (\url -> + \id -> + call2 (Advanced.aliasedName { modulePath = sourceNs, aliasName = "Source", name = "rasterFromUrl", typeName = Nothing }) + (string id) + (string url) + ) + (D.field "url" D.string) + _ -> - D.succeed (\a -> todoExpr ("type " ++ t ++ "not yet supported")) + D.succeed (\a -> Lib.todo ("type " ++ t ++ " not yet supported")) ) -decodeMisc : Decoder (Node Expression) decodeMisc = - D.succeed (node (ListExpr [])) - - -list l = - node (ListExpr l) - + D.map6 (\sprite glyphs name zoom bearing pitch -> [ sprite, glyphs, name, zoom, bearing, pitch ] |> List.filterMap identity |> list) + (miscField "sprite" "sprite" D.string string) + (miscField "glyphs" "glyphs" D.string string) + (miscField "name" "name" D.string string) + (miscField "zoom" "defaultZoomLevel" D.float float) + (miscField "bearing" "defaultBearing" D.float float) + (miscField "pitch" "defaultPitch" D.float float) -str s = - node (Literal s) +miscField : String -> String -> Decoder a -> (a -> Expression) -> Decoder (Maybe Expression) +miscField name elmName decoder toExpr = + D.maybe (D.field name (D.map (\item -> call1 (styleName elmName) (toExpr item)) decoder)) -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 +-- (D.field "center" D.maybe (D.map (\sprite -> call1 (styleName "defaultCenter") (str sprite) )) D.string) +-- 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 []) + D.succeed (call0 (Advanced.aliasedName { modulePath = [ "Mapbox", ns ], aliasName = ns, name = name, typeName = Nothing })) diff --git a/style-generator/src/Decoder/Expression.elm b/style-generator/src/Decoder/Expression.elm new file mode 100644 index 0000000..137ab26 --- /dev/null +++ b/style-generator/src/Decoder/Expression.elm @@ -0,0 +1,345 @@ +module Decoder.Expression exposing (decodeBool, expression) + +import Color +import Decoder.Generic as Decode +import Decoder.Helpers exposing (todo) +import Json.Decode as D exposing (Decoder) +import Lib +import MyElm.Syntax exposing (Expression, call1, calln, float, int, list, pair, string) +import String.Case exposing (toCamelCaseLower) + + +expression = + D.oneOf + [ D.string |> D.map makeConstant + , decodeBool + , D.float |> D.map (float >> Lib.float) + , D.int |> D.map (int >> Lib.int) + , D.index 0 D.string |> D.andThen decodeExpression + , D.index 0 D.int |> D.andThen (always (D.map (List.map int >> list >> Lib.floats) (D.list D.int))) + , D.index 0 D.float |> D.andThen (always (D.map (List.map float >> list >> Lib.floats) (D.list D.float))) + , todo + ] + + +decodeLiteral = + D.oneOf + [ D.string |> D.map makeConstant + , decodeBool + , D.float |> D.map (float >> Lib.float) + , D.int |> D.map (int >> Lib.int) + , todo + ] + + +makeConstant s = + case s of + "map" -> + Lib.eValue "anchorMap" + + "viewport" -> + Lib.eValue "anchorViewport" + + "auto" -> + Lib.eValue "anchorAuto" + + "center" -> + Lib.eValue "positionCenter" + + "left" -> + Lib.eValue "positionLeft" + + "right" -> + Lib.eValue "positionRight" + + "top" -> + Lib.eValue "positionTop" + + "bottom" -> + Lib.eValue "positionBottom" + + "topRight" -> + Lib.eValue "positionTopRight" + + "topLeft" -> + Lib.eValue "positionTopLeft" + + "bottomLeft" -> + Lib.eValue "positionBottomLeft" + + "bottomRight" -> + Lib.eValue "positionBottomRight" + + "none" -> + Lib.eValue "textFitNone" + + "width" -> + Lib.eValue "textFitWidth" + + "height" -> + Lib.eValue "textFitHeight" + + "both" -> + Lib.eValue "textFitBoth" + + "butt" -> + Lib.eValue "lineCapButt" + + "round" -> + Lib.eValue "lineCapRound" + + "square" -> + Lib.eValue "lineCapSquare" + + "bevel" -> + Lib.eValue "lineJoinBevel" + + "miter" -> + Lib.eValue "lineJoinMiter" + + "point" -> + Lib.eValue "symbolPlacementPoint" + + "line-center" -> + Lib.eValue "symbolPlacementLineCenter" + + "line" -> + Lib.eValue "symbolPlacementLine" + + "uppercase" -> + Lib.eValue "textTransformUppercase" + + "lowercase" -> + Lib.eValue "textTransformLowercase" + + "linear" -> + Lib.eValue "rasterResamplingLinear" + + "nearest" -> + Lib.eValue "rasterResamplingNearest" + + _ -> + case Color.parse s of + Ok { r, g, b, a } -> + calln (Lib.eName "rgba") [ int r, int g, int b, float a ] + + Err err -> + string s |> Lib.str + + +decodeExpression funName = + case funName of + "literal" -> + D.index 1 + (D.oneOf + [ D.list D.string |> D.map (\strs -> calln (Lib.eName "strings") [ list (List.map string strs) ]) + , D.list D.float |> D.map (\floats -> calln (Lib.eName "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) + , D.index 2 (D.list D.string) |> D.andThen (decodeMatch True) + , D.index 2 (D.list D.float) |> D.andThen (decodeMatch False) + ] + + "exponential" -> + D.map (\base -> calln (Lib.eName "Exponential") [ float base ]) (D.index 1 D.float) + + "interpolate" -> + D.map3 + (\interpolation options input -> + Lib.pipelineCall "interpolate" (input :: interpolation :: options) + ) + (D.index 1 expression) + (Decode.tail D.value |> D.map (List.drop 2) |> D.andThen (organizeArgs (D.map float D.float) [])) + (D.index 2 expression) + + "step" -> + D.map3 + (\inp def stps -> + Lib.pipelineCall "step" (inp :: def :: stps) + ) + (D.index 1 expression) + (D.index 2 expression) + (Decode.tail D.value |> D.map (List.drop 2) |> D.andThen (organizeArgs (D.map float D.float) [])) + + "case" -> + D.map (calln (Lib.eName "conditionally")) + (Decode.tail D.value |> D.andThen (organizeArgs expression [])) + + _ -> + let + fallback = + Decode.tail expression + |> D.map + (\arguments -> + case funName of + "==" -> + Lib.pipelineCall "isEqual" arguments + + "!=" -> + Lib.pipelineCall "notEqual" arguments + + "!has" -> + Lib.todo "!has is not supported" + + "!in" -> + Lib.todo "!in is not supported" + + "in" -> + Lib.todo "in is not supported" + + ">=" -> + Lib.pipelineCall "greaterThanOrEqual" arguments + + ">" -> + Lib.pipelineCall "greaterThan" arguments + + "<=" -> + Lib.pipelineCall "lessThanOrEqual" arguments + + "<" -> + Lib.pipelineCall "lessThan" arguments + + "concat" -> + Lib.pipelineMultiCall "append" arguments + + "linear" -> + calln (Lib.eName "Linear") arguments + + "rgb" -> + calln (Lib.eName "makeRGBColor") arguments + + "rgba" -> + calln (Lib.eName "makeRGBAColor") arguments + + "to-rgba" -> + calln (Lib.eName "rgbaChannels") arguments + + "-" -> + Lib.pipelineMultiCall "minus" arguments + + "*" -> + Lib.pipelineMultiCall "multiply" arguments + + "+" -> + Lib.pipelineMultiCall "plus" arguments + + "/" -> + Lib.pipelineMultiCall "divideBy" arguments + + "%" -> + Lib.pipelineMultiCall "modBy" arguments + + "^" -> + Lib.pipelineMultiCall "raiseBy" arguments + + "get" -> + if List.length arguments == 1 then + calln (Lib.eName "getProperty") arguments + + else + calln (Lib.eName "get") arguments + + "all" -> + call1 (Lib.eName "all") (MyElm.Syntax.list arguments) + + "any" -> + call1 (Lib.eName "any") (MyElm.Syntax.list arguments) + + _ -> + calln (Lib.eName (toCamelCaseLower funName)) arguments + ) + in + if String.toLower funName /= funName then + D.oneOf + [ D.map (\strs -> calln (Lib.eName "strings") [ list (List.map string strs) ]) <| D.list D.string + , fallback + ] + + else + fallback + + +decodeBool = + D.bool + |> D.map + (\b -> + if b then + Lib.true + + else + Lib.false + ) + + +decodeMatch : Bool -> any -> Decoder Expression +decodeMatch isString _ = + Decode.tail D.value + |> D.andThen + (\args -> + case args of + [] -> + todo + + head :: tail -> + D.map2 + (\cond rest -> + Lib.pipelineCall + (if isString then + "matchesStr" + + else + "matchesFloat" + ) + (cond :: rest) + ) + (Decode.subdecode expression head) + (organizeArgs + (if isString then + D.map string D.string + + else + D.map float D.float + ) + [] + (normalizeArgs tail) + ) + ) + + +normalizeArgs args = + case args of + a :: b :: rest -> + case D.decodeValue (D.list D.value) a of + Err _ -> + a :: b :: rest + + Ok xs -> + List.concatMap (\x -> [ x, b ]) xs ++ normalizeArgs rest + + _ -> + args + + +organizeArgs inpDec accu args = + case args of + [] -> + Decode.combine [ D.map list (List.reverse accu |> Decode.combine) ] + + [ default ] -> + Decode.combine [ D.map list (List.reverse accu |> Decode.combine), Decode.subdecode expression default ] + + a :: b :: rest -> + let + newAccu = + D.map2 + pair + (Decode.subdecode inpDec a) + (Decode.subdecode expression b) + :: accu + in + organizeArgs inpDec newAccu rest diff --git a/style-generator/src/Decoder/Generic.elm b/style-generator/src/Decoder/Generic.elm new file mode 100644 index 0000000..b81167e --- /dev/null +++ b/style-generator/src/Decoder/Generic.elm @@ -0,0 +1,52 @@ +module Decoder.Generic exposing (combine, pair, resultToDecoder, subdecode, tail, withDefault) + +import Json.Decode as D exposing (Decoder) + + +withDefault : a -> Decoder a -> Decoder a +withDefault fallback decoder = + D.oneOf + [ decoder + , D.succeed fallback + ] + + +combine : List (Decoder a) -> Decoder (List a) +combine = + List.foldr (D.map2 (::)) (D.succeed []) + + +subdecode : Decoder a -> D.Value -> Decoder a +subdecode d v = + D.decodeValue d v |> resultToDecoder + + +tail : Decoder a -> Decoder (List a) +tail 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 + ) + + +pair : Decoder a -> Decoder b -> Decoder ( a, b ) +pair aDecoder bDecoder = + D.map2 Tuple.pair + (D.index 0 aDecoder) + (D.index 1 bDecoder) + + +resultToDecoder : Result D.Error a -> Decoder a +resultToDecoder res = + case res of + Ok a -> + D.succeed a + + Err e -> + D.fail (D.errorToString e) diff --git a/style-generator/src/Decoder/Helpers.elm b/style-generator/src/Decoder/Helpers.elm new file mode 100644 index 0000000..74c47b0 --- /dev/null +++ b/style-generator/src/Decoder/Helpers.elm @@ -0,0 +1,9 @@ +module Decoder.Helpers exposing (todo) + +import Json.Decode as D exposing (Decoder) +import Json.Encode +import Lib + + +todo = + D.map (\val -> Lib.todo ("The expression " ++ Json.Encode.encode 0 val ++ " is not yet supported")) D.value diff --git a/style-generator/src/Decoder/Legacy.elm b/style-generator/src/Decoder/Legacy.elm new file mode 100644 index 0000000..2c7be93 --- /dev/null +++ b/style-generator/src/Decoder/Legacy.elm @@ -0,0 +1,110 @@ +module Decoder.Legacy exposing (filter) + +import Decoder.Expression exposing (decodeBool) +import Decoder.Generic as Decode +import Decoder.Helpers exposing (todo) +import Json.Decode as D exposing (Decoder) +import Lib +import MyElm.Syntax exposing (Expression, calln, float, int, list, pair, string) + + +filter = + let + decodeProp = + D.index 1 D.string + |> D.map + (\prop -> + case prop of + "$type" -> + Lib.eValue "geometryType" + + "$id" -> + Lib.eValue "id" + + _ -> + calln (Lib.eName "getProperty") [ Lib.str (string prop) ] + ) + + decodeVal = + D.index 2 <| + D.oneOf + [ D.map (string >> Lib.str) D.string + , D.map (float >> Lib.float) D.float + , decodeBool + ] + + decodeVals = + D.list <| + D.oneOf + [ D.map (string >> Lib.str) D.string + , D.map (float >> Lib.float) D.float + , decodeBool + ] + + operator name = + D.map2 (\prop val -> Lib.pipelineCall name [ prop, val ]) decodeProp decodeVal + in + D.index 0 D.string + |> D.andThen + (\filt -> + case filt of + "all" -> + Decode.tail filter |> D.map (\filters -> calln (Lib.eName "all") [ list filters ]) + + "any" -> + Decode.tail filter |> D.map (\filters -> calln (Lib.eName "any") [ list filters ]) + + "none" -> + Decode.tail filter |> D.map (\filters -> calln (Lib.eName "all") [ list (List.map (\f -> calln (Lib.eName "not") [ f ]) filters) ]) + + "has" -> + D.index 1 D.string |> D.map (\prop -> calln (Lib.eName "hasProperty") [ Lib.str (string prop) ]) + + "!has" -> + D.index 1 D.string |> D.map (\prop -> calln (Lib.eName "not") [ calln (Lib.eName "hasProperty") [ Lib.str (string prop) ] ]) + + "==" -> + operator "isEqual" + + "!=" -> + operator "notEqual" + + ">" -> + operator "greaterThan" + + ">=" -> + operator "greaterThanOrEqual" + + "<" -> + operator "lessThan" + + "<=" -> + operator "lessThanOrEqual" + + "in" -> + D.map2 + (\prop values -> + List.drop 2 values + |> List.map (\v -> Lib.pipelineCall "isEqual" [ prop, v ]) + |> list + |> List.singleton + |> calln (Lib.eName "any") + ) + decodeProp + decodeVals + + "!in" -> + D.map2 + (\prop values -> + List.drop 2 values + |> List.map (\v -> Lib.pipelineCall "notEqual" [ prop, v ]) + |> list + |> List.singleton + |> calln (Lib.eName "all") + ) + decodeProp + decodeVals + + _ -> + D.fail "not actually a legacy filter" + ) diff --git a/style-generator/src/Lib.elm b/style-generator/src/Lib.elm new file mode 100644 index 0000000..32692cf --- /dev/null +++ b/style-generator/src/Lib.elm @@ -0,0 +1,101 @@ +module Lib exposing (bare, eName, eValue, expressionNs, false, float, floats, get, int, layerNs, pipelineCall, pipelineMultiCall, sourceNs, str, styleNs, todo, true, zoom) + +import MyElm.Advanced as Advanced +import MyElm.Syntax as Elm exposing (Expression) + + +styleNs = + [ "Mapbox", "Style" ] + + +layerNs = + [ "Mapbox", "Layer" ] + + +expressionNs = + [ "Mapbox", "Expression" ] + + +sourceNs = + [ "Mapbox", "Source" ] + + +eName name = + Advanced.aliasedName { modulePath = expressionNs, aliasName = "E", name = name, typeName = Nothing } + + +bare = + Advanced.exposedName expressionNs + + +zoom : Expression +zoom = + Elm.call0 (eName "zoom") + + +true : Expression +true = + Elm.call0 (bare "true") + + +false : Expression +false = + Elm.call0 (bare "false") + + +float : Expression -> Expression +float = + Elm.call1 (bare "float") + + +floats : Expression -> Expression +floats = + Elm.call1 (eName "floats") + + +int : Expression -> Expression +int = + Elm.call1 (bare "int") + + +str : Expression -> Expression +str = + Elm.call1 (bare "str") + + +eValue : String -> Expression +eValue = + eName >> Elm.call0 + + +get : Expression -> Expression +get = + Elm.call1 (eName "get") + + +todo : String -> Expression +todo msg = + Elm.call1 (Elm.valueName [ "Debug" ] "todo") (Elm.string msg) + + +pipelineCall : String -> List Expression -> Expression +pipelineCall name args = + case args of + fst :: rest -> + Elm.call2 (Elm.local "|>") + fst + (Elm.calln (eName name) rest) + + _ -> + todo <| "Wrong number of arguments passed to E." ++ name + + +pipelineMultiCall : String -> List Expression -> Expression +pipelineMultiCall name args = + case args of + fst :: rest -> + List.map (Elm.call1 (eName name)) rest + |> List.foldl (\a b -> Elm.call2 (Elm.local "|>") b a) fst + + _ -> + todo <| "Wrong number of arguments passed to E." ++ name diff --git a/style-generator/src/Main.elm b/style-generator/src/Main.elm index e46254e..7a5ba63 100644 --- a/style-generator/src/Main.elm +++ b/style-generator/src/Main.elm @@ -1,12 +1,24 @@ -module Main exposing (main) +port 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 Element exposing (Element, centerY, fill, height, padding, px, rgb255, spacing, text, width) +import Element.Background as Background +import Element.Border as Border +import Element.Font as Font +import Element.Input as Input +import Html +import Html.Attributes exposing (property, style) +import Html.Events import Http import Json.Decode +import Json.Encode exposing (Value) + + +port requestStyleUpgrade : String -> Cmd msg + + +port styleUpgradeComplete : (Value -> msg) -> Sub msg main = @@ -19,12 +31,14 @@ main = init () = - ( { styleUrl = "" - , token = "" + ( { styleUrl = "https://api.mapbox.com/styles/v1/mapbox/outdoors-v9" + , token = "pk.eyJ1IjoiYXN0cm9zYXQiLCJhIjoiY2o3YWtjNnJzMGR6ajM3b2FidmNwaDNsaSJ9.lwWi7kOiejlT0RbD7RxtmA" , style = Nothing , error = Nothing + , code = Nothing } , Cmd.none + -- , fetchStyle "https://api.mapbox.com/styles/v1/astrosat/cjl6ljcr80vwg2rmgep7t3dtl" "pk.eyJ1IjoiYXN0cm9zYXQiLCJhIjoiY2o3YWtjNnJzMGR6ajM3b2FidmNwaDNsaSJ9.lwWi7kOiejlT0RbD7RxtmA" ) @@ -33,12 +47,13 @@ type Msg | LoadStyle | StyleURLChanged String | TokenChanged String + | StyleUpgradeCompleted Value update msg model = case msg of LoadedStyle (Ok style) -> - ( { model | style = Just style }, Cmd.none ) + ( { model | style = Just style }, requestStyleUpgrade style ) LoadedStyle (Err e) -> ( { model | error = Just (errorToString e) }, Cmd.none ) @@ -52,9 +67,30 @@ update msg model = TokenChanged s -> ( { model | token = s }, Cmd.none ) + StyleUpgradeCompleted style -> + ( { model + | code = + case Json.Decode.decodeValue (Json.Decode.field "type" Json.Decode.string) style of + Ok "Ok" -> + Json.Decode.decodeValue (Json.Decode.field "result" Decoder.styleCode) style + |> Result.mapError Json.Decode.errorToString + |> Just + + Ok "Err" -> + Json.Decode.decodeValue (Json.Decode.at [ "error", "message" ] Json.Decode.string) style + |> Result.withDefault "Something went wrong" + |> Err + |> Just -subscriptions model = - Sub.none + _ -> + Just (Err "Something went wrong") + } + , Cmd.none + ) + + +subscriptions l = + styleUpgradeComplete StyleUpgradeCompleted fetchStyle styleUrl token = @@ -65,20 +101,128 @@ fetchStyle styleUrl token = |> 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 ] [] + +-- UI + + +pad = + 20 + + +body model = + Element.layout [ width fill, height fill ] <| + Element.column [ width fill, height fill, spacing pad ] + [ Element.row [ width fill, height (px 60), Background.color (rgb255 238 238 238), padding pad, Border.color (rgb255 96 181 204), Border.widthEach { bottom = 2, left = 0, right = 0, top = 0 } ] + [ Element.el [] <| Element.text "Mapbox to Elm Style Converter" + , Element.link [ Font.color (rgb255 18 133 207), Element.alignRight ] + { url = "https://github.com/gampleman/elm-mapbox/tree/master/style-generator" + , label = text "GitHub" + } + ] + , Element.row [ width fill, height fill ] + [ form [ height fill, width fill, spacing pad, padding pad ] model + , results [ height fill, width fill ] model + ] ] - , div [] [ input [ type_ "submit", value "Fetch", onClick LoadStyle ] [] ] + + +form attrs model = + Element.column attrs + [ Element.el [] <| Element.text "Import style from Mapbox" + , Input.text [] + { onChange = StyleURLChanged + , placeholder = Nothing + , label = Input.labelLeft [ centerY, width (px 100) ] <| Element.text "Style URL" + , text = model.styleUrl + } + , Input.text [] + { onChange = TokenChanged + , placeholder = Nothing + , label = Input.labelLeft [ centerY, width (px 100) ] <| Element.text "Token" + , text = model.token + } + , Input.button [ Background.color (rgb255 238 238 238), padding pad ] { onPress = Just LoadStyle, label = Element.text "Fetch style" } + , Element.el [] <| Element.text "Or paste your style here:" + , codeEditor + { width = "100%" + , height = "100%" + , mode = "json" + , code = model.style |> Maybe.withDefault "" + , onChange = Just (Ok >> LoadedStyle) + } ] +codeEditor : { width : String, height : String, mode : String, code : String, onChange : Maybe (String -> msg) } -> Element msg +codeEditor props = + let + handler = + case props.onChange of + Just tagger -> + Html.Events.on "editorChanged" <| + Json.Decode.map tagger <| + Json.Decode.at [ "detail" ] + Json.Decode.string + + Nothing -> + property "readonly" (Json.Encode.bool True) + in + Element.html <| + Html.node "code-editor" + [ props.code + |> Json.Encode.string + |> property "editorValue" + , handler + , property "mode" (Json.Encode.string "elm") + , style "width" "50vw" + , style "height" "100%" + ] + [] + + +results attrs model = + Element.el attrs <| + case ( model.error, model.code ) of + ( Just err, _ ) -> + Element.paragraph [ Font.color (rgb255 207 7 19), padding pad ] [ Element.text err ] + + ( Nothing, Just (Err err) ) -> + Element.paragraph [ Font.color (rgb255 207 7 19), padding pad ] [ Element.text err ] + + ( Nothing, Just (Ok srcCode) ) -> + codeEditor + { width = "50vw" + , height = "100%" + , mode = "elm" + , code = srcCode + , onChange = Nothing + } + + ( Nothing, Nothing ) -> + Element.column [ padding pad, spacing pad ] + [ Element.paragraph [] [ Element.text "This is a tool that helps you generate elm-mapbox styles from Mapbox Studio." ] + , Element.paragraph [] [ Element.text "In Studio, hit the share button. This will give you the style url and token. This tool will attempt to generate an elm-mapbox style for you. It is not perfect, but should give a nice head-start. Try to compile the file and see if you get any errors." ] + , Element.paragraph [] + [ text "There are a few common limitations that are relatively easy to fix with some grepping. For example, " + , code "Layer.lineJoin E.lineCapRound" + , text " should be replaced by " + , code "Layer.lineJoin E.lineJoinRound" + , text ". Also " + , code "Layer.textField" + , text " is often followed by " + , code "E.toString" + , text ", but should instead be followed by " + , code "E.toFormattedText" + , text "." + ] + ] + + +code : String -> Element msg +code = + Element.el [ Font.family [ Font.monospace ] ] << Element.text + + errorToString : Http.Error -> String errorToString err = case err of @@ -106,33 +250,8 @@ errorToString err = 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." ] - ] + [ body model ] } diff --git a/style-generator/src/MyElm/Advanced.elm b/style-generator/src/MyElm/Advanced.elm new file mode 100644 index 0000000..7f88ab2 --- /dev/null +++ b/style-generator/src/MyElm/Advanced.elm @@ -0,0 +1,46 @@ +module MyElm.Advanced exposing (aliasedName, exposedName, cheat) + +{-| This module allows you to mess with some of the the little things at the cost of a more verbose API. + +@docs aliasedName, exposedName, cheat + +-} + +import MyElm.Types exposing (Expression(..), Ident(..), QualifiedName(..)) + + +{-| Specify a name using a module Alias. If it is a constructor, you must specify the type name as well. +-} +aliasedName : + { modulePath : List String + , aliasName : String + , name : String + , typeName : Maybe String + } + -> QualifiedName +aliasedName opts = + case opts.typeName of + Just tpn -> + Aliased opts.modulePath opts.aliasName (Constructor tpn opts.name) + + Nothing -> + Aliased opts.modulePath opts.aliasName (ValueOrType opts.name) + + +{-| Import a name and expose it. +-} +exposedName : List String -> String -> QualifiedName +exposedName modulePath name = + Bare modulePath (ValueOrType name) + + +{-| Sometimes it is easier to just include a string of Elm code rather than build it up. + +This function will allow you to do that. However, using this breaks the guarantee that the +generated Elm code will be valid. You should be careful to take into consideration things like +brackets in the context where you will use this expression. + +-} +cheat : String -> Expression +cheat = + Literal diff --git a/style-generator/src/MyElm/Stringify.elm b/style-generator/src/MyElm/Stringify.elm new file mode 100644 index 0000000..da2793c --- /dev/null +++ b/style-generator/src/MyElm/Stringify.elm @@ -0,0 +1,282 @@ +module MyElm.Stringify exposing (arg2string, declaration2string, expose2string, expression2string, module2string, needsBrackets, qualifiedName2string, type2str, type2string) + +import MyElm.Types exposing (..) + + + +-- indentation + + +indented : String -> String +indented s = + s + |> String.split "\n" + |> String.join "\n " + |> String.append " " + + +listLike : String -> String -> String -> List String -> String +listLike before sep after l = + let + shouldBeMultiline = + List.any (\ln -> List.length (String.split "\n" ln) > 1) l || List.foldl (\ln s -> s + String.length ln) 0 l > 100 + in + if shouldBeMultiline then + "\n" ++ indented (before ++ " " ++ String.join ("\n" ++ sep) l ++ "\n" ++ after) + + else if after == "" && before == "" then + String.join sep l + + else + before ++ " " ++ String.join sep l ++ " " ++ after + + +bodyIndent : String -> String +bodyIndent str = + if List.length (String.split "\n" str) > 1 then + str + + else + "\n " ++ str + + +expose2string : Exposing -> String +expose2string expose = + case expose of + ValueExposed val -> + val + + TypeExposed tp -> + tp + + TypeAndConstructors tp -> + tp ++ "(..)" + + +module