diff options
Diffstat (limited to 'style-generator/src')
| -rw-r--r-- | style-generator/src/Color.elm | 104 | ||||
| -rw-r--r-- | style-generator/src/Decoder.elm | 707 | ||||
| -rw-r--r-- | style-generator/src/Decoder/Expression.elm | 345 | ||||
| -rw-r--r-- | style-generator/src/Decoder/Generic.elm | 52 | ||||
| -rw-r--r-- | style-generator/src/Decoder/Helpers.elm | 9 | ||||
| -rw-r--r-- | style-generator/src/Decoder/Legacy.elm | 110 | ||||
| -rw-r--r-- | style-generator/src/Lib.elm | 101 | ||||
| -rw-r--r-- | style-generator/src/Main.elm | 209 | ||||
| -rw-r--r-- | style-generator/src/MyElm/Advanced.elm | 46 | ||||
| -rw-r--r-- | style-generator/src/MyElm/Stringify.elm | 282 | ||||
| -rw-r--r-- | style-generator/src/MyElm/Syntax.elm | 678 | ||||
| -rw-r--r-- | style-generator/src/MyElm/Types.elm | 56 | ||||
| -rw-r--r-- | style-generator/src/Writer.elm | 640 |
13 files changed, 2039 insertions, 1300 deletions
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 ++ "(..)" + + +module2string : Module -> String +module2string (Module { name, exposes, doc, imports, declarations }) = + let + header = + "module " ++ name ++ " exposing (" ++ String.join ", " (List.map expose2string exposes) ++ ")\n\n" + + docstr = + case doc of + Just d -> + "{-|" ++ d ++ "-}\n\n" + + Nothing -> + "" + + imps = + String.join "\n" imports + ++ (if List.length imports > 0 then + "\n\n\n" + + else + "" + ) + + decs = + String.join "" <| List.map declaration2string declarations + in + header ++ docstr ++ imps ++ decs + + +type2str : Bool -> Type -> String +type2str needsBr tp = + case tp of + NamedType qualifiedName typeList -> + if List.length typeList > 0 then + if needsBr then + "(" ++ qualifiedName2string qualifiedName ++ " " ++ String.join " " (List.map (type2str True) typeList) ++ ")" + + else + qualifiedName2string qualifiedName ++ " " ++ String.join " " (List.map (type2str True) typeList) + + else + qualifiedName2string qualifiedName + + RecordType branches -> + "{ " ++ String.join ", " (List.map (\( name, typ ) -> name ++ " = " ++ type2str False typ) branches) ++ " }" + + FunctionType typeList -> + let + a = + String.join " -> " (List.map (type2str False) typeList) + in + if needsBr then + "(" ++ a ++ ")" + + else + a + + TupleType typeList -> + "( " ++ String.join ", " (List.map (type2str False) typeList) ++ " )" + + TypeVariable name -> + name + + +type2string = + type2str False + + +declaration2string : Declaration -> String +declaration2string declaration = + case declaration of + CustomType name variables variants -> + "type " ++ String.join " " (name :: variables) ++ "\n = " ++ String.join "\n | " (List.map (\( nm, args ) -> String.join " " (nm :: List.map (type2str True) args)) variants) ++ "\n\n\n" + + TypeAlias name variables aliased -> + "type alias " ++ String.join " " (name :: variables) ++ "\n =" ++ type2string aliased ++ "\n\n\n" + + Comment str -> + "{-|" ++ str ++ "}" + + ValueDeclaration name anno argList expression -> + let + decl = + name ++ " " ++ String.join " " (List.map arg2string argList) ++ " =" ++ bodyIndent (expression2string expression) ++ "\n\n\n" + in + case anno of + [] -> + decl + + signature -> + name ++ " : " ++ String.join " -> " (List.map type2string signature) ++ "\n" ++ decl + + +arg2string : Argument -> String +arg2string argument = + case argument of + Argument a -> + a + + +qualifiedName2string : QualifiedName -> String +qualifiedName2string qualifiedName = + let + identifierToStr id = + case id of + Constructor _ s -> + s + + ValueOrType s -> + s + in + case qualifiedName of + Local ident -> + identifierToStr ident + + FullyQualified modPath ident -> + String.join "." modPath ++ "." ++ identifierToStr ident + + Aliased _ alias_ ident -> + alias_ ++ "." ++ identifierToStr ident + + Bare _ ident -> + identifierToStr ident + + +bracketify : Expression -> String +bracketify arg = + if needsBrackets arg then + "(" ++ expression2string arg ++ ")" + + else + expression2string arg + + +isOperator : String -> Bool +isOperator op = + case op of + "++" -> + True + + "-" -> + True + + "+" -> + True + + "*" -> + True + + "/" -> + True + + "//" -> + True + + "^" -> + True + + "|>" -> + True + + "<|" -> + True + + _ -> + False + + +expression2string : Expression -> String +expression2string expression = + case expression of + Call name args -> + let + nameStr = + qualifiedName2string name + in + if isOperator nameStr then + case args of + a :: b :: rest -> + case nameStr of + "|>" -> + listLike "" " |> " "" [ expression2string a, String.join " " (List.map expression2string (b :: rest)) ] + + _ -> + expression2string a ++ " " ++ nameStr ++ " " ++ String.join " " (List.map expression2string (b :: rest)) + + _ -> + "(" ++ nameStr ++ ") " ++ String.join " " (List.map bracketify args) + + else + String.join " " + (nameStr + :: List.map + (\arg -> + if needsBrackets arg then + "(" ++ expression2string arg ++ ")" + + else + expression2string arg + ) + args + ) + + Literal lit -> + lit + + ListExpr expressions -> + listLike "[" ", " "]" (List.map expression2string expressions) + + Tuple expressions -> + listLike "(" ", " ")" (List.map expression2string expressions) + + Record branches -> + listLike "{" ", " "}" (List.map (\( name, branch ) -> name ++ " = " ++ expression2string branch) branches) + + +needsBrackets : Expression -> Bool +needsBrackets expression = + case expression of + Call _ [] -> + False + + Call _ _ -> + True + + _ -> + False diff --git a/style-generator/src/MyElm/Syntax.elm b/style-generator/src/MyElm/Syntax.elm new file mode 100644 index 0000000..7b99915 --- /dev/null +++ b/style-generator/src/MyElm/Syntax.elm @@ -0,0 +1,678 @@ +module MyElm.Syntax exposing + ( QualifiedName, local, valueName, typeName, constructorName + , Expression, string, float, int, list, pair, triple, call0, call1, call2, call3, call4, calln, pipe, record + , Type, type0, type1, type2, typen, recordType, functionType, pairType, tripleType, typeVar + , Declaration, variable, fun1, customType, typeAlias + , build, Exposing, opaque, withConstructors, exposeFn + ) + +{-| This module is intended for autogenerating elm code with +relatively minimal fuss and without needing to do bookkeeping +about minor details like indentation, etc. + +This is meant as the simple, convenient module that you +should get started with. It attempts to reduce boilerplate +to a minimum, but makes some opinionated choice about what +the results should look like. You can also use the Advanced +module if you want to make different choices. + +The simplifcations made here are: + + - Helpers for naming things assume a particular import style. + - Imports are generated for you automatically. + - Custom types and type alaises generate their type variables implicitely. + + +### Naming things + +@docs QualifiedName, local, valueName, typeName, constructorName + + +### Expressions + +@docs Expression, string, float, int, list, pair, triple, call0, call1, call2, call3, call4, calln, pipe, record + + +### Type signatures + +@docs Type, type0, type1, type2, typen, recordType, functionType, pairType, tripleType, typeVar + + +### Declarations + +@docs Declaration, variable, fun1, customType, typeAlias + + +### Modules + +@docs build, Exposing, opaque, withConstructors, exposeFn + +-} + +import MyElm.Stringify +import MyElm.Types exposing (..) +import Set + + +{-| The simplest thing you will need to do is keep track of what things in the program are called and where they come from. +-} +type alias QualifiedName = + MyElm.Types.QualifiedName + + +{-| This is a value (i.e. variable or function, but not type or constructor) from a module whose path is the first argument. +-} +valueName : List String -> String -> QualifiedName +valueName modulePath name = + FullyQualified modulePath (ValueOrType name) + + +{-| This is a type from a module whose path is the first argument. +-} +typeName : List String -> String -> QualifiedName +typeName modulePath name = + Bare modulePath (ValueOrType name) + + +{-| This is a constructor for a type (the second argument) from a module whose path is the first argument. + + just = + constructorName [ "Result" ] "Result" "Just" + +-} +constructorName : List String -> String -> String -> QualifiedName +constructorName modulePath typeNm name = + Bare modulePath (Constructor typeNm name) + + +{-| This is a variable local to the module you are generating. +-} +local : String -> QualifiedName +local name = + Local (ValueOrType name) + + +isLocal : QualifiedName -> Bool +isLocal qualifiedName = + case qualifiedName of + Local _ -> + True + + _ -> + False + + +{-| Create a module and return it as a pretty printed string. +-} +build : + { name : List String + , exposes : List Exposing + , doc : Maybe String + , declarations : List Declaration + } + -> String +build m = + Module + { name = String.join "." m.name + , exposes = m.exposes + , doc = m.doc + , imports = consolidateImports (extractImports m.declarations) + , declarations = m.declarations + } + |> MyElm.Stringify.module2string + + +{-| What you would like to expose from a module. +-} +type alias Exposing = + MyElm.Types.Exposing + + +{-| Expose a custom type, but leave the constructors hidden. +-} +opaque : String -> Exposing +opaque = + TypeExposed + + +{-| Expose a custom type and all its constructors. +-} +withConstructors : String -> Exposing +withConstructors = + TypeAndConstructors + + +{-| Expose a function or value. +-} +exposeFn : String -> Exposing +exposeFn = + ValueExposed + + +{-| -} +type alias Declaration = + MyElm.Types.Declaration + + +{-| This will do automatic type variable extraction for you in order of appearance in the type declaration. + +So for example: + + customType "Foo" + [ ( "Bar", TypeVariable "g" ) + , ( "Baz", TypeVariable "comparable" ) + ] + +would generate the following code: + + type Foo g comparable + = Bar g + | Baz comparable + +If you would like to control the order in which type variables appear, you can use the function in the "Advanced" module. + +-} +customType : String -> List ( String, List Type ) -> Declaration +customType name variants = + CustomType name (List.concatMap (Tuple.second >> List.concatMap extractVariables) variants |> unique) variants + + +{-| Declare a type alias. Also does automatic type variable extraction. +-} +typeAlias : String -> Type -> Declaration +typeAlias name type_ = + TypeAlias name (extractVariables type_ |> unique) type_ + + +unique : List comparable -> List comparable +unique = + Set.fromList >> Set.toList + + +extractVariables : Type -> List String +extractVariables tp = + case tp of + NamedType _ typeList -> + List.concatMap extractVariables typeList + + RecordType branches -> + List.concatMap (Tuple.second >> extractVariables) branches + + FunctionType typeList -> + List.concatMap extractVariables typeList + + TupleType typeList -> + List.concatMap extractVariables typeList + + TypeVariable variable_ -> + [ variable_ ] + + +{-| Declare a top level variable. +-} +variable : String -> Type -> Expression -> Declaration +variable name typeAnno expression = + ValueDeclaration name [ typeAnno ] [] expression + + +{-| Declare a top level function with a single argument. + + fun1 "identity" (typeVar "a") (typeVar "a") "a" call0 + +would be turned into: + + identity : a -> a + identity a = + a + +-} +fun1 : String -> Type -> Type -> String -> (QualifiedName -> Expression) -> Declaration +fun1 name fromTp toTp arg f = + ValueDeclaration name [ fromTp, toTp ] [ Argument arg ] (f (local arg)) + + +{-| The heart of an elm program are the expressions that implement the computations. +-} +type alias Expression = + MyElm.Types.Expression + + +{-| Reference a variable by name. +-} +call0 : QualifiedName -> Expression +call0 name = + Call name [] + + +{-| Call a function with 1 argument. +-} +call1 : QualifiedName -> Expression -> Expression +call1 name arg = + Call name [ arg ] + + +{-| Call a function with 2 arguments. +-} +call2 : QualifiedName -> Expression -> Expression -> Expression +call2 name arg1 arg2 = + Call name [ arg1, arg2 ] + + +{-| Call a function with 3 arguments. +-} +call3 : QualifiedName -> Expression -> Expression -> Expression -> Expression +call3 name arg1 arg2 arg3 = + Call name [ arg1, arg2, arg3 ] + + +{-| Call a function with 4 arguments. +-} +call4 : QualifiedName -> Expression -> Expression -> Expression -> Expression -> Expression +call4 name arg1 arg2 arg3 arg4 = + Call name [ arg1, arg2, arg3, arg4 ] + + +{-| Call a function with any number of arguments. +-} +calln : QualifiedName -> List Expression -> Expression +calln name args = + Call name args + + +{-| A convenience helper for construcing pipelines. + + string "foo" + |> pipe (valueName [ "String" ] "concat") [ string "bar" ] + +would generate: + + "foo" + |> String.concat "bar" + +This is just a helper for: + + pipe name args subject = + call2 (valueName [ "Basics" ] "|>") subject (calln name args) + +-} +pipe : QualifiedName -> List Expression -> Expression -> Expression +pipe name args subject = + Call (valueName [ "Basics" ] "|>") [ subject, Call name args ] + + +{-| A string literal. +-} +string : String -> Expression +string s = + Literal ("\"" ++ String.replace "\"" "\\\"" s ++ "\"") + + +{-| A float literal. +-} +float : Float -> Expression +float f = + Literal (String.fromFloat f) + + +{-| An integer literal. +-} +int : Int -> Expression +int i = + Literal (String.fromInt i) + + +{-| A list literal +-} +list : List Expression -> Expression +list = + ListExpr + + +{-| A two-tuple literal +-} +pair : Expression -> Expression -> Expression +pair a b = + Tuple [ a, b ] + + +{-| A three-tuple literal +-} +triple : Expression -> Expression -> Expression -> Expression +triple a b c = + Tuple [ a, b, c ] + + +{-| A record literal expression. +-} +record : List ( String, Expression ) -> Expression +record = + Record + + +{-| A representation of a type as in a type annotation context. +-} +type alias Type = + MyElm.Types.Type + + +{-| A simple type, like `Int`. +-} +type0 : QualifiedName -> Type +type0 qualifiedName = + NamedType qualifiedName [] + + +{-| A type with one argument, like `List`. +-} +type1 : QualifiedName -> Type -> Type +type1 qualifiedName arg1 = + NamedType qualifiedName [ arg1 ] + + +{-| A type with 2 arguments. +-} +type2 : QualifiedName -> Type -> Type -> Type +type2 qualifiedName arg1 arg2 = + NamedType qualifiedName [ arg1, arg2 ] + + +{-| A type with many arguments. +-} +typen : QualifiedName -> List Type -> Type +typen qualifiedName args = + NamedType qualifiedName args + + +{-| A record type. + +For example we could model + + { foo = Int + , bar = List String + } + +so: + + recordType + [ ( "foo", type0 (typeName [ "Basics" ] "Int") ) + , ( "bar" + , type1 (typeName [ "Basics" ] "List") + (type0 + (typeName [ "String" ] "String") + ) + ) + ] + +-} +recordType : List ( String, Type ) -> Type +recordType = + RecordType + + +{-| A function type. +-} +functionType : List Type -> Type +functionType = + FunctionType + + +{-| Pair type. +-} +pairType : Type -> Type -> Type +pairType a b = + TupleType [ a, b ] + + +{-| -} +tripleType : Type -> Type -> Type -> Type +tripleType a b c = + TupleType [ a, b, c ] + + +{-| A type variable. +-} +typeVar : String -> Type +typeVar = + TypeVariable + + +extractImports : List Declaration -> List QualifiedName +extractImports = + List.concatMap + (\dec -> + case dec of + CustomType _ _ variants -> + List.concatMap (\( _, args ) -> List.concatMap typeImports args) variants + + TypeAlias _ _ aliased -> + typeImports aliased + + Comment _ -> + [] + + ValueDeclaration _ signature _ expression -> + List.concatMap typeImports signature ++ expressionImports expression + ) + + +typeImports : Type -> List QualifiedName +typeImports tp = + case tp of + NamedType qualifiedName args -> + qualifiedName :: List.concatMap typeImports args + + RecordType rec -> + List.concatMap (\( _, typ ) -> typeImports typ) rec + + FunctionType typeList -> + List.concatMap typeImports typeList + + TupleType typeList -> + List.concatMap typeImports typeList + + TypeVariable _ -> + [] + + +expressionImports : Expression -> List QualifiedName +expressionImports expression = + case expression of + Call qualifiedName expressionList -> + qualifiedName :: List.concatMap expressionImports expressionList + + Literal _ -> + [] + + ListExpr expressionList -> + List.concatMap expressionImports expressionList + + Tuple expressionList -> + List.concatMap expressionImports expressionList + + Record branches -> + List.concatMap (Tuple.second >> expressionImports) branches + + +consolidateImports : List QualifiedName -> List String +consolidateImports qualifiedNames = + qualifiedNames + |> List.filter removeDefaults + |> List.map toTupleRep + |> Set.fromList + |> Set.toList + |> List.sort + |> consolidateTuples + |> List.map + (\( mod, al, imps ) -> + let + name = + "import " ++ mod + + alias_ = + if al == "" then + "" + + else + " as " ++ al + + exposingList = + if List.length imps > 0 then + " exposing (" ++ String.join ", " imps ++ ")" + + else + "" + in + String.join "" [ name, alias_, exposingList ] + ) + + +consolidateTuples : List ( String, String, List String ) -> List ( String, String, List String ) +consolidateTuples tuples = + case tuples of + ( xm, xa, xl ) :: ( ym, ya, yl ) :: rest -> + if xm == ym && (xa == ya || xa == "" || ya == "") then + consolidateTuples + (( xm + , if xa == "" then + ya + + else + xa + , xl ++ yl + ) + :: rest + ) + + else + ( xm, xa, xl ) :: consolidateTuples (( ym, ya, yl ) :: rest) + + x -> + x + + +iden2str : Ident -> List String +iden2str ident = + case ident of + Constructor tpname _ -> + [ tpname ++ "(..)" ] + + ValueOrType name -> + [ name ] + + +toTupleRep : QualifiedName -> ( String, String, List String ) +toTupleRep qualifiedName = + case qualifiedName of + Local _ -> + ( "not-possible", "", [] ) + + FullyQualified module_ id -> + ( String.join "." module_, "", [] ) + + Aliased module_ alias_ id -> + ( String.join "." module_, alias_, [] ) + + Bare module_ id -> + ( String.join "." module_, "", iden2str id ) + + +removeDefaults : QualifiedName -> Bool +removeDefaults qualifedName = + case qualifedName of + Local _ -> + False + + FullyQualified module_ id -> + case module_ of + [ "Basics" ] -> + False + + [ "List" ] -> + False + + [ "Maybe" ] -> + False + + [ "Result" ] -> + False + + [ "String" ] -> + False + + [ "Char" ] -> + False + + [ "Tuple" ] -> + False + + [ "Debug" ] -> + False + + [ "Platform" ] -> + False + + _ -> + True + + Aliased module_ alias_ id -> + case ( module_, alias_ ) of + ( [ "Platform", "Cmd" ], "Cmd" ) -> + False + + ( [ "Platform", "Sub" ], "Sub" ) -> + False + + _ -> + True + + Bare module_ (Constructor tpname name) -> + case ( module_, tpname ) of + ( [ "Basics" ], _ ) -> + False + + ( [ "List" ], "List" ) -> + False + + ( [ "Maybe" ], "Maybe" ) -> + False + + ( [ "Result" ], "Result" ) -> + False + + _ -> + True + + Bare module_ (ValueOrType tpname) -> + case ( module_, tpname ) of + ( [ "Basics" ], _ ) -> + False + + ( [ "List" ], "List" ) -> + False + + ( [ "List" ], "::" ) -> + False + + ( [ "Maybe" ], "Maybe" ) -> + False + + ( [ "Result" ], "Result" ) -> + False + + ( [ "String" ], "String" ) -> + False + + ( [ "Char" ], "Char" ) -> + False + + ( [ "Platform" ], "Program" ) -> + False + + ( [ "Platform", "Cmd" ], "Cmd" ) -> + False + + ( [ "Platform", "Sub" ], "Sub" ) -> + False + + _ -> + True diff --git a/style-generator/src/MyElm/Types.elm b/style-generator/src/MyElm/Types.elm new file mode 100644 index 0000000..ef473e4 --- /dev/null +++ b/style-generator/src/MyElm/Types.elm @@ -0,0 +1,56 @@ +module MyElm.Types exposing (Argument(..), Declaration(..), Exposing(..), Expression(..), Ident(..), Module(..), QualifiedName(..), Type(..)) + + +type Module + = Module + { name : String + , exposes : List Exposing + , doc : Maybe String + , imports : List String + , declarations : List Declaration + } + + +type QualifiedName + = Local Ident + | FullyQualified (List String) Ident + | Aliased (List String) String Ident + | Bare (List String) Ident + + +type Ident + = Constructor String String + | ValueOrType String + + +type Exposing + = ValueExposed String + | TypeExposed String + | TypeAndConstructors String + + +type Type + = NamedType QualifiedName (List Type) + | RecordType (List ( String, Type )) + | FunctionType (List Type) + | TupleType (List Type) + | TypeVariable String + + +type Declaration + = CustomType String (List String) (List ( String, List Type )) + | TypeAlias String (List String) Type + | ValueDeclaration String (List Type) (List Argument) Expression + | Comment String + + +type Expression + = Call QualifiedName (List Expression) + | Literal String + | ListExpr (List Expression) + | Tuple (List Expression) + | Record (List ( String, Expression )) + + +type Argument + = Argument String diff --git a/style-generator/src/Writer.elm b/style-generator/src/Writer.elm deleted file mode 100644 index ad9f3fd..0000000 --- a/style-generator/src/Writer.elm +++ /dev/null @@ -1,640 +0,0 @@ -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 |