diff --git a/implement/elm-fullstack/ElmFullstack/CompileElmValueSerializer.cs b/implement/elm-fullstack/ElmFullstack/CompileElmValueSerializer.cs deleted file mode 100644 index fa19ec0a..00000000 --- a/implement/elm-fullstack/ElmFullstack/CompileElmValueSerializer.cs +++ /dev/null @@ -1,1206 +0,0 @@ -using System; -using System.Collections.Generic; -using System.Collections.Immutable; -using System.Linq; -using System.Text; -using System.Text.RegularExpressions; -using Pine; - -namespace ElmFullstack -{ - public class CompileElmValueSerializer - { - static string encodeParamName => "valueToEncode"; - - static string jsonEncodeFunctionNamePrefix => "jsonEncode_"; - - static string jsonDecodeFunctionNamePrefix => "jsonDecode_"; - - static string jsonCodeMaybeFunctionNameCommonPart => "_generic_Maybe"; - - static string jsonCodeListFunctionNameCommonPart => "_generic_List"; - - static string jsonCodeSetFunctionNameCommonPart => "_generic_Set"; - - static string jsonCodeDictFunctionNameCommonPart => "_generic_Dict"; - - static string jsonCodeResultFunctionNameCommonPart => "_generic_Result"; - - static string jsonCodeTupleFunctionNameCommonPart => "_tuple_"; - - static IImmutableDictionary LeafExpressions => - ImmutableDictionary.Empty - .Add("String", ("Json.Encode.string " + encodeParamName, "Json.Decode.string")) - .Add("Int", ("Json.Encode.int " + encodeParamName, "Json.Decode.int")) - .Add("Bool", ("Json.Encode.bool " + encodeParamName, "Json.Decode.bool")) - .Add("Float", ("Json.Encode.float " + encodeParamName, "Json.Decode.float")) - .Add("()", ("Json.Encode.list (always (Json.Encode.object [])) []", "Json.Decode.succeed ()")) - .Add("{}", ("Json.Encode.object []", "Json.Decode.succeed {}")) - .Add("Bytes.Bytes", ("json_encode_Bytes " + encodeParamName, "json_decode_Bytes")); - - static IImmutableDictionary InstantiationSpecialCases => - ImmutableDictionary.Empty - .Add("List", jsonCodeListFunctionNameCommonPart) - .Add("Set.Set", jsonCodeSetFunctionNameCommonPart) - .Add("Maybe", jsonCodeMaybeFunctionNameCommonPart) - .Add("Result", jsonCodeResultFunctionNameCommonPart) - .Add("Dict.Dict", jsonCodeDictFunctionNameCommonPart); - - public struct ResolveTypeResult - { - public string canonicalTypeText; - - public string canonicalTypeTextWithParameters; - - public Func<(string encodeExpression, string decodeExpression, IImmutableSet dependencies)> compileExpressions; - - public IImmutableSet referencedModules; - } - - static bool StartsWithLowercaseLetter(string text) => - text.Length < 1 ? false : Char.IsLower(text[0]); - - static public ((string encodeFunctionName, string decodeFunctionName, string commonPart) functionNames, - IImmutableList typeParameterNames) - GetFunctionNamesAndTypeParametersFromTypeText(string typeText) - { - var (typeTextMinusTypeParameters, typeParametersNames) = parseForTypeParameters(typeText); - - var rootTypeTextHash = CommonConversion.HashSHA256(Encoding.UTF8.GetBytes(typeTextMinusTypeParameters)); - - var functionNameCommonPart = - StartsWithLowercaseLetter(typeTextMinusTypeParameters.Trim()) - ? - "type_parameter_" + typeTextMinusTypeParameters - : - (Regex.IsMatch(typeTextMinusTypeParameters, @"^[\w\d_\.]+$") ? - "named_" + typeTextMinusTypeParameters.Replace(".", "_dot_") - : - "anonymous_" + CommonConversion.StringBase16FromByteArray(rootTypeTextHash).Substring(0, 10)); - - return - ((jsonEncodeFunctionNamePrefix + functionNameCommonPart, - jsonDecodeFunctionNamePrefix + functionNameCommonPart, - functionNameCommonPart), typeParametersNames); - } - - static public (string encodeFunction, string decodeFunction) BuildJsonCodingFunctionTexts( - string typeText, - string encodeExpression, - string decodeExpression) - { - var (functionNames, typeParametersNames) = GetFunctionNamesAndTypeParametersFromTypeText(typeText); - - var typeParameters = - typeParametersNames - .Select(typeParameterName => - { - var parameterNameCommonPart = "type_parameter_" + typeParameterName; - - return - new - { - encodeAnnotation = typeParameterName + " -> Json.Encode.Value", - encodeParameter = jsonEncodeFunctionNamePrefix + parameterNameCommonPart, - - decodeAnnotation = "Json.Decode.Decoder " + typeParameterName, - decodeParameter = jsonDecodeFunctionNamePrefix + parameterNameCommonPart, - }; - }) - .ToImmutableList(); - - string annotationsFromTypeList(IEnumerable types) => - string.Join(" -> ", types.Select(@type => "(" + @type + ")")); - - var encodeFunction = - functionNames.encodeFunctionName + " : " + - annotationsFromTypeList( - typeParameters.Select(typeParam => typeParam.encodeAnnotation).Concat( - new[] { typeText, "Json.Encode.Value" })) + "\n" + - functionNames.encodeFunctionName + " " + - string.Join(" ", typeParameters.Select(typeParam => typeParam.encodeParameter)) + - " " + encodeParamName + " =\n" + - IndentElmCodeLines(1, encodeExpression); - - var decodeFunction = - functionNames.decodeFunctionName + " : " + - annotationsFromTypeList( - typeParameters.Select(typeParam => typeParam.decodeAnnotation).Concat( - new[] { "Json.Decode.Decoder (" + typeText + ")" })) + "\n" + - functionNames.decodeFunctionName + " " + - string.Join(" ", typeParameters.Select(typeParam => typeParam.decodeParameter)) + - " =\n" + - IndentElmCodeLines(1, decodeExpression); - - return (encodeFunction, decodeFunction); - } - - static (string typeTextMinusTypeParameters, ImmutableList typeParametersNames) parseForTypeParameters(string typeText) - { - var instanceTypeTextWithParametersMatch = Regex.Match(typeText.Trim(), @"^\((.+?)((\s+[a-z][^\s]*){1,})\)$"); - - if (instanceTypeTextWithParametersMatch.Success) - return - (instanceTypeTextWithParametersMatch.Groups[1].Value, - Regex.Split(instanceTypeTextWithParametersMatch.Groups[2].Value.Trim(), @"\s+").ToImmutableList()); - - var parseTypeResult = ParseElmTypeText(typeText, canBeInstance: true); - - var parsedType = parseTypeResult.parsedType; - - if (parsedType.Instance != null) - { - var typeParametersNames = - parsedType.Instance.Value.parameters - .SelectMany(EnumerateAllTypeNamesFromTypeText) - .Where(typeName => Char.IsLower(typeName[0])).ToImmutableList(); - - return (typeText, typeParametersNames); - } - - { - var typeParametersNames = - EnumerateAllTypeNamesFromTypeText(typeText).Where(typeName => Char.IsLower(typeName[0])).ToImmutableList(); - - return (typeText, typeParametersNames); - } - } - - static IEnumerable EnumerateAllTypeNamesFromTypeText(string typeText) - { - var parseTypeResult = ParseElmTypeText(typeText, canBeInstance: true); - - if (0 < parseTypeResult.remainingString?.Trim()?.Length) - throw new NotSupportedException("Unexpected remaining string after parsing type: '" + parseTypeResult.remainingString + "'."); - - var parsedType = parseTypeResult.parsedType; - - if (parsedType.Instance != null) - { - var instancedTypes = new[] { parsedType.Instance.Value.typeName }; - - if (parsedType.Instance.Value.parameters.Count < 1) - return instancedTypes; - - return instancedTypes.Concat(parsedType.Instance.Value.parameters.SelectMany(EnumerateAllTypeNamesFromTypeText)); - } - - if (parsedType.Tuple != null) - return parsedType.Tuple.SelectMany(EnumerateAllTypeNamesFromTypeText); - - if (parsedType.Record != null) - return parsedType.Record.Value.fields.SelectMany(field => EnumerateAllTypeNamesFromTypeText(field.typeText)); - - throw new NotImplementedException(); - } - - static public ResolveTypeResult ResolveType( - string rootTypeText, - string sourceModuleName, - IImmutableDictionary sourceModules, - Action logWriteLine) - { - rootTypeText = rootTypeText.Trim(); - - logWriteLine?.Invoke("Begin ResolveType for '" + rootTypeText + "' in module '" + sourceModuleName + "'."); - - sourceModules.TryGetValue(sourceModuleName, out var sourceModuleText); - - if (LeafExpressions.TryGetValue(rootTypeText, out var leafExpressions)) - { - logWriteLine?.Invoke("Found a leaf for type '" + rootTypeText + "'."); - - return new ResolveTypeResult - { - canonicalTypeText = rootTypeText, - - compileExpressions = () => (leafExpressions.encodeExpression, leafExpressions.decodeExpression, ImmutableHashSet.Empty), - - referencedModules = ImmutableHashSet.Empty, - }; - } - - (string referencedModuleName, string typeNameInReferencedModule) - GetCanonicalModuleNameAndLocalTypeNameFromNameInSourceModule(string nameInThisModule) - { - var importedName = GetCanonicalNameFromImportedNameInModule(nameInThisModule, sourceModuleText); - - if (importedName != null) - return importedName.Value; - - if (nameInThisModule.Contains('.')) - throw new Exception("Failed to look up name '" + nameInThisModule + "'."); - - return (sourceModuleName, nameInThisModule); - } - - (string canonicalTypeText, IImmutableSet dependencies) ResolveLocalTypeText(string typeText) - { - if (StartsWithLowercaseLetter(typeText)) - return (typeText, ImmutableHashSet.Empty); - - var canonicalTypeText = ResolveType(typeText, sourceModuleName, sourceModules, logWriteLine).canonicalTypeText; - - return (canonicalTypeText, ImmutableHashSet.Create(canonicalTypeText)); - } - - var rootType = ParseElmTypeText(rootTypeText, canBeInstance: true).parsedType; - - if (rootType.Alias != null) - { - logWriteLine?.Invoke("Type '" + rootTypeText + "' is alias for '" + rootType.Alias.Value.aliasedText + "'."); - - return ResolveType( - rootType.Alias.Value.aliasedText, - sourceModuleName, - sourceModules, - logWriteLine); - } - - if (rootType.Instance != null) - { - if (rootType.Instance.Value.parameters.Count == 0) - { - var (referencedModuleName, typeNameInReferencedModule) = - GetCanonicalModuleNameAndLocalTypeNameFromNameInSourceModule(rootTypeText); - - if (referencedModuleName != sourceModuleName) - { - logWriteLine?.Invoke("Type '" + rootTypeText + "' in '" + sourceModuleName + "' refers to '" + referencedModuleName + "." + typeNameInReferencedModule + "'."); - - return ResolveType( - typeNameInReferencedModule, - referencedModuleName, - sourceModules, - logWriteLine); - } - - logWriteLine?.Invoke("Resolve type text for '" + rootTypeText + "' in '" + sourceModuleName + "'."); - - var referencedTypeText = GetTypeDefinitionTextFromModuleText(rootTypeText, sourceModuleText); - - if (!(0 < referencedTypeText?.Length)) - throw new Exception("Did not find the definition of type '" + rootTypeText + "'."); - - return ResolveType(referencedTypeText, sourceModuleName, sourceModules, logWriteLine); - } - - logWriteLine?.Invoke("Type '" + rootTypeText + "' is instance of '" + - rootType.Instance.Value.typeName + "' with " + - rootType.Instance.Value.parameters.Count + " parameters."); - - var parameters = - rootType.Instance.Value.parameters - .Select(parameter => - { - var dependencies = ResolveType(parameter, sourceModuleName, sourceModules, logWriteLine); - - var (functionNames, typeParametersNames) = GetFunctionNamesAndTypeParametersFromTypeText(dependencies.canonicalTypeText); - - var encodeFunction = expressionTextForFunctionWithOptionalTypeParameters( - functionNames.encodeFunctionName, jsonEncodeFunctionNamePrefix, typeParametersNames); - - var decodeFunction = expressionTextForFunctionWithOptionalTypeParameters( - functionNames.decodeFunctionName, jsonDecodeFunctionNamePrefix, typeParametersNames); - - return new { encodeFunction, decodeFunction, dependencies }; - }) - .ToImmutableList(); - - string instantiatedTypeCanonicalName = null; - string instantiatedTypeFunctionNameCommonPart = null; - IImmutableSet dependenciesFromInstantiatedType = ImmutableHashSet.Empty; - - if (InstantiationSpecialCases.TryGetValue(rootType.Instance.Value.typeName, out var specialCaseFunctionNameCommonPart)) - { - instantiatedTypeCanonicalName = rootType.Instance.Value.typeName; - instantiatedTypeFunctionNameCommonPart = specialCaseFunctionNameCommonPart; - } - else - { - var instantiatedTypeResolution = ResolveType(rootType.Instance.Value.typeName, sourceModuleName, sourceModules, logWriteLine); - instantiatedTypeCanonicalName = instantiatedTypeResolution.canonicalTypeText; - instantiatedTypeFunctionNameCommonPart = GetFunctionNamesAndTypeParametersFromTypeText(instantiatedTypeCanonicalName).functionNames.commonPart; - dependenciesFromInstantiatedType = ImmutableHashSet.Create(instantiatedTypeResolution.canonicalTypeText); - } - - var parametersTypeTextsForComposition = - parameters.Select(param => - { - var needsParentheses = - param.dependencies.canonicalTypeText.Contains(" ") && - !param.dependencies.canonicalTypeText.StartsWith("(") && - !param.dependencies.canonicalTypeText.StartsWith("{"); - - var beforeParentheses = - param.dependencies.canonicalTypeText; - - if (needsParentheses) - return "(" + beforeParentheses + ")"; - - return beforeParentheses; - }); - - return new ResolveTypeResult - { - canonicalTypeText = instantiatedTypeCanonicalName + " " + String.Join(" ", parametersTypeTextsForComposition), - - compileExpressions = () => - (jsonEncodeFunctionNamePrefix + instantiatedTypeFunctionNameCommonPart + " " + String.Join(" ", parameters.Select(param => param.encodeFunction)) + " " + encodeParamName, - jsonDecodeFunctionNamePrefix + instantiatedTypeFunctionNameCommonPart + " " + String.Join(" ", parameters.Select(param => param.decodeFunction)), - dependenciesFromInstantiatedType.Union(parameters.Select(parameter => parameter.dependencies.canonicalTypeText))), - - referencedModules = ImmutableHashSet.Empty, - }; - } - - if (rootType.Record != null) - { - logWriteLine?.Invoke("'" + rootTypeText + "' is a record type."); - - var fields = rootType.Record.Value.fields.Select(recordField => - { - var fieldTypeResolution = ResolveLocalTypeText(recordField.typeText); - - var (fieldFunctionNames, fieldTypeParametersNames) = - GetFunctionNamesAndTypeParametersFromTypeText(fieldTypeResolution.canonicalTypeText); - - var encodeFunction = expressionTextForFunctionWithOptionalTypeParameters( - fieldFunctionNames.encodeFunctionName, jsonEncodeFunctionNamePrefix, fieldTypeParametersNames); - - var decodeFunction = expressionTextForFunctionWithOptionalTypeParameters( - fieldFunctionNames.decodeFunctionName, jsonDecodeFunctionNamePrefix, fieldTypeParametersNames); - - var encodeFieldValueExpression = - encodeParamName + "." + recordField.name + " |> " + encodeFunction; - - return new - { - fieldName = recordField.name, - fieldCanonicalType = fieldTypeResolution.canonicalTypeText, - encodeExpression = "( \"" + recordField.name + "\", " + encodeFieldValueExpression + " )", - decodeExpression = "|> jsonDecode_andMap ( Json.Decode.field \"" + recordField.name + "\" " + decodeFunction + " )", - dependencies = fieldTypeResolution.dependencies, - }; - }).ToImmutableList(); - - var encodeListExpression = - "[ " + - String.Join( - "\n, ", - fields.Select(field => field.encodeExpression)) - + "\n]"; - - var dencodeListExpression = - String.Join("\n", fields.Select(field => field.decodeExpression)); - - var allFieldsDependencies = - fields - .Select(field => field.dependencies) - .Aggregate(ImmutableHashSet.Empty, (a, b) => a.Union(b)); - - var encodeExpression = - "Json.Encode.object\n" + - IndentElmCodeLines(1, encodeListExpression); - - var recordFieldsNames = rootType.Record.Value.fields.Select(field => field.name); - - var decodeMapFunction = - "(\\" + String.Join(" ", recordFieldsNames) + " -> { " + - String.Join(", ", recordFieldsNames.Select(fieldName => fieldName + " = " + fieldName)) - + " })"; - - var decodeExpression = - "Json.Decode.succeed " + decodeMapFunction + "\n" + - IndentElmCodeLines(1, dencodeListExpression); - - var canonicalTypeText = - "{" + - string.Join(",", fields.Select(field => field.fieldName + ":" + field.fieldCanonicalType)) + - "}"; - - return new ResolveTypeResult - { - canonicalTypeText = canonicalTypeText, - - compileExpressions = () => (encodeExpression, decodeExpression, allFieldsDependencies), - - referencedModules = ImmutableHashSet.Empty.Add(sourceModuleName), - }; - } - - if (rootType.Custom != null) - { - logWriteLine?.Invoke("'" + rootTypeText + "' is a custom type."); - - (string encodeExpression, string decodeExpression, IImmutableSet dependencies) compileExpressions() - { - var tags = rootType.Custom.Value.tags.Select(typeTag => - { - var typeTagCanonicalName = sourceModuleName + "." + typeTag.Key; - - string encodeCaseSyntaxFromArgumentSyntaxAndObjectContentSyntax(string argumentSyntax, string objectContentSyntax) - { - var tagEncodeCase = - typeTagCanonicalName + " " + argumentSyntax + " ->"; - - var tagEncodeExpression = - @"Json.Encode.object [ ( """ + typeTag.Key + @""", " + objectContentSyntax + " ) ]"; - - return tagEncodeCase + "\n" + IndentElmCodeLines(1, tagEncodeExpression); - } - - var decodeSyntaxCommonPart = @"Json.Decode.field """ + typeTag.Key + @""""; - - if (typeTag.Value.Count == 0) - { - return new - { - encodeCase = encodeCaseSyntaxFromArgumentSyntaxAndObjectContentSyntax("", "Json.Encode.list identity []"), - decodeExpression = decodeSyntaxCommonPart + " (Json.Decode.succeed " + typeTagCanonicalName + ")", - dependencies = ImmutableHashSet.Empty, - }; - } - - var tagParametersExpressions = - typeTag.Value.Select(tagParameterType => - { - var tagParameterCanonicalTypeTextAndDependencies = ResolveLocalTypeText(tagParameterType); - - var (tagParameterTypeFunctionNames, tagParameterTypeParametersNames) = - GetFunctionNamesAndTypeParametersFromTypeText(tagParameterCanonicalTypeTextAndDependencies.canonicalTypeText); - - var tagParameterEncodeFunction = - expressionTextForFunctionWithOptionalTypeParameters( - tagParameterTypeFunctionNames.encodeFunctionName, jsonEncodeFunctionNamePrefix, tagParameterTypeParametersNames); - - var tagParameterDecodeFunction = - expressionTextForFunctionWithOptionalTypeParameters( - tagParameterTypeFunctionNames.decodeFunctionName, jsonDecodeFunctionNamePrefix, tagParameterTypeParametersNames); - - return new - { - encodeFunction = tagParameterEncodeFunction, - decodeFunction = tagParameterDecodeFunction, - canonicalTypeTextAndDependencies = tagParameterCanonicalTypeTextAndDependencies, - }; - }).ToImmutableList(); - - var tagDecodeExpressionBeforeLazy = - tagParametersExpressions.Count == 1 - /* - 2020-03-07: To support easy migration of existing applications, support decoding from the older JSON representation for tags with one parameter. - This branch can be removed when all apps have been migrated. - */ - ? - "Json.Decode.map " + typeTagCanonicalName + - " (Json.Decode.oneOf [ " + tagParametersExpressions.Single().decodeFunction + ", " + - "(Json.Decode.index 0 " + tagParametersExpressions.Single().decodeFunction + ")" + - " ])" - : - "Json.Decode.map" + tagParametersExpressions.Count.ToString() + " " + typeTagCanonicalName + " " + - string.Join(" ", tagParametersExpressions.Select((tagParamExpr, tagParamIndex) => - "(Json.Decode.index " + tagParamIndex.ToString() + " " + tagParamExpr.decodeFunction + ")")); - - var tagDecodeExpression = - decodeSyntaxCommonPart + @" (Json.Decode.lazy (\_ -> " + - tagDecodeExpressionBeforeLazy + - " ) )"; - - var encodeArgumentsAndExpressions = - tagParametersExpressions - .Select((tagArgumentExpressions, tagParameterIndex) => - { - var argumentName = "tagArgument" + tagParameterIndex.ToString(); - - return (argumentName, encodeExpression: argumentName + " |> " + tagArgumentExpressions.encodeFunction); - }).ToImmutableList(); - - var encodeArgumentSyntax = - string.Join(" ", encodeArgumentsAndExpressions.Select(argumentAndExpr => argumentAndExpr.argumentName)); - - var encodeObjectContentSyntax = - "[ " + - string.Join(", ", encodeArgumentsAndExpressions.Select(argumentAndExpr => argumentAndExpr.encodeExpression)) - + " ] |> Json.Encode.list identity"; - - var tagParametersDependencies = - tagParametersExpressions - .Select(tagParamResult => tagParamResult.canonicalTypeTextAndDependencies.dependencies) - .Aggregate(ImmutableHashSet.Empty, (a, b) => a.Union(b)); - - return new - { - encodeCase = encodeCaseSyntaxFromArgumentSyntaxAndObjectContentSyntax( - encodeArgumentSyntax, - encodeObjectContentSyntax), - decodeExpression = tagDecodeExpression, - dependencies = tagParametersDependencies, - }; - }) - .ToImmutableList(); - - var encodeCases = - String.Join("\n\n", tags.Select(tag => tag.encodeCase)); - - var encodeExpression = - "case " + encodeParamName + " of\n" + - IndentElmCodeLines(1, encodeCases); - - var decodeArrayExpression = "[ " + String.Join("\n, ", tags.Select(tag => tag.decodeExpression)) + "\n]"; - - var decodeExpression = - "Json.Decode.oneOf\n" + - IndentElmCodeLines(1, decodeArrayExpression); - - var allTagsDependencies = - tags.SelectMany(field => field.dependencies) - .ToImmutableHashSet(); - - return (encodeExpression, decodeExpression, allTagsDependencies); - } - - var canonicalTypeText = sourceModuleName + "." + rootType.Custom.Value.typeLocalName; - - var canonicalTypeTextWithParameters = - rootType.Custom.Value.parameters.Count < 1 - ? - canonicalTypeText - : - "(" + canonicalTypeText + " " + string.Join(" ", rootType.Custom.Value.parameters) + ")"; - - return new ResolveTypeResult - { - canonicalTypeText = canonicalTypeText, - canonicalTypeTextWithParameters = canonicalTypeTextWithParameters, - - compileExpressions = compileExpressions, - - referencedModules = ImmutableHashSet.Empty.Add(sourceModuleName), - }; - } - - if (rootType.Tuple != null) - { - logWriteLine?.Invoke("'" + rootTypeText + "' is a " + rootType.Tuple.Count + "-tuple."); - - var tupleElementsResults = - rootType.Tuple - .Select(tupleElementType => ResolveLocalTypeText(tupleElementType)) - .ToImmutableList(); - - var tupleElementsCanonicalTypeName = - tupleElementsResults - .Select(elementResult => elementResult.canonicalTypeText) - .ToImmutableList(); - - var allElementsDependencies = - tupleElementsResults.SelectMany(elementResult => elementResult.dependencies) - .ToImmutableHashSet(); - - var tupleElementsFunctionNames = - tupleElementsCanonicalTypeName - .Select(tupleElement => GetFunctionNamesAndTypeParametersFromTypeText(tupleElement).functionNames) - .ToImmutableList(); - - var functionNameCommonPart = jsonCodeTupleFunctionNameCommonPart + rootType.Tuple.Count.ToString(); - - var encodeExpression = - jsonEncodeFunctionNamePrefix + functionNameCommonPart + " " + - String.Join(" ", tupleElementsFunctionNames.Select(functionNamesAndTypeParams => - functionNamesAndTypeParams.encodeFunctionName)) + " " + - encodeParamName; - - var decodeExpression = - jsonDecodeFunctionNamePrefix + functionNameCommonPart + " " + - String.Join(" ", tupleElementsFunctionNames.Select(functionNamesAndTypeParams => - functionNamesAndTypeParams.decodeFunctionName)); - - var canonicalTypeText = "(" + string.Join(",", tupleElementsCanonicalTypeName) + ")"; - - return new ResolveTypeResult - { - canonicalTypeText = canonicalTypeText, - - compileExpressions = () => (encodeExpression, decodeExpression, allElementsDependencies), - - referencedModules = ImmutableHashSet.Empty.Add(sourceModuleName), - }; - } - - throw new Exception("Parsed invalid case for type '" + rootTypeText + "'"); - } - - static string expressionTextForFunctionWithOptionalTypeParameters( - string functionName, string typeParametersFunctionsCommonPrefix, IImmutableList typeParametersNames) - { - var needsParentheses = 0 < typeParametersNames.Count; - - var beforeParentheses = - functionName + - String.Join("", typeParametersNames.Select(typeParameterName => " " + typeParametersFunctionsCommonPrefix + "type_parameter_" + typeParameterName)); - - if (needsParentheses) - return "(" + beforeParentheses + ")"; - - return beforeParentheses; - } - - - static string ElmCodeIndentString(int level) => - level <= 0 ? "" : " " + ElmCodeIndentString(level - 1); - - static public string IndentElmCodeLines(int level, string textBeforeIndent) - { - var indentString = ElmCodeIndentString(level); - - return indentString + textBeforeIndent.Replace("\n", "\n" + indentString); - } - - static public (ElmType parsedType, string remainingString) ParseElmTypeText( - string elmTypeText, - bool canBeInstance) - { - // Assume: Custom type tags are all on their own line. - - try - { - var typeDefinitionTextLines = elmTypeText.Split(new char[] { '\n' }); - - var aliasMatch = Regex.Match(typeDefinitionTextLines[0], @"^type\s+alias\s+([A-Z][^\s]*(\s+[a-z][^\s]*){0,})\s*="); - - if (aliasMatch.Success) - { - var aliasNameAndParameters = Regex.Split(aliasMatch.Groups[1].Value.Trim(), @"\s+"); - - var aliasLocalName = aliasNameAndParameters.First(); - var parameters = aliasNameAndParameters.Skip(1).ToImmutableList(); - - return (parsedType: new ElmType - { - Alias = new ElmType.AliasStructure - { - aliasLocalName = aliasLocalName, - parameters = parameters, - aliasedText = string.Join("\n", typeDefinitionTextLines.Skip(1).ToArray()), - }, - }, ""); - } - - var customTypeMatch = Regex.Match(string.Join("", typeDefinitionTextLines), @"^type\s+([A-Z][^\s]*(\s+[a-z][^\s]*){0,})\s*="); - - if (customTypeMatch.Success) - { - var typeNameAndParameters = Regex.Split(customTypeMatch.Groups[1].Value, @"\s+"); - - var typeLocalName = typeNameAndParameters.First(); - var parameters = typeNameAndParameters.Skip(1).ToImmutableList(); - - var tags = - typeDefinitionTextLines.Skip(1) - .Select(tagLine => - { - var overallMatch = Regex.Match(tagLine, @"^\s+(=|\|)\s*([\w\d_]+)(.*)$"); - - if (!overallMatch.Success) - throw new Exception("Failed to parse Custom Type tag name from '" + tagLine + "'"); - - var parametersText = overallMatch.Groups[3].Value.Trim(); - - var tagParametersTexts = new List(); - - var tagParametersTextRemaining = parametersText; - - while (0 < tagParametersTextRemaining?.Length) - { - var (parameter, remainingAfterParameter) = ParseElmTypeText(tagParametersTextRemaining, canBeInstance: false); - - var tagParameterText = - tagParametersTextRemaining - .Substring(0, tagParametersTextRemaining.Length - remainingAfterParameter.Length) - .Trim(); - - tagParametersTexts.Add(tagParameterText); - - tagParametersTextRemaining = remainingAfterParameter.TrimStart(); - } - - return (tagName: overallMatch.Groups[2].Value, tagParameters: (IImmutableList)tagParametersTexts.ToImmutableList()); - }) - .ToImmutableDictionary(tag => tag.tagName, tag => tag.tagParameters); - - return (parsedType: new ElmType - { - Custom = new ElmType.CustomStructure - { - typeLocalName = typeLocalName, - parameters = parameters, - tags = tags - }, - }, ""); - } - - var withoutLeadingWhitespace = elmTypeText.TrimStart(); - - switch (withoutLeadingWhitespace[0]) - { - case '(': - var parenthesesRest = withoutLeadingWhitespace.Substring(1); - - var elements = new List(); - - while (true) - { - var (_, restWithoutLeadingWhitespace) = parseRegexPattern(parenthesesRest, @"\s*"); - - if (restWithoutLeadingWhitespace.Length < 1) - throw new Exception("Missing terminating parenthesis."); - - var (termination, restAfterTermination) = parseRegexPattern(restWithoutLeadingWhitespace, @"\)"); - - if (0 < termination.Length) - { - var parsedType = - 1 == elements.Count ? - ParseElmTypeText(elements.Single(), canBeInstance: true).parsedType - : - new ElmType - { - Tuple = elements.ToImmutableList() - }; - - return (parsedType, restAfterTermination); - } - - if (0 < elements.Count) - { - var (separator, restAfterSeparator) = parseRegexPattern(restWithoutLeadingWhitespace, @",\s*"); - - if (!(0 < separator.Length)) - throw new Exception("Missing separator."); - - restWithoutLeadingWhitespace = restAfterSeparator.TrimStart(); - } - - var parsedElement = ParseElmTypeText(restWithoutLeadingWhitespace, canBeInstance: true); - - var parsedElementText = restWithoutLeadingWhitespace.Substring(0, restWithoutLeadingWhitespace.Length - parsedElement.remainingString.Length); - - elements.Add(parsedElementText); - parenthesesRest = parsedElement.remainingString; - } - - case '{': - var recordRest = withoutLeadingWhitespace.Substring(1); - - var fields = new List<(string fieldName, string fieldTypeText, ElmType fieldType)>(); - - while (true) - { - var recordRestWithoutLeadingWhitespace = recordRest.TrimStart(); - - if (recordRestWithoutLeadingWhitespace[0] == '}') - { - return (parsedType: new ElmType - { - Record = new ElmType.RecordStructure - { - fields = fields.ToImmutableList(), - } - }, remainingString: recordRestWithoutLeadingWhitespace.Substring(1)); - } - - var (_, restAfterFieldSeparator) = parseRegexPattern(recordRestWithoutLeadingWhitespace, @"\s*,\s*"); - - var (fieldName, restAfterFieldName) = parseFieldName(restAfterFieldSeparator); - - var (_, restAfterFieldColon) = parseRegexPattern(restAfterFieldName, @"\s*:\s*"); - - var (fieldType, restAfterFieldType) = ParseElmTypeText(restAfterFieldColon, canBeInstance: true); - - recordRest = restAfterFieldType; - - var fieldTypeTextLength = restAfterFieldColon.Length - recordRest.Length; - - if (fieldName.Length < 1) - throw new Exception("Missing termination token."); - - fields.Add((fieldName, fieldTypeText: restAfterFieldColon.Substring(0, fieldTypeTextLength), fieldType)); - } - - case char firstCharacter when Char.IsLetter(firstCharacter) || firstCharacter == '_': - - var nameInInstanceRegexPattern = @"[\w\d_\.]+"; - - var (firstName, restAfterFirstName) = parseRegexPattern(withoutLeadingWhitespace, nameInInstanceRegexPattern); - - if (!canBeInstance) - { - return (parsedType: new ElmType - { - Instance = (typeName: firstName, parameters: ImmutableList.Empty), - }, - remainingString: restAfterFirstName); - } - - var parametersTexts = new List(); - - var instanceRest = restAfterFirstName; - - while (true) - { - var (_, instanceRestWithoutWhitespace) = parseRegexPattern(instanceRest, @"\s*"); - - var (parameterName, restAfterParameterName) = parseRegexPattern( - instanceRestWithoutWhitespace, nameInInstanceRegexPattern); - - if (0 < parameterName.Length) - { - parametersTexts.Add(parameterName); - instanceRest = restAfterParameterName; - continue; - } - - var (parameterTypeBegin, _) = parseRegexPattern(instanceRestWithoutWhitespace, @"[\(\{]"); - - if (0 < parameterTypeBegin.Length) - { - var parameterParsed = ParseElmTypeText(instanceRestWithoutWhitespace, canBeInstance: false); - - var parameterTypeText = instanceRestWithoutWhitespace.Substring(0, instanceRestWithoutWhitespace.Length - parameterParsed.remainingString.Length); - - parametersTexts.Add(parameterTypeText); - instanceRest = parameterParsed.remainingString; - continue; - } - - return (parsedType: new ElmType - { - Instance = (typeName: firstName, parametersTexts.ToImmutableList()), - }, - remainingString: instanceRest); - } - - case char other: - throw new NotSupportedException("Unexpected first character in type text: '" + other.ToString() + "'."); - } - - throw new NotImplementedException("Type text did not match any supported pattern."); - } - catch (Exception e) - { - throw new Exception("Failed to parse type '" + elmTypeText + "'.", e); - } - } - - static (string fieldName, string remainingString) parseFieldName(string originalString) - { - return parseRegexPattern(originalString, @"[\w\d_]+"); - } - - static (string matchValue, string remainingString) parseRegexPattern(string originalString, string regexPattern) - { - var match = Regex.Match(originalString, "^" + regexPattern); - - return (matchValue: match.Value, remainingString: originalString.Substring(match.Length)); - } - - /* - Resolve the 'exposing' and optional 'as' parts 'import' statements. - Return null in case this name is not imported. - */ - static public (string moduleName, string localTypeName)? GetCanonicalNameFromImportedNameInModule( - string importedNameInModule, string moduleText) - { - // Assume: Each import is expressed on a single line. - - var qualifiedMatch = Regex.Match(importedNameInModule, @"(.+)\.(.+)"); - - var imports = - GetElmModuleTextLines(moduleText) - .Select(line => Regex.Match(line, @"^import\s+([\w\d\._]+)(.*)")) - .Where(match => match.Success) - .ToImmutableDictionary(match => match.Groups[1].Value, match => match.Groups[2].Value); - - if (qualifiedMatch.Success) - { - // In this case, we are looking for 'as' or the unmapped name. - - var moduleName = qualifiedMatch.Groups[1].Value; - var typeName = qualifiedMatch.Groups[2].Value; - - { - imports.TryGetValue(moduleName, out var literalMatch); - - if (literalMatch != null) - return (moduleName, typeName); - } - - { - var matchingImportByAs = - imports.FirstOrDefault(import => - { - var asMatch = Regex.Match(import.Value, @"^\s+as\s+([\w\d_]+)"); - - return asMatch.Success && asMatch.Groups[1].Value == moduleName; - }); - - if (matchingImportByAs.Key != null) - return (matchingImportByAs.Key, typeName); - } - - return null; - } - else - { - foreach (var import in imports) - { - var exposingMatch = Regex.Match(import.Value, @"^\s*(|as\s+[\w\d_]+\s*)exposing\s*\(([^\)]*)\)"); - - if (!exposingMatch.Success) - continue; - - var exposedAggregated = exposingMatch.Groups[2].Value.Trim(); - - if (exposedAggregated == "..") - { - // resolving 'exposing(..)' in import is not implemented yet. - - continue; - } - - var exposedNames = - exposedAggregated - .Split(new[] { ',' }) - .Select(commaSeparatedValue => commaSeparatedValue.Trim()) - .ToImmutableList(); - - if (exposedNames.Contains(importedNameInModule)) - { - return (import.Key, importedNameInModule); - } - } - - return null; - } - } - - static public IImmutableList GetElmModuleTextLines(string moduleText) => - moduleText.Replace("\r", "").Split(new[] { '\n' }, StringSplitOptions.None) - .ToImmutableList(); - - static public string GetTypeDefinitionTextFromModuleText(string typeNameInModule, string moduleText) - { - // Assume: There are no empty lines and no comments in the type definition. - - var match = - Regex.Match( - moduleText.Replace("\r", ""), - @"(?<=(^|\n))type\s+(|alias\s+)" + typeNameInModule + @"\s+.+?(?=\n($|\n))", - RegexOptions.Singleline); - - if (!match.Success) - return null; - - return match.Value; - } - - public struct ElmType - { - public CustomStructure? Custom; - - public RecordStructure? Record; - - public AliasStructure? Alias; - - public (string typeName, IImmutableList parameters)? Instance; - - public IImmutableList Tuple; - - public struct AliasStructure - { - public string aliasLocalName; - - public IImmutableList parameters; - - public string aliasedText; - } - - public struct CustomStructure - { - public string typeLocalName; - - public IImmutableList parameters; - - public IImmutableDictionary> tags; - } - - public struct RecordStructure - { - public IImmutableList<(string name, string typeText, ElmType parsedType)> fields; - } - } - - public struct ExpressionsForType - { - public string encodeExpression; - - public string decodeExpression; - - public IImmutableSet referencedModules; - - public override bool Equals(object obj) - { - if (obj is ExpressionsForType sameType) - return Equals(sameType); - - return base.Equals(obj); - } - - public bool Equals(ExpressionsForType other) => - encodeExpression == other.encodeExpression && - decodeExpression == other.decodeExpression && - referencedModules.SetEquals(other.referencedModules); - } - - static public IEnumerable<(string elmType, ExpressionsForType result)> - EnumerateExpressionsResolvingAllDependencies( - Func getExpressionsAndDependenciesForType, - IImmutableSet rootTypes) - { - var remainingDependencies = new Queue(rootTypes); - - var alreadyResolved = new HashSet(); - - while (0 < remainingDependencies.Count) - { - var currentType = remainingDependencies.Dequeue(); - - if (alreadyResolved.Contains(currentType)) - continue; - - alreadyResolved.Add(currentType); - - var currentTypeResults = getExpressionsAndDependenciesForType(currentType); - - var currentTypeExpressions = currentTypeResults.compileExpressions(); - - foreach (var dependency in currentTypeExpressions.dependencies) - remainingDependencies.Enqueue(dependency); - - yield return - (currentTypeResults.canonicalTypeTextWithParameters ?? currentTypeResults.canonicalTypeText, - new ExpressionsForType - { - encodeExpression = currentTypeExpressions.encodeExpression, - decodeExpression = currentTypeExpressions.decodeExpression, - referencedModules = currentTypeResults.referencedModules, - }); - } - } - - static public IImmutableList generalSupportingFunctionsTexts => new[]{ - jsonEncodeFunctionNamePrefix + jsonCodeMaybeFunctionNameCommonPart + $@" encodeJust valueToEncode = - case valueToEncode of - Nothing -> - [ ( ""Nothing"", [] |> Json.Encode.list identity ) ] |> Json.Encode.object - - Just just -> - [ ( ""Just"", [ just ] |> Json.Encode.list encodeJust ) ] |> Json.Encode.object -", - jsonDecodeFunctionNamePrefix + jsonCodeMaybeFunctionNameCommonPart + $@" decoder = - Json.Decode.oneOf - [ Json.Decode.field ""Nothing"" (Json.Decode.succeed Nothing) - , Json.Decode.field ""Just"" ((Json.Decode.index 0 decoder) |> Json.Decode.map Just) - , Json.Decode.field ""Just"" (decoder |> Json.Decode.map Just) -- 2020-03-07 Support easy migration of apps: Support decode from older JSON format for now. - , Json.Decode.null Nothing -- Temporary backwardscompatibility: Map 'null' to Nothing - ] -", - - jsonEncodeFunctionNamePrefix + jsonCodeListFunctionNameCommonPart + $@" encoder = - Json.Encode.list encoder -", - jsonDecodeFunctionNamePrefix + jsonCodeListFunctionNameCommonPart + $@" decoder = - Json.Decode.list decoder -", - - jsonEncodeFunctionNamePrefix + jsonCodeSetFunctionNameCommonPart + $@" encoder = - Set.toList >> Json.Encode.list encoder -", - jsonDecodeFunctionNamePrefix + jsonCodeSetFunctionNameCommonPart + $@" decoder = - Json.Decode.list decoder |> Json.Decode.map Set.fromList -", - jsonEncodeFunctionNamePrefix + jsonCodeDictFunctionNameCommonPart + $@" encodeKey encodeValue = - Dict.toList >> Json.Encode.list (" + jsonEncodeFunctionNamePrefix + jsonCodeTupleFunctionNameCommonPart + "2 encodeKey encodeValue)", - - jsonDecodeFunctionNamePrefix + jsonCodeDictFunctionNameCommonPart + $@" decodeKey decodeValue = - let - -- Support migrate applications automatically from older framework versions: - - oldElementDecoder = - Json.Decode.map2 Tuple.pair - (Json.Decode.field ""key"" decodeKey) - (Json.Decode.field ""value"" decodeValue) - in - Json.Decode.list (Json.Decode.oneOf [ " + jsonDecodeFunctionNamePrefix + jsonCodeTupleFunctionNameCommonPart + $@"2 decodeKey decodeValue, oldElementDecoder ]) - |> Json.Decode.map Dict.fromList -", - jsonEncodeFunctionNamePrefix + jsonCodeResultFunctionNameCommonPart + $@" encodeErr encodeOk valueToEncode = - case valueToEncode of - Err valueToEncodeError -> - [ ( ""Err"", [ valueToEncodeError ] |> Json.Encode.list encodeErr ) ] |> Json.Encode.object - - Ok valueToEncodeOk -> - [ ( ""Ok"", [ valueToEncodeOk ] |> Json.Encode.list encodeOk ) ] |> Json.Encode.object -", - jsonDecodeFunctionNamePrefix + jsonCodeResultFunctionNameCommonPart + $@" decodeErr decodeOk = - Json.Decode.oneOf - [ Json.Decode.field ""Err"" (Json.Decode.index 0 decodeErr) |> Json.Decode.map Err - , Json.Decode.field ""Ok"" (Json.Decode.index 0 decodeOk) |> Json.Decode.map Ok - , Json.Decode.field ""Err"" decodeErr |> Json.Decode.map Err -- 2020-03-07 Support easy migration of apps: Support decode from older JSON format for now. - , Json.Decode.field ""Ok"" decodeOk |> Json.Decode.map Ok -- 2020-03-07 Support easy migration of apps: Support decode from older JSON format for now. - ] -", - jsonEncodeFunctionNamePrefix + jsonCodeTupleFunctionNameCommonPart + $@"2 encodeA encodeB ( a, b ) = - [ a |> encodeA, b |> encodeB ] - |> Json.Encode.list identity -", - jsonDecodeFunctionNamePrefix + jsonCodeTupleFunctionNameCommonPart + $@"2 decodeA decodeB = - Json.Decode.map2 (\a b -> ( a, b )) - (Json.Decode.index 0 decodeA) - (Json.Decode.index 1 decodeB) -", - jsonEncodeFunctionNamePrefix + jsonCodeTupleFunctionNameCommonPart + $@"3 encodeA encodeB encodeC ( a, b, c ) = - [ a |> encodeA, b |> encodeB, c |> encodeC ] - |> Json.Encode.list identity -", - jsonDecodeFunctionNamePrefix + jsonCodeTupleFunctionNameCommonPart + $@"3 decodeA decodeB decodeC = - Json.Decode.map3 (\a b c -> ( a, b, c )) - (Json.Decode.index 0 decodeA) - (Json.Decode.index 1 decodeB) - (Json.Decode.index 2 decodeC) -", - $@"{{-| As found at --}} -jsonDecode_andMap : Json.Decode.Decoder a -> Json.Decode.Decoder (a -> b) -> Json.Decode.Decoder b -jsonDecode_andMap = - Json.Decode.map2 (|>) -", -$@" -json_encode_Bytes : Bytes.Bytes -> Json.Encode.Value -json_encode_Bytes bytes = - [ ( ""AsBase64"", bytes |> Base64.fromBytes |> Maybe.withDefault ""Error encoding to base64"" |> Json.Encode.string ) ] - |> Json.Encode.object -", -$@" -json_decode_Bytes : Json.Decode.Decoder Bytes.Bytes -json_decode_Bytes = - Json.Decode.field ""AsBase64"" - (Json.Decode.string - |> Json.Decode.andThen - (Base64.toBytes >> Maybe.map Json.Decode.succeed >> Maybe.withDefault (Json.Decode.fail ""Failed to decode base64."")) - ) -" - }.ToImmutableList(); - } -} \ No newline at end of file diff --git a/implement/elm-fullstack/ElmFullstack/ElmApp.cs b/implement/elm-fullstack/ElmFullstack/ElmApp.cs index 6090689d..3e62d852 100644 --- a/implement/elm-fullstack/ElmFullstack/ElmApp.cs +++ b/implement/elm-fullstack/ElmFullstack/ElmApp.cs @@ -3,7 +3,6 @@ using System.Collections.Immutable; using System.Linq; using System.Text; -using System.Text.RegularExpressions; using Pine; namespace ElmFullstack @@ -48,194 +47,12 @@ static public IImmutableDictionary, IImmutableList> static public IImmutableDictionary, IImmutableList> AsCompletelyLoweredElmApp( IImmutableDictionary, IImmutableList> sourceFiles, - ElmAppInterfaceConfig interfaceConfig, - Action logWriteLine) => + ElmAppInterfaceConfig interfaceConfig) => AsCompletelyLoweredElmApp( sourceFiles, rootModuleName: interfaceConfig.RootModuleName.Split('.').ToImmutableList(), interfaceToHostRootModuleName: InterfaceToHostRootModuleName.Split('.').ToImmutableList()); - static public IImmutableDictionary, IImmutableList> WithSupportForCodingElmType( - IImmutableDictionary, IImmutableList> originalAppFiles, - string elmTypeName, - string elmModuleToAddFunctionsIn, - Action logWriteLine, - out (string encodeFunctionName, string decodeFunctionName) functionNames) - { - var interfaceModuleFilePath = FilePathFromModuleName(elmModuleToAddFunctionsIn); - - if (!originalAppFiles.ContainsKey(interfaceModuleFilePath)) - { - throw new ArgumentException("Did not find the module '" + elmModuleToAddFunctionsIn + "'."); - } - - var interfaceModuleOriginalFile = originalAppFiles[interfaceModuleFilePath]; - - var interfaceModuleOriginalFileText = - Encoding.UTF8.GetString(interfaceModuleOriginalFile.ToArray()); - - string getOriginalModuleText(string moduleName) - { - var filePath = FilePathFromModuleName(moduleName); - - originalAppFiles.TryGetValue(filePath, out var moduleFile); - - if (moduleFile == null) - throw new Exception("Did not find the module named '" + moduleFile + "'"); - - return Encoding.UTF8.GetString(moduleFile.ToArray()); - } - - var allOriginalElmModulesNames = - originalAppFiles - .Select(originalAppFilePathAndContent => - { - var fileName = originalAppFilePathAndContent.Key.Last(); - - if (originalAppFilePathAndContent.Key.First() != "src" || !fileName.EndsWith(".elm")) - return null; - - return - (IEnumerable) - originalAppFilePathAndContent.Key.Skip(1).Reverse().Skip(1).Reverse() - .Concat(new[] { fileName.Substring(0, fileName.Length - 4) }) - .ToImmutableList(); - }) - .Where(module => module != null) - .OrderBy(module => string.Join(".", module)) - .ToImmutableHashSet(); - - var sourceModules = - allOriginalElmModulesNames - .Select(moduleName => string.Join(".", moduleName)) - .ToImmutableDictionary( - moduleName => moduleName, - moduleName => - { - var originalModuleText = getOriginalModuleText(moduleName); - - if (moduleName == elmModuleToAddFunctionsIn) - { - return - CompileElm.WithImportsAdded(originalModuleText, allOriginalElmModulesNames); - } - - return originalModuleText; - }); - - var getExpressionsAndDependenciesForType = new Func(canonicalTypeName => - { - return - CompileElmValueSerializer.ResolveType( - canonicalTypeName, - elmModuleToAddFunctionsIn, - sourceModules, - logWriteLine); - }); - - var functionCodingExpressions = - CompileElmValueSerializer.EnumerateExpressionsResolvingAllDependencies( - getExpressionsAndDependenciesForType, - ImmutableHashSet.Create(elmTypeName)) - .ToImmutableList(); - - var functionCodingExpressionsDict = - functionCodingExpressions - .ToImmutableDictionary(entry => entry.elmType, entry => entry.result); - - var appFilesAfterExposingCustomTypesInModules = - functionCodingExpressionsDict - .Select(exprResult => exprResult.Key) - .Aggregate( - originalAppFiles, - (partiallyUpdatedAppFiles, elmType) => - { - { - var enclosingParenthesesMatch = Regex.Match(elmType.Trim(), @"^\(([^,^\)]+)\)$"); - - if (enclosingParenthesesMatch.Success) - elmType = enclosingParenthesesMatch.Groups[1].Value; - } - - var qualifiedMatch = Regex.Match(elmType.Trim(), @"^(.+)\.([^\s^\.]+)(\s+[a-z][^\s^\.]*)*$"); - - if (!qualifiedMatch.Success) - return partiallyUpdatedAppFiles; - - var moduleName = qualifiedMatch.Groups[1].Value; - var localTypeName = qualifiedMatch.Groups[2].Value; - - var expectedFilePath = FilePathFromModuleName(moduleName); - - var moduleBefore = - partiallyUpdatedAppFiles - .FirstOrDefault(candidate => candidate.Key.SequenceEqual(expectedFilePath)); - - if (moduleBefore.Value == null) - return partiallyUpdatedAppFiles; - - var moduleTextBefore = Encoding.UTF8.GetString(moduleBefore.Value.ToArray()); - - var isCustomTypeMatch = Regex.Match( - moduleTextBefore, - @"^type\s+" + localTypeName + @"(\s+[a-z][^\s]*){0,}\s*=", RegexOptions.Multiline); - - if (!isCustomTypeMatch.Success) - return partiallyUpdatedAppFiles; - - var moduleText = CompileElm.ExposeCustomTypeAllTagsInElmModule(moduleTextBefore, localTypeName); - - return partiallyUpdatedAppFiles.SetItem(moduleBefore.Key, Encoding.UTF8.GetBytes(moduleText).ToImmutableList()); - }); - - var supportingCodingFunctions = - functionCodingExpressionsDict - .Select(typeResult => CompileElmValueSerializer.BuildJsonCodingFunctionTexts( - typeResult.Key, - typeResult.Value.encodeExpression, - typeResult.Value.decodeExpression)) - .SelectMany(encodeAndDecodeFunctions => new[] { encodeAndDecodeFunctions.encodeFunction, encodeAndDecodeFunctions.decodeFunction }) - .ToImmutableHashSet() - .Union(CompileElmValueSerializer.generalSupportingFunctionsTexts); - - var modulesToImport = - functionCodingExpressions - .SelectMany(functionReplacement => - functionReplacement.result.referencedModules.Select(moduleName => moduleName.Split("."))) - .ToImmutableHashSet(EnumerableExtension.EqualityComparer()) - .Remove(elmModuleToAddFunctionsIn.Split(".")) - .Add(new[] { "Set" }) - .Add(new[] { "Dict" }) - .Add(new[] { "Json.Decode" }) - .Add(new[] { "Json.Encode" }) - .Add(new[] { "Base64" }) - .Add(new[] { "Bytes" }) - .Add(new[] { "Bytes.Encode" }) - .Add(new[] { "Bytes.Decode" }); - - var interfaceModuleWithImports = - CompileElm.WithImportsAdded(interfaceModuleOriginalFileText, modulesToImport); - - var interfaceModuleWithSupportingFunctions = - supportingCodingFunctions - .Aggregate( - interfaceModuleWithImports, - (intermediateModuleText, supportingFunction) => CompileElm.WithFunctionAdded(intermediateModuleText, supportingFunction)); - - var elmTypeCodingFunctionNames = - CompileElmValueSerializer.GetFunctionNamesAndTypeParametersFromTypeText( - getExpressionsAndDependenciesForType(elmTypeName).canonicalTypeText); - - functionNames = - (encodeFunctionName: elmTypeCodingFunctionNames.functionNames.encodeFunctionName, - decodeFunctionName: elmTypeCodingFunctionNames.functionNames.decodeFunctionName); - - return - appFilesAfterExposingCustomTypesInModules.SetItem( - interfaceModuleFilePath, - Encoding.UTF8.GetBytes(interfaceModuleWithSupportingFunctions).ToImmutableList()); - } - static IImmutableDictionary, IImmutableList> AsCompletelyLoweredElmApp( IImmutableDictionary, IImmutableList> sourceFiles, IImmutableList rootModuleName, @@ -407,129 +224,8 @@ static public IImmutableList FilePathFromModuleName(IReadOnlyList FilePathFromModuleName(string moduleName) => FilePathFromModuleName(moduleName.Split(new[] { '.' }).ToImmutableList()); - static public string StateTypeNameFromRootElmModule(string elmModuleText) - { - var match = Regex.Match( - elmModuleText, - "^" + ElmAppInterfaceConvention.ProcessSerializedEventFunctionName + - @"\s*:\s*String\s*->\s*([\w\d_]+)\s*->\s*\(\s*", - RegexOptions.Multiline); - - if (!match.Success) - throw new System.Exception("Did not find the expected type anotation for function " + ElmAppInterfaceConvention.ProcessSerializedEventFunctionName); - - return match.Groups[1].Value; - } - static public string InterfaceToHostRootModuleName => "Backend.InterfaceToHost_Root"; - static public IImmutableList InterfaceToHostRootModuleFilePathFromSourceFiles( - IImmutableDictionary, IImmutableList> sourceFiles) => - FilePathFromModuleName(InterfaceToHostRootModuleName); - - static public string InitialRootElmModuleText( - string rootModuleNameBeforeLowering, - string stateTypeNameInRootModuleBeforeLowering) => - $@" -module " + InterfaceToHostRootModuleName + $@" exposing - ( State - , interfaceToHost_deserializeState - , interfaceToHost_initState - , interfaceToHost_processEvent - , interfaceToHost_serializeState - , main - ) - -import " + rootModuleNameBeforeLowering + $@" -import Platform - -type alias DeserializedState = " + rootModuleNameBeforeLowering + "." + stateTypeNameInRootModuleBeforeLowering + $@" - - -type State - = DeserializeFailed String - | DeserializeSuccessful DeserializedState - - -interfaceToHost_initState = " + rootModuleNameBeforeLowering + $@".interfaceToHost_initState |> DeserializeSuccessful - - -interfaceToHost_processEvent hostEvent stateBefore = - case stateBefore of - DeserializeFailed _ -> - ( stateBefore, ""[]"" ) - - DeserializeSuccessful deserializedState -> - deserializedState - |> " + rootModuleNameBeforeLowering + $@".interfaceToHost_processEvent hostEvent - |> Tuple.mapFirst DeserializeSuccessful - - -interfaceToHost_serializeState = jsonEncodeState >> Json.Encode.encode 0 - - -interfaceToHost_deserializeState = deserializeState - - --- Support function-level dead code elimination (https://elm-lang.org/blog/small-assets-without-the-headache) Elm code needed to inform the Elm compiler about our entry points. - - -main : Program Int State String -main = - Platform.worker - {{ init = \_ -> ( interfaceToHost_initState, Cmd.none ) - , update = - \event stateBefore -> - interfaceToHost_processEvent event (stateBefore |> interfaceToHost_serializeState |> interfaceToHost_deserializeState) |> Tuple.mapSecond (always Cmd.none) - , subscriptions = \_ -> Sub.none - }} - - --- Inlined helpers --> - - -{{-| Turn a `Result e a` to an `a`, by applying the conversion -function specified to the `e`. --}} -result_Extra_Extract : (e -> a) -> Result e a -> a -result_Extra_Extract f x = - case x of - Ok a -> - a - - Err e -> - f e - - --- Remember and communicate errors from state deserialization --> - - -jsonEncodeState : State -> Json.Encode.Value -jsonEncodeState state = - case state of - DeserializeFailed error -> - [ ( ""Interface_DeserializeFailed"", [ ( ""error"", error |> Json.Encode.string ) ] |> Json.Encode.object ) ] |> Json.Encode.object - - DeserializeSuccessful deserializedState -> - deserializedState |> jsonEncodeDeserializedState - - -deserializeState : String -> State -deserializeState serializedState = - serializedState - |> Json.Decode.decodeString jsonDecodeState - |> Result.mapError Json.Decode.errorToString - |> result_Extra_Extract DeserializeFailed - - -jsonDecodeState : Json.Decode.Decoder State -jsonDecodeState = - Json.Decode.oneOf - [ Json.Decode.field ""Interface_DeserializeFailed"" (Json.Decode.field ""error"" Json.Decode.string |> Json.Decode.map DeserializeFailed) - , jsonDecodeDeserializedState |> Json.Decode.map DeserializeSuccessful - ] - -"; static Lazy jsEngineToCompileElmApp = new Lazy(PrepareJsEngineToCompileElmApp); static public JavaScriptEngineSwitcher.Core.IJsEngine PrepareJsEngineToCompileElmApp() diff --git a/implement/elm-fullstack/ElmFullstack/compile-elm-program/src/CompileFullstackApp.elm b/implement/elm-fullstack/ElmFullstack/compile-elm-program/src/CompileFullstackApp.elm index 33c19455..44064f46 100644 --- a/implement/elm-fullstack/ElmFullstack/compile-elm-program/src/CompileFullstackApp.elm +++ b/implement/elm-fullstack/ElmFullstack/compile-elm-program/src/CompileFullstackApp.elm @@ -74,6 +74,21 @@ elmAppInterfaceConvention = } +appStateMigrationInterfaceModuleName : String +appStateMigrationInterfaceModuleName = + "MigrateBackendState" + + +appStateMigrationRootModuleName : String +appStateMigrationRootModuleName = + appStateMigrationInterfaceModuleName ++ "Root" + + +appStateMigrationInterfaceFunctionName : String +appStateMigrationInterfaceFunctionName = + "migrate" + + type alias AppFiles = Dict.Dict (List String) Bytes.Bytes @@ -129,6 +144,7 @@ asCompletelyLoweredElmApp { sourceFiles, compilationInterfaceElmModuleNamePrefix , interfaceToHostRootModuleName = interfaceToHostRootModuleName } ) + |> Result.andThen (loweredForAppStateMigration { originalSourceModules = sourceModules }) loweredForSourceFiles : List String -> AppFiles -> Result String AppFiles @@ -186,91 +202,151 @@ loweredForAppStateSerializer : -> Result (List CompilationError) AppFiles loweredForAppStateSerializer { rootModuleName, interfaceToHostRootModuleName, originalSourceModules } sourceFiles = let - backendMainFilePath = - filePathFromElmModuleName (String.join "." rootModuleName) - interfaceToHostRootFilePath = filePathFromElmModuleName (String.join "." interfaceToHostRootModuleName) in - case Dict.get backendMainFilePath sourceFiles of + case Dict.get (String.join "." rootModuleName) originalSourceModules of Nothing -> -- App contains no backend. Ok sourceFiles - Just backendMainFile -> + Just backendMainModule -> if Dict.get interfaceToHostRootFilePath sourceFiles /= Nothing then -- Support integrating applications supplying their own lowered version. Ok sourceFiles else - case stringFromFileContent backendMainFile of - Nothing -> - Err [ OtherCompilationError "Failed to map file content to text" ] - - Just backendMainModuleText -> - parseAppStateElmTypeAndDependenciesRecursively originalSourceModules backendMainModuleText - |> Result.mapError ((++) "Failed to parse state type name: ") - |> Result.andThen - (\( stateTypeAnnotation, stateTypeDependencies ) -> - let - initialRootElmModuleText = - composeInitialRootElmModuleText - { interfaceToHostRootModuleName = String.join "." interfaceToHostRootModuleName - , rootModuleNameBeforeLowering = String.join "." rootModuleName - , stateTypeAnnotation = stateTypeAnnotation - } - in - mapAppFilesAndModuleTextToSupportJsonCoding + parseAppStateElmTypeAndDependenciesRecursively originalSourceModules backendMainModule + |> Result.mapError ((++) "Failed to parse state type name: ") + |> Result.map + (\( stateTypeAnnotation, stateTypeDependencies ) -> + let + ( appFiles, { generatedModuleName, modulesToImport } ) = + mapAppFilesToSupportJsonCoding + { generatedModuleNamePrefix = interfaceToHostRootModuleName } [ stateTypeAnnotation ] stateTypeDependencies - ( sourceFiles, initialRootElmModuleText ) - |> Result.map - (\( appFiles, interfaceModuleTextWithSupportingFunctions, generatedModuleName ) -> - let - functionsNamesInGeneratedModules = - buildJsonCodingFunctionsForTypeAnnotation stateTypeAnnotation - - encodeFunction = - "jsonEncodeDeserializedState =\n" - ++ indentElmCodeLines 1 - (generatedModuleName ++ "." ++ functionsNamesInGeneratedModules.encodeFunction.name) - - decodeFunction = - "jsonDecodeDeserializedState =\n" - ++ indentElmCodeLines 1 - (generatedModuleName ++ "." ++ functionsNamesInGeneratedModules.decodeFunction.name) - - interfaceModuleText = - [ interfaceModuleTextWithSupportingFunctions - , encodeFunction - , decodeFunction - ] - |> String.join "\n\n" - in - appFiles - |> updateFileContentAtPath - (always (fileContentFromString interfaceModuleText)) - interfaceToHostRootFilePath - ) - ) - |> Result.mapError (OtherCompilationError >> List.singleton) + sourceFiles + + functionsNamesInGeneratedModules = + buildJsonCodingFunctionsForTypeAnnotation stateTypeAnnotation + + encodeFunction = + "jsonEncodeDeserializedState =\n" + ++ indentElmCodeLines 1 + (generatedModuleName ++ "." ++ functionsNamesInGeneratedModules.encodeFunction.name) + + decodeFunction = + "jsonDecodeDeserializedState =\n" + ++ indentElmCodeLines 1 + (generatedModuleName ++ "." ++ functionsNamesInGeneratedModules.decodeFunction.name) + + rootElmModuleText = + composeAppRootElmModuleText + { interfaceToHostRootModuleName = String.join "." interfaceToHostRootModuleName + , rootModuleNameBeforeLowering = String.join "." rootModuleName + , stateTypeAnnotation = stateTypeAnnotation + , modulesToImport = modulesToImport + , encodeFunction = encodeFunction + , decodeFunction = decodeFunction + } + in + appFiles + |> updateFileContentAtPath + (always (fileContentFromString rootElmModuleText)) + interfaceToHostRootFilePath + ) + |> Result.mapError (OtherCompilationError >> List.singleton) -parseAppStateElmTypeAndDependenciesRecursively : Dict.Dict String Elm.Syntax.File.File -> String -> Result String ( ElmTypeAnnotation, Dict.Dict String ElmCustomTypeStruct ) -parseAppStateElmTypeAndDependenciesRecursively sourceModules moduleText = - case parseElmModuleText moduleText of +loweredForAppStateMigration : + { originalSourceModules : Dict.Dict String Elm.Syntax.File.File } + -> AppFiles + -> Result (List CompilationError) AppFiles +loweredForAppStateMigration { originalSourceModules } sourceFiles = + let + interfaceToHostRootFilePath = + filePathFromElmModuleName appStateMigrationRootModuleName + in + case Dict.get appStateMigrationInterfaceModuleName originalSourceModules of + Nothing -> + -- App contains no migrate module. + Ok sourceFiles + + Just originalInterfaceModule -> + if Dict.get interfaceToHostRootFilePath sourceFiles /= Nothing then + -- Support integrating applications supplying their own lowered version. + Ok sourceFiles + + else + parseAppStateMigrateElmTypeAndDependenciesRecursively originalSourceModules originalInterfaceModule + |> Result.mapError ((++) "Failed to parse state type name: ") + |> Result.map + (\( ( inputType, returnType ), stateTypeDependencies ) -> + let + ( appFiles, { generatedModuleName, modulesToImport } ) = + mapAppFilesToSupportJsonCoding + { generatedModuleNamePrefix = String.split "." appStateMigrationRootModuleName } + [ inputType, returnType ] + stateTypeDependencies + sourceFiles + + inputTypeNamesInGeneratedModules = + buildJsonCodingFunctionsForTypeAnnotation inputType + + returnTypeNamesInGeneratedModules = + buildJsonCodingFunctionsForTypeAnnotation returnType + + rootElmModuleText = + composeStateMigrationModuleText + { generatedModuleName = generatedModuleName + , decodeOrigTypeFunctionName = inputTypeNamesInGeneratedModules.decodeFunction.name + , encodeDestTypeFunctionName = returnTypeNamesInGeneratedModules.encodeFunction.name + , modulesToImport = modulesToImport + } + in + appFiles + |> updateFileContentAtPath + (always (fileContentFromString rootElmModuleText)) + interfaceToHostRootFilePath + ) + |> Result.mapError (OtherCompilationError >> List.singleton) + + +parseAppStateElmTypeAndDependenciesRecursively : Dict.Dict String Elm.Syntax.File.File -> Elm.Syntax.File.File -> Result String ( ElmTypeAnnotation, Dict.Dict String ElmCustomTypeStruct ) +parseAppStateElmTypeAndDependenciesRecursively sourceModules parsedModule = + case stateTypeAnnotationFromRootElmModule parsedModule of Err error -> - Err ("Failed to parse Elm module text: " ++ parserDeadEndsToString moduleText error) + Err ("Did not find state type annotation: " ++ error) - Ok parsedModule -> - case stateTypeAnnotationFromRootElmModule parsedModule of - Err error -> - Err ("Did not find state type annotation: " ++ error) + Ok stateTypeAnnotation -> + parseElmTypeAndDependenciesRecursivelyFromAnnotation + sourceModules + ( parsedModule, stateTypeAnnotation ) + + +parseAppStateMigrateElmTypeAndDependenciesRecursively : Dict.Dict String Elm.Syntax.File.File -> Elm.Syntax.File.File -> Result String ( ( ElmTypeAnnotation, ElmTypeAnnotation ), Dict.Dict String ElmCustomTypeStruct ) +parseAppStateMigrateElmTypeAndDependenciesRecursively sourceModules parsedModule = + case migrateStateTypeAnnotationFromElmModule parsedModule of + Err error -> + Err ("Did not find state type annotation: " ++ error) - Ok stateTypeAnnotation -> - parseElmTypeAndDependenciesRecursivelyFromAnnotation - sourceModules - ( parsedModule, stateTypeAnnotation ) + Ok ( originType, destinationType ) -> + parseElmTypeAndDependenciesRecursivelyFromAnnotation + sourceModules + ( parsedModule, originType ) + |> Result.andThen + (\( originTypeAnnotation, originTypeDependencies ) -> + parseElmTypeAndDependenciesRecursivelyFromAnnotation + sourceModules + ( parsedModule, destinationType ) + |> Result.map + (\( destinationTypeAnnotation, destinationTypeDependencies ) -> + ( ( originTypeAnnotation, destinationTypeAnnotation ) + , originTypeDependencies |> Dict.union destinationTypeDependencies + ) + ) + ) stateTypeAnnotationFromRootElmModule : Elm.Syntax.File.File -> Result String Elm.Syntax.TypeAnnotation.TypeAnnotation @@ -315,13 +391,58 @@ stateTypeAnnotationFromRootElmModule parsedModule = |> Maybe.withDefault (Err "Did not find function with matching name") -composeInitialRootElmModuleText : +migrateStateTypeAnnotationFromElmModule : Elm.Syntax.File.File -> Result String ( Elm.Syntax.TypeAnnotation.TypeAnnotation, Elm.Syntax.TypeAnnotation.TypeAnnotation ) +migrateStateTypeAnnotationFromElmModule parsedModule = + parsedModule.declarations + |> List.filterMap + (\declaration -> + case Elm.Syntax.Node.value declaration of + Elm.Syntax.Declaration.FunctionDeclaration functionDeclaration -> + if + Elm.Syntax.Node.value (Elm.Syntax.Node.value functionDeclaration.declaration).name + == appStateMigrationInterfaceFunctionName + then + Just functionDeclaration + + else + Nothing + + _ -> + Nothing + ) + |> List.head + |> Maybe.map + (\functionDeclaration -> + case functionDeclaration.signature of + Nothing -> + Err "Missing function signature" + + Just functionSignature -> + case Elm.Syntax.Node.value (Elm.Syntax.Node.value functionSignature).typeAnnotation of + Elm.Syntax.TypeAnnotation.FunctionTypeAnnotation inputType returnType -> + case Elm.Syntax.Node.value returnType of + Elm.Syntax.TypeAnnotation.FunctionTypeAnnotation _ _ -> + Err "Too many parameters." + + _ -> + Ok ( Elm.Syntax.Node.value inputType, Elm.Syntax.Node.value returnType ) + + _ -> + Err "Unexpected type annotation" + ) + |> Maybe.withDefault (Err "Did not find function with matching name") + + +composeAppRootElmModuleText : { interfaceToHostRootModuleName : String , rootModuleNameBeforeLowering : String , stateTypeAnnotation : ElmTypeAnnotation + , modulesToImport : List (List String) + , encodeFunction : String + , decodeFunction : String } -> String -composeInitialRootElmModuleText { interfaceToHostRootModuleName, rootModuleNameBeforeLowering, stateTypeAnnotation } = +composeAppRootElmModuleText { interfaceToHostRootModuleName, rootModuleNameBeforeLowering, stateTypeAnnotation, modulesToImport, encodeFunction, decodeFunction } = "module " ++ interfaceToHostRootModuleName ++ """ exposing ( State , interfaceToHost_deserializeState @@ -332,6 +453,7 @@ composeInitialRootElmModuleText { interfaceToHostRootModuleName, rootModuleNameB ) import """ ++ rootModuleNameBeforeLowering ++ """ +""" ++ (modulesToImport |> List.map (String.join "." >> (++) "import ") |> String.join "\n") ++ """ import Platform type alias DeserializedState = @@ -421,6 +543,60 @@ jsonDecodeState = , jsonDecodeDeserializedState |> Json.Decode.map DeserializeSuccessful ] +""" ++ encodeFunction ++ "\n\n" ++ decodeFunction + + +composeStateMigrationModuleText : + { generatedModuleName : String + , decodeOrigTypeFunctionName : String + , encodeDestTypeFunctionName : String + , modulesToImport : List (List String) + } + -> String +composeStateMigrationModuleText { generatedModuleName, decodeOrigTypeFunctionName, encodeDestTypeFunctionName, modulesToImport } = + String.trimLeft """ +module """ ++ appStateMigrationRootModuleName ++ """ exposing (decodeMigrateAndEncodeAndSerializeResult, main) + +import """ ++ appStateMigrationInterfaceModuleName ++ """ +import """ ++ generatedModuleName ++ """ +""" ++ (modulesToImport |> List.map (String.join "." >> (++) "import ") |> String.join "\n") ++ """ +import Json.Decode +import Json.Encode + + +decodeMigrateAndEncode : String -> Result String String +decodeMigrateAndEncode = + Json.Decode.decodeString """ ++ generatedModuleName ++ "." ++ decodeOrigTypeFunctionName ++ """ + >> Result.map (""" ++ appStateMigrationInterfaceModuleName ++ "." ++ appStateMigrationInterfaceFunctionName ++ """ >> """ ++ generatedModuleName ++ "." ++ encodeDestTypeFunctionName ++ """ >> Json.Encode.encode 0) + >> Result.mapError Json.Decode.errorToString + + +decodeMigrateAndEncodeAndSerializeResult : String -> String +decodeMigrateAndEncodeAndSerializeResult = + decodeMigrateAndEncode + >> jsonEncodeResult Json.Encode.string Json.Encode.string + >> Json.Encode.encode 0 + + +jsonEncodeResult : (err -> Json.Encode.Value) -> (ok -> Json.Encode.Value) -> Result err ok -> Json.Encode.Value +jsonEncodeResult encodeErr encodeOk valueToEncode = + case valueToEncode of + Err valueToEncodeError -> + [ ( "Err", [ valueToEncodeError ] |> Json.Encode.list encodeErr ) ] |> Json.Encode.object + + Ok valueToEncodeOk -> + [ ( "Ok", [ valueToEncodeOk ] |> Json.Encode.list encodeOk ) ] |> Json.Encode.object + + +main : Program Int {} String +main = + Platform.worker + { init = \\_ -> ( {}, Cmd.none ) + , update = + \\_ _ -> + ( decodeMigrateAndEncodeAndSerializeResult |> always {}, Cmd.none ) + , subscriptions = \\_ -> Sub.none + } """ @@ -450,6 +626,10 @@ mapJsonCodersModuleText { originalSourceModules } ( sourceFiles, moduleText ) = Err ("Failed to parse Elm module text: " ++ parserDeadEndsToString moduleText error) Ok parsedModule -> + let + interfaceModuleName = + Elm.Syntax.Module.moduleName (Elm.Syntax.Node.value parsedModule.moduleDefinition) + in parsedModule.declarations -- TODO: Also share the 'map all functions' part with `mapSourceFilesModuleText` |> List.filterMap @@ -498,163 +678,160 @@ mapJsonCodersModuleText { originalSourceModules } ( sourceFiles, moduleText ) = |> Result.Extra.combine |> Result.andThen (\functionsToReplace -> - mapAppFilesAndModuleTextToSupportJsonCoding - (functionsToReplace |> List.map .parsedTypeAnnotation) - (functionsToReplace |> List.map .dependencies |> List.foldl Dict.union Dict.empty) - ( sourceFiles, moduleText ) - |> Result.andThen - (\( appFiles, interfaceModuleText, generatedModuleName ) -> - functionsToReplace - |> listFoldlToAggregateResult - (\functionToReplace previousModuleText -> - let - functionName = - functionToReplace.functionName - - functionsNamesInGeneratedModules = - buildJsonCodingFunctionsForTypeAnnotation functionToReplace.parsedTypeAnnotation - - newFunction = - functionName - ++ " =\n " - ++ generatedModuleName - ++ "." - ++ (if functionToReplace.functionType.isDecoder then - functionsNamesInGeneratedModules.decodeFunction.name - - else - functionsNamesInGeneratedModules.encodeFunction.name - ) - - mapFunctionDeclarationLines originalFunctionTextLines = - [ originalFunctionTextLines |> List.take 1 - , [ newFunction ] - ] - |> List.concat - in - addOrUpdateFunctionInElmModuleText - { functionName = functionName - , mapFunctionLines = Maybe.withDefault [] >> mapFunctionDeclarationLines - } - previousModuleText - |> Result.mapError ((++) "Failed to replace function text: ") - ) - (Ok interfaceModuleText) - |> Result.map (Tuple.pair appFiles) + let + ( appFiles, { generatedModuleName, modulesToImport } ) = + mapAppFilesToSupportJsonCoding + { generatedModuleNamePrefix = interfaceModuleName } + (functionsToReplace |> List.map .parsedTypeAnnotation) + (functionsToReplace |> List.map .dependencies |> List.foldl Dict.union Dict.empty) + sourceFiles + in + functionsToReplace + |> listFoldlToAggregateResult + (\functionToReplace previousModuleText -> + let + functionName = + functionToReplace.functionName + + functionsNamesInGeneratedModules = + buildJsonCodingFunctionsForTypeAnnotation functionToReplace.parsedTypeAnnotation + + newFunction = + functionName + ++ " =\n " + ++ generatedModuleName + ++ "." + ++ (if functionToReplace.functionType.isDecoder then + functionsNamesInGeneratedModules.decodeFunction.name + + else + functionsNamesInGeneratedModules.encodeFunction.name + ) + + mapFunctionDeclarationLines originalFunctionTextLines = + [ originalFunctionTextLines |> List.take 1 + , [ newFunction ] + ] + |> List.concat + in + addOrUpdateFunctionInElmModuleText + { functionName = functionName + , mapFunctionLines = Maybe.withDefault [] >> mapFunctionDeclarationLines + } + previousModuleText + |> Result.mapError ((++) "Failed to replace function text: ") ) + (addImportsInElmModuleText + modulesToImport + moduleText + ) + |> Result.map (Tuple.pair appFiles) ) -mapAppFilesAndModuleTextToSupportJsonCoding : - List ElmTypeAnnotation +mapAppFilesToSupportJsonCoding : + { generatedModuleNamePrefix : List String } + -> List ElmTypeAnnotation -> Dict.Dict String ElmCustomTypeStruct - -> ( AppFiles, String ) - -> Result String ( AppFiles, String, String ) -mapAppFilesAndModuleTextToSupportJsonCoding typeAnnotationsBeforeDeduplicating customTypes ( appFilesBefore, moduleText ) = - case parseElmModuleText moduleText of - Err error -> - Err ("Failed to parse Elm module text: " ++ parserDeadEndsToString moduleText error) - - Ok parsedModule -> - let - interfaceModuleName = - Elm.Syntax.Module.moduleName (Elm.Syntax.Node.value parsedModule.moduleDefinition) + -> AppFiles + -> ( AppFiles, { generatedModuleName : String, modulesToImport : List (List String) } ) +mapAppFilesToSupportJsonCoding { generatedModuleNamePrefix } typeAnnotationsBeforeDeduplicating customTypes appFilesBefore = + let + modulesToImportForCustomTypes = + customTypes + |> Dict.keys + |> List.map moduleNameFromTypeName + |> Set.fromList + |> Set.toList + |> List.map (String.split ".") + + modulesToImport = + [ [ "Base64" ] + , [ "Dict" ] + , [ "Set" ] + , [ "Json", "Decode" ] + , [ "Json", "Encode" ] + , [ "Bytes" ] + , [ "Bytes", "Decode" ] + , [ "Bytes", "Encode" ] + ] + ++ modulesToImportForCustomTypes + + appFilesAfterExposingCustomTypesInModules = + modulesToImportForCustomTypes + |> List.foldl exposeAllInElmModuleInAppFiles appFilesBefore + + typeAnnotationsFunctions = + typeAnnotationsBeforeDeduplicating + |> listRemoveDuplicates + |> List.map buildJsonCodingFunctionsForTypeAnnotation + + typeAnnotationsFunctionsForGeneratedModule = + typeAnnotationsFunctions + |> List.concatMap + (\functionsForType -> + [ functionsForType.encodeFunction, functionsForType.decodeFunction ] + ) + |> List.map (\function -> { functionName = function.name, functionText = function.text }) - modulesToImportForCustomTypes = - customTypes - |> Dict.keys - |> List.map moduleNameFromTypeName - |> Set.fromList - |> Set.toList - |> List.map (String.split ".") - - modulesToImport = - [ [ "Base64" ] - , [ "Dict" ] - , [ "Set" ] - , [ "Json", "Decode" ] - , [ "Json", "Encode" ] - , [ "Bytes" ] - , [ "Bytes", "Decode" ] - , [ "Bytes", "Encode" ] - ] - ++ modulesToImportForCustomTypes - |> List.filter ((==) interfaceModuleName >> not) - - appFilesAfterExposingCustomTypesInModules = - modulesToImportForCustomTypes - |> List.foldl exposeAllInElmModuleInAppFiles appFilesBefore - - typeAnnotationsFunctions = - typeAnnotationsBeforeDeduplicating - |> listRemoveDuplicates - |> List.map buildJsonCodingFunctionsForTypeAnnotation - - typeAnnotationsFunctionsForGeneratedModule = - typeAnnotationsFunctions - |> List.concatMap - (\functionsForType -> - [ functionsForType.encodeFunction, functionsForType.decodeFunction ] - ) - |> List.map (\function -> { functionName = function.name, functionText = function.text }) - - dependenciesFunctions = - customTypes - |> Dict.toList - |> List.map - (\( customTypeName, customType ) -> - jsonCodingFunctionFromCustomType - { customTypeName = customTypeName - , encodeValueExpression = jsonEncodeParamName - , typeArgLocalName = "type_arg" - } - customType - ) - |> List.concatMap - (\functionsForType -> - [ functionsForType.encodeFunction, functionsForType.decodeFunction ] - ) - |> List.map (\function -> { functionName = function.name, functionText = function.text }) + dependenciesFunctions = + customTypes + |> Dict.toList + |> List.map + (\( customTypeName, customType ) -> + jsonCodingFunctionFromCustomType + { customTypeName = customTypeName + , encodeValueExpression = jsonEncodeParamName + , typeArgLocalName = "type_arg" + } + customType + ) + |> List.concatMap + (\functionsForType -> + [ functionsForType.encodeFunction, functionsForType.decodeFunction ] + ) + |> List.map (\function -> { functionName = function.name, functionText = function.text }) - functionsForGeneratedModule = - typeAnnotationsFunctionsForGeneratedModule ++ dependenciesFunctions ++ generalSupportingFunctionsTexts + functionsForGeneratedModule = + typeAnnotationsFunctionsForGeneratedModule ++ dependenciesFunctions ++ generalSupportingFunctionsTexts - generatedModuleTextWithoutModuleDeclaration = - [ modulesToImport |> List.map (String.join "." >> (++) "import ") - , functionsForGeneratedModule |> List.map .functionText - ] - |> List.concat - |> String.join "\n\n" + generatedModuleTextWithoutModuleDeclaration = + [ modulesToImport |> List.map (String.join "." >> (++) "import ") + , functionsForGeneratedModule |> List.map .functionText + ] + |> List.concat + |> String.join "\n\n" - generatedModuleHash = - generatedModuleTextWithoutModuleDeclaration - |> SHA256.fromString - |> SHA256.toHex + generatedModuleHash = + generatedModuleTextWithoutModuleDeclaration + |> SHA256.fromString + |> SHA256.toHex - generatedModuleName = - (interfaceModuleName |> String.join ".") - ++ ".Generated_" - ++ String.left 8 generatedModuleHash + generatedModuleName = + (generatedModuleNamePrefix |> String.join ".") + ++ ".Generated_" + ++ String.left 8 generatedModuleHash - generatedModulePath = - filePathFromElmModuleName generatedModuleName + generatedModulePath = + filePathFromElmModuleName generatedModuleName - generatedModuleText = - [ "module " ++ generatedModuleName ++ " exposing (..)" - , generatedModuleTextWithoutModuleDeclaration - ] - |> String.join "\n\n" + generatedModuleText = + [ "module " ++ generatedModuleName ++ " exposing (..)" + , generatedModuleTextWithoutModuleDeclaration + ] + |> String.join "\n\n" - appFiles = - appFilesAfterExposingCustomTypesInModules - |> updateFileContentAtPath - (always (fileContentFromString generatedModuleText)) - generatedModulePath - in - addImportsInElmModuleText - ([ String.split "." generatedModuleName ] ++ modulesToImport) - moduleText - |> Result.map (\moduleTextWithImport -> ( appFiles, moduleTextWithImport, generatedModuleName )) + appFiles = + appFilesAfterExposingCustomTypesInModules + |> updateFileContentAtPath + (always (fileContentFromString generatedModuleText)) + generatedModulePath + in + ( appFiles + , { generatedModuleName = generatedModuleName + , modulesToImport = String.split "." generatedModuleName :: modulesToImport + } + ) buildJsonCodingFunctionsForTypeAnnotation : @@ -2612,11 +2789,6 @@ parserProblemToString p = "bad repeat" -stringStartsWithLowercaseLetter : String -> Bool -stringStartsWithLowercaseLetter = - String.toList >> List.head >> Maybe.map Char.isLower >> Maybe.withDefault False - - listFoldlToAggregateResult : (a -> b -> Result e b) -> Result e b -> List a -> Result e b listFoldlToAggregateResult getElementResult = List.foldl diff --git a/implement/elm-fullstack/ElmFullstack/compile-elm-program/tests/Tests.elm b/implement/elm-fullstack/ElmFullstack/compile-elm-program/tests/Tests.elm index b7192862..d620fea1 100644 --- a/implement/elm-fullstack/ElmFullstack/compile-elm-program/tests/Tests.elm +++ b/implement/elm-fullstack/ElmFullstack/compile-elm-program/tests/Tests.elm @@ -130,16 +130,33 @@ interfaceToHost_processEvent = (\( testName, moduleText, expectedResult ) -> Test.test testName <| \() -> - let - sourceModules = - [ moduleText ] - |> CompileFullstackApp.elmModulesDictFromFilesTexts - |> Dict.map (always Tuple.second) - in - CompileFullstackApp.parseAppStateElmTypeAndDependenciesRecursively - sourceModules - moduleText - |> Expect.equal expectedResult + moduleText + |> CompileFullstackApp.parseElmModuleText + |> Result.mapError + (\error -> + "Failed to parse supporting module '" + ++ (moduleText + |> String.lines + |> List.head + |> Maybe.withDefault "???" + ) + ++ "': " + ++ CompileFullstackApp.parserDeadEndsToString moduleText error + ) + |> Result.map + (\parsedModule -> + let + sourceModules = + [ moduleText ] + |> CompileFullstackApp.elmModulesDictFromFilesTexts + |> Dict.map (always Tuple.second) + in + CompileFullstackApp.parseAppStateElmTypeAndDependenciesRecursively + sourceModules + parsedModule + |> Expect.equal expectedResult + ) + |> Result.Extra.unpack Expect.fail identity ) |> Test.describe "state type name from root Elm module" diff --git a/implement/elm-fullstack/Program.cs b/implement/elm-fullstack/Program.cs index bcbe7d9c..9e97f327 100644 --- a/implement/elm-fullstack/Program.cs +++ b/implement/elm-fullstack/Program.cs @@ -398,8 +398,6 @@ static int Main(string[] args) ElmFullstack.WebHost.PersistentProcess.PersistentProcessVolatileRepresentation.TreeToFlatDictionaryWithPathComparer( loadFromPathResult.Ok.tree); - var compilationLog = new List(); - string compilationException = null; Composition.TreeWithStringPath compiledTree = null; @@ -407,8 +405,7 @@ static int Main(string[] args) { var loweredAppFiles = ElmFullstack.ElmApp.AsCompletelyLoweredElmApp( sourceFiles: sourceFiles, - ElmFullstack.ElmAppInterfaceConfig.Default, - compilationLog.Add); + ElmFullstack.ElmAppInterfaceConfig.Default); compiledTree = Composition.SortedTreeFromSetOfBlobsWithStringPath(loweredAppFiles); @@ -455,7 +452,6 @@ static int Main(string[] args) sourceCompositionId = sourceCompositionId, sourceSummary = sourceSummary, compilationException = compilationException, - compilationLog = compilationLog.ToImmutableList(), compilationTimeSpentMilli = (int)compilationTimeSpentMilli, compiledCompositionId = compiledCompositionId, }; diff --git a/implement/elm-fullstack/WebHost/PersistentProcessVolatileRepresentation.cs b/implement/elm-fullstack/WebHost/PersistentProcessVolatileRepresentation.cs index 8cfa5620..24e401c2 100644 --- a/implement/elm-fullstack/WebHost/PersistentProcessVolatileRepresentation.cs +++ b/implement/elm-fullstack/WebHost/PersistentProcessVolatileRepresentation.cs @@ -80,27 +80,23 @@ public struct CompositionEventWithLoadedDependencies } static public (IDisposableProcessWithStringInterface process, - (string javascriptFromElmMake, string javascriptPreparedToRun) buildArtifacts, - IReadOnlyList log) + (string javascriptFromElmMake, string javascriptPreparedToRun) buildArtifacts) ProcessFromWebAppConfig( Composition.TreeWithStringPath appConfig, ElmAppInterfaceConfig? overrideElmAppInterfaceConfig = null) { - var log = new List(); - var sourceFiles = TreeToFlatDictionaryWithPathComparer(appConfig); var loweredAppFiles = ElmApp.AsCompletelyLoweredElmApp( sourceFiles: sourceFiles, - ElmAppInterfaceConfig.Default, - log.Add); + ElmAppInterfaceConfig.Default); var processFromLoweredElmApp = ProcessFromElm019Code.ProcessFromElmCodeFiles( loweredAppFiles, overrideElmAppInterfaceConfig: overrideElmAppInterfaceConfig); - return (processFromLoweredElmApp.process, processFromLoweredElmApp.buildArtifacts, log); + return (processFromLoweredElmApp.process, processFromLoweredElmApp.buildArtifacts); } static public IImmutableDictionary, IImmutableList> TreeToFlatDictionaryWithPathComparer( @@ -271,7 +267,7 @@ static public PersistentProcessVolatileRepresentation RestoreFromCompositionEven if (compositionLogRecord.reduction != null) { - var (newElmAppProcess, (javascriptFromElmMake, javascriptPreparedToRun), _) = + var (newElmAppProcess, (javascriptFromElmMake, javascriptPreparedToRun)) = ProcessFromWebAppConfig( compositionLogRecord.reduction.Value.appConfigAsTree, overrideElmAppInterfaceConfig: overrideElmAppInterfaceConfig); @@ -410,7 +406,7 @@ static PersistentProcessVolatileRepresentationDuringRestore ApplyCompositionEven var prepareMigrateResult = PrepareMigrateSerializedValue(destinationAppConfigTree: appConfig); - var (newElmAppProcess, buildArtifacts, _) = + var (newElmAppProcess, buildArtifacts) = ProcessFromWebAppConfig( appConfig, overrideElmAppInterfaceConfig: overrideElmAppInterfaceConfig); @@ -453,7 +449,7 @@ static PersistentProcessVolatileRepresentationDuringRestore ApplyCompositionEven { var appConfig = compositionEvent.DeployAppConfigAndInitElmAppState; - var (newElmAppProcess, buildArtifacts, _) = + var (newElmAppProcess, buildArtifacts) = ProcessFromWebAppConfig( appConfig, overrideElmAppInterfaceConfig: overrideElmAppInterfaceConfig); @@ -586,129 +582,17 @@ static Result>> PrepareMigrateSerial var pathToInterfaceModuleFile = ElmApp.FilePathFromModuleName(MigrationElmAppInterfaceModuleName); var pathToCompilationRootModuleFile = ElmApp.FilePathFromModuleName(MigrationElmAppCompilationRootModuleName); - appConfigFiles.TryGetValue(pathToInterfaceModuleFile, out var migrateElmAppInterfaceModuleOriginalFile); - - if (migrateElmAppInterfaceModuleOriginalFile == null) + if (!appConfigFiles.TryGetValue(pathToInterfaceModuleFile, out var _)) return new Result>> { Err = "Did not find interface module at '" + string.Join("/", pathToInterfaceModuleFile) + "'", }; - var migrateElmAppInterfaceModuleOriginalText = - Encoding.UTF8.GetString(migrateElmAppInterfaceModuleOriginalFile.ToArray()); - - var migrateFunctionTypeAnnotation = - CompileElm.TypeAnnotationFromFunctionName(MigrateElmFunctionNameInModule, migrateElmAppInterfaceModuleOriginalText); - - if (migrateFunctionTypeAnnotation == null) - return new Result>> - { - Err = "Did not find type annotation for function '" + MigrateElmFunctionNameInModule + "'" - }; - - var typeAnnotationMatch = Regex.Match(migrateFunctionTypeAnnotation, @"^\s*([\w\d_\.]+)\s*->\s*([\w\d_\.]+)\s*$"); - - if (!typeAnnotationMatch.Success) - return new Result>> - { - Err = "Type annotation did not match expected pattern: '" + migrateFunctionTypeAnnotation + "'" - }; - - var inputTypeText = typeAnnotationMatch.Groups[1].Value; - var returnTypeText = typeAnnotationMatch.Groups[2].Value; - - var inputTypeCanonicalName = - inputTypeText.Contains(".") ? - inputTypeText : - MigrationElmAppInterfaceModuleName + "." + inputTypeText; - - var returnTypeCanonicalName = - returnTypeText.Contains(".") ? - returnTypeText : - MigrationElmAppInterfaceModuleName + "." + returnTypeText; - - var compilationRootModuleInitialText = @" -module " + MigrationElmAppCompilationRootModuleName + @" exposing(decodeMigrateAndEncodeAndSerializeResult, main) - -import " + MigrationElmAppInterfaceModuleName + @" -import Json.Decode -import Json.Encode - - -decodeMigrateAndEncode : String -> Result String String -decodeMigrateAndEncode = - Json.Decode.decodeString jsonDecodeBackendState - >> Result.map (" + MigrationElmAppInterfaceModuleName + "." + MigrateElmFunctionNameInModule + @" >> jsonEncodeBackendState >> Json.Encode.encode 0) - >> Result.mapError Json.Decode.errorToString - - -decodeMigrateAndEncodeAndSerializeResult : String -> String -decodeMigrateAndEncodeAndSerializeResult = - decodeMigrateAndEncode - >> jsonEncodeResult Json.Encode.string Json.Encode.string - >> Json.Encode.encode 0 - - -jsonEncodeResult : (err -> Json.Encode.Value) -> (ok -> Json.Encode.Value) -> Result err ok -> Json.Encode.Value -jsonEncodeResult encodeErr encodeOk valueToEncode = - case valueToEncode of - Err valueToEncodeError -> - [ ( ""Err"", [ valueToEncodeError ] |> Json.Encode.list encodeErr ) ] |> Json.Encode.object - - Ok valueToEncodeOk -> - [ ( ""Ok"", [ valueToEncodeOk ] |> Json.Encode.list encodeOk ) ] |> Json.Encode.object - - -main : Program Int {} String -main = - Platform.worker - { init = \_ -> ( {}, Cmd.none ) - , update = - \_ _ -> - ( decodeMigrateAndEncodeAndSerializeResult |> always {}, Cmd.none ) - , subscriptions = \_ -> Sub.none - } -"; - var compileCodingFunctionsLogLines = new System.Collections.Generic.List(); - try { - var migrateElmAppFilesBeforeAddingCodingSupport = - appConfigFiles.SetItem( - pathToCompilationRootModuleFile, - Encoding.UTF8.GetBytes(compilationRootModuleInitialText).ToImmutableList()); - - var appFilesWithInputCodingFunctions = - ElmApp.WithSupportForCodingElmType( - migrateElmAppFilesBeforeAddingCodingSupport, - inputTypeCanonicalName, - MigrationElmAppCompilationRootModuleName, - compileCodingFunctionsLogLines.Add, - out var inputTypeFunctionNames); - - var appFilesWithCodingFunctions = - ElmApp.WithSupportForCodingElmType( - appFilesWithInputCodingFunctions, - returnTypeCanonicalName, - MigrationElmAppCompilationRootModuleName, - compileCodingFunctionsLogLines.Add, - out var returnTypeFunctionNames); - - var rootModuleTextWithSupportAdded = - Encoding.UTF8.GetString(appFilesWithCodingFunctions[pathToCompilationRootModuleFile].ToArray()); - - var rootModuleText = - new[] - { - "jsonDecodeBackendState = " + inputTypeFunctionNames.decodeFunctionName, - "jsonEncodeBackendState = " + returnTypeFunctionNames.encodeFunctionName - } - .Aggregate(rootModuleTextWithSupportAdded, (intermediateModuleText, functionToAdd) => - CompileElm.WithFunctionAdded(intermediateModuleText, functionToAdd)); - - var migrateElmAppFiles = appFilesWithCodingFunctions.SetItem( - pathToCompilationRootModuleFile, - Encoding.UTF8.GetBytes(rootModuleText).ToImmutableList()); + var migrateElmAppFiles = ElmApp.AsCompletelyLoweredElmApp( + sourceFiles: appConfigFiles, + interfaceConfig: ElmAppInterfaceConfig.Default); var javascriptFromElmMake = ElmFullstack.ProcessFromElm019Code.CompileElmToJavascript( migrateElmAppFiles, @@ -783,7 +667,7 @@ Ok valueToEncodeOk -> { return new Result>> { - Err = "Failed with exception:\n" + e.ToString() + "\ncompileCodingFunctionsLogLines:\n" + String.Join("\n", compileCodingFunctionsLogLines) + Err = "Failed with exception:\n" + e.ToString() }; } } diff --git a/implement/test-elm-fullstack/TestModeledInElm.cs b/implement/test-elm-fullstack/TestModeledInElm.cs index ec794d61..d4b5e450 100644 --- a/implement/test-elm-fullstack/TestModeledInElm.cs +++ b/implement/test-elm-fullstack/TestModeledInElm.cs @@ -23,8 +23,7 @@ static IImmutableDictionary, IImmutableList> GetLow return ElmFullstack.ElmApp.AsCompletelyLoweredElmApp( sourceFiles: TestSetup.GetElmAppFromDirectoryPath(directoryPath), - ElmAppInterfaceConfig.Default, - Console.WriteLine); + ElmAppInterfaceConfig.Default); } /* diff --git a/implement/test-elm-fullstack/TestSetup.cs b/implement/test-elm-fullstack/TestSetup.cs index 17203272..81ca36fa 100644 --- a/implement/test-elm-fullstack/TestSetup.cs +++ b/implement/test-elm-fullstack/TestSetup.cs @@ -97,8 +97,7 @@ static public IImmutableDictionary, IImmutableList> IImmutableDictionary, IImmutableList> originalAppFiles) => ElmApp.AsCompletelyLoweredElmApp( sourceFiles: originalAppFiles, - ElmAppInterfaceConfig.Default, - Console.WriteLine); + ElmAppInterfaceConfig.Default); static public IProcessStoreReader EmptyProcessStoreReader() => new ProcessStoreReaderFromDelegates