diff --git a/ConsumePlugin/GeneratedJson.fs b/ConsumePlugin/GeneratedJson.fs index 3172f20..ed1eb16 100644 --- a/ConsumePlugin/GeneratedJson.fs +++ b/ConsumePlugin/GeneratedJson.fs @@ -24,15 +24,24 @@ namespace ConsumePlugin module JsonRecordType = /// Parse from a JSON node. let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JsonRecordType = + let F = + node.["f"].AsArray () + |> Seq.map (fun elt -> elt.AsValue().GetValue ()) + |> Array.ofSeq + + let E = + node.["e"].AsArray () + |> Seq.map (fun elt -> elt.AsValue().GetValue ()) + |> Array.ofSeq + let D = InnerType.jsonParse node.["d"] let C = node.["hi"].AsArray () - |> Seq.map (fun elt -> elt.GetValue ()) + |> Seq.map (fun elt -> elt.AsValue().GetValue ()) |> List.ofSeq - let B2 = node.["another-thing"].AsValue () - let B = B2.GetValue () + let B = node.["another-thing"].AsValue().GetValue () let A = node.["a"].AsValue().GetValue () { @@ -40,4 +49,6 @@ module JsonRecordType = B = B C = C D = D + E = E + F = F } diff --git a/ConsumePlugin/JsonRecord.fs b/ConsumePlugin/JsonRecord.fs index ef3d988..6cf041a 100644 --- a/ConsumePlugin/JsonRecord.fs +++ b/ConsumePlugin/JsonRecord.fs @@ -25,4 +25,6 @@ type JsonRecordType = [] C : int list D : InnerType + E : string array + F : int[] } diff --git a/MyriadPlugin.Test/TestJsonParse.fs b/MyriadPlugin.Test/TestJsonParse.fs index 80b2170..376b837 100644 --- a/MyriadPlugin.Test/TestJsonParse.fs +++ b/MyriadPlugin.Test/TestJsonParse.fs @@ -12,7 +12,8 @@ module TestJsonParse = let s = """ { - "a": 3, "another-thing": "hello", "hi": [6, 1], "d": {"something": "oh hi"} + "a": 3, "another-thing": "hello", "hi": [6, 1], "d": {"something": "oh hi"}, + "e": ["something", "else"], "f": [] } """ @@ -25,6 +26,8 @@ module TestJsonParse = { Thing = "oh hi" } + E = [| "something" ; "else" |] + F = [||] } let actual = s |> JsonNode.Parse |> JsonRecordType.jsonParse diff --git a/MyriadPlugin/AstHelper.fs b/MyriadPlugin/AstHelper.fs index 59dea49..6a18733 100644 --- a/MyriadPlugin/AstHelper.fs +++ b/MyriadPlugin/AstHelper.fs @@ -62,6 +62,19 @@ module internal AstHelper = // TODO: consider FSharpList or whatever it is | _ -> false + let isArrayIdent (ident : SynLongIdent) : bool = + match ident.LongIdent with + | [ i ] when + System.String.Equals (i.idText, "array", System.StringComparison.OrdinalIgnoreCase) + || System.String.Equals (i.idText, "[]", System.StringComparison.Ordinal) + -> + true + // TODO: consider FSharpList or whatever it is + | [ i ] -> + printfn $"Not array: %s{i.idText}" + false + | _ -> false + [] module internal SynTypePatterns = let (|OptionType|_|) (fieldType : SynType) = @@ -76,11 +89,50 @@ module internal SynTypePatterns = Some innerType | _ -> None + let (|ArrayType|_|) (fieldType : SynType) = + match fieldType with + | SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when AstHelper.isArrayIdent ident -> + Some innerType + | SynType.Array (1, innerType, _) -> Some innerType + | _ -> None + /// Returns the string name of the type. let (|PrimitiveType|_|) (fieldType : SynType) = match fieldType with | SynType.LongIdent ident -> match ident.LongIdent with - | [ i ] -> [ "string" ; "float" ; "int" ] |> List.tryFind (fun s -> s = i.idText) + | [ i ] -> [ "string" ; "float" ; "int" ; "bool" ] |> List.tryFind (fun s -> s = i.idText) + | _ -> None + | _ -> None + + let (|NumberType|_|) (fieldType : SynType) = + match fieldType with + | SynType.LongIdent ident -> + match ident.LongIdent with + | [ i ] -> [ "string" ; "float" ; "int" ; "bool" ] |> List.tryFind (fun s -> s = i.idText) + | _ -> None + | _ -> None + + let (|DateOnly|_|) (fieldType : SynType) = + match fieldType with + | SynType.LongIdent ident -> + match ident.LongIdent with + | [ i ] -> + if i.idText = "System.DateOnly" || i.idText = "DateOnly" then + Some () + else + None + | _ -> None + | _ -> None + + let (|DateTime|_|) (fieldType : SynType) = + match fieldType with + | SynType.LongIdent ident -> + match ident.LongIdent with + | [ i ] -> + if i.idText = "System.DateTime" || i.idText = "DateTime" then + Some () + else + None | _ -> None | _ -> None diff --git a/MyriadPlugin/JsonParseGenerator.fs b/MyriadPlugin/JsonParseGenerator.fs index f43d7f1..d454357 100644 --- a/MyriadPlugin/JsonParseGenerator.fs +++ b/MyriadPlugin/JsonParseGenerator.fs @@ -17,23 +17,33 @@ module internal JsonParseGenerator = open Fantomas.FCS.Text.Range open Myriad.Core.Ast - let createParseLineValue (propertyName : SynExpr) (typeName : string) : SynExpr = - // node.["town"].AsValue().GetValue () - let indexed = + type JsonParseOption = + { + JsonNumberHandlingArg : SynExpr option + } + + static member None = + { + JsonNumberHandlingArg = None + } + + /// {node}.AsValue().GetValue<{typeName}> () + let asValueGetValue (typeName : string) (node : SynExpr) : SynExpr = + let asValue = SynExpr.CreateApp ( SynExpr.DotGet ( - SynExpr.DotIndexedGet (SynExpr.Ident (Ident.Create "node"), propertyName, range0, range0), + node, range0, SynLongIdent.SynLongIdent (id = [ Ident.Create "AsValue" ], dotRanges = [], trivia = [ None ]), range0 ), - SynExpr.CreateConst (SynConst.Unit) + SynExpr.CreateConst SynConst.Unit ) SynExpr.CreateApp ( SynExpr.TypeApp ( SynExpr.DotGet ( - indexed, + asValue, range0, SynLongIdent.SynLongIdent (id = [ Ident.Create "GetValue" ], dotRanges = [], trivia = [ None ]), range0 @@ -52,45 +62,21 @@ module internal JsonParseGenerator = SynExpr.CreateConst SynConst.Unit ) - let createParseLineCallThrough (propertyName : SynExpr) (fieldType : SynType) : SynExpr = - // Type.jsonParse node.["town"] - let typeName = - match fieldType with - | SynType.LongIdent ident -> ident.LongIdent - | _ -> failwith $"Unrecognised type: %+A{fieldType}" - + /// {type}.jsonParse {node} + let typeJsonParse (typeName : LongIdent) (node : SynExpr) : SynExpr = SynExpr.CreateApp ( SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent (typeName @ [ Ident.Create "jsonParse" ])), - SynExpr.DotIndexedGet (SynExpr.CreateIdentString "node", propertyName, range0, range0) + node ) /// collectionType is e.g. "List"; we'll be calling `ofSeq` on it. - let createParseLineList (collectionType : string) (propertyName : SynExpr) (elementType : string) : SynExpr = - // node.["openingHours"].AsArray() - // |> Seq.map (fun elt -> elt.AsValue().GetValue ()) - // |> List.ofSeq - + /// body is the body of a lambda which takes a parameter `elt`. + /// {node}.AsArray() + /// |> Seq.map (fun elt -> {body}) + /// |> {collectionType}.ofSeq + let asArrayMapped (collectionType : string) (node : SynExpr) (body : SynExpr) : SynExpr = let parsedDataPat = [ SynPat.CreateNamed (Ident.Create "elt") ] - let parsedData = - SynExpr.CreateApp ( - SynExpr.TypeApp ( - SynExpr.DotGet ( - SynExpr.CreateLongIdent (SynLongIdent.CreateString "elt"), - range0, - SynLongIdent.Create [ "GetValue" ], - range0 - ), - range0, - [ SynType.CreateLongIdent elementType ], - [], - Some range0, - range0, - range0 - ), - SynExpr.CreateConst SynConst.Unit - ) - SynExpr.CreateApp ( SynExpr.CreateAppInfix ( SynExpr.LongIdent ( @@ -116,17 +102,7 @@ module internal JsonParseGenerator = range0 ), SynExpr.CreateApp ( - SynExpr.DotGet ( - SynExpr.DotIndexedGet ( - SynExpr.CreateIdent (Ident.Create "node"), - propertyName, - range0, - range0 - ), - range0, - SynLongIdent.CreateString "AsArray", - range0 - ), + SynExpr.DotGet (node, range0, SynLongIdent.CreateString "AsArray", range0), SynExpr.CreateConst SynConst.Unit ) ), @@ -137,27 +113,8 @@ module internal JsonParseGenerator = false, false, SynSimplePats.Create [ SynSimplePat.CreateId (Ident.Create "elt") ], - SynExpr.CreateApp ( - SynExpr.TypeApp ( - SynExpr.DotGet ( - SynExpr.CreateApp ( - SynExpr.CreateLongIdent (SynLongIdent.CreateString "elt"), - SynExpr.CreateConst SynConst.Unit - ), - range0, - SynLongIdent.CreateString "GetValue", - range0 - ), - range0, - [ SynType.CreateLongIdent (SynLongIdent.CreateString elementType) ], - [], - None, - range0, - range0 - ), - SynExpr.CreateConst SynConst.Unit - ), - Some (parsedDataPat, parsedData), + body, + Some (parsedDataPat, body), range0, { ArrowRange = Some range0 @@ -170,16 +127,230 @@ module internal JsonParseGenerator = SynExpr.CreateLongIdent (SynLongIdent.Create [ collectionType ; "ofSeq" ]) ) - /// propertyName is probably a string literal, but it could be a [] variable - let createParseRhs (varName : string) (propertyName : SynExpr) (fieldType : SynType) : SynExpr = + /// match {node} with | null -> None | v -> Some {body} + /// Use the variable `v` to get access to the `Some`. + let createParseLineOption (node : SynExpr) (body : SynExpr) : SynExpr = + let body = + SynExpr.CreateApp ( + SynExpr.CreateAppInfix ( + SynExpr.CreateLongIdent ( + SynLongIdent.SynLongIdent ( + [ Ident.Create "op_PipeRight" ], + [], + [ Some (IdentTrivia.OriginalNotation "|>") ] + ) + ), + body + ), + SynExpr.CreateIdentString "Some" + ) + + SynExpr.CreateMatch ( + node, + [ + SynMatchClause.Create (SynPat.CreateNull, None, SynExpr.CreateIdent (Ident.Create "None")) + SynMatchClause.Create (SynPat.CreateNamed (Ident.Create "v"), None, body) + ] + ) + + let eltGetValue (elementType : string) : SynExpr = + SynExpr.CreateApp ( + SynExpr.TypeApp ( + SynExpr.DotGet ( + SynExpr.CreateLongIdent (SynLongIdent.CreateString "elt"), + range0, + SynLongIdent.Create [ "GetValue" ], + range0 + ), + range0, + [ SynType.CreateLongIdent elementType ], + [], + Some range0, + range0, + range0 + ), + SynExpr.CreateConst SynConst.Unit + ) + + /// {expr} |> DateOnly.Parse + let pipeThroughFunction (ident : SynLongIdent) (expr : SynExpr) : SynExpr = + SynExpr.CreateApp ( + SynExpr.CreateAppInfix ( + SynExpr.CreateLongIdent ( + SynLongIdent.SynLongIdent ( + [ Ident.Create "op_PipeRight" ], + [], + [ Some (IdentTrivia.OriginalNotation "|>") ] + ) + ), + expr + ), + SynExpr.CreateLongIdent ident + ) + + /// if {cond} then {trueBranch} else {falseBranch} + let ifThenElse (cond : SynExpr) (trueBranch : SynExpr) (falseBranch : SynExpr) : SynExpr = + SynExpr.IfThenElse ( + cond, + trueBranch, + Some falseBranch, + DebugPointAtBinding.Yes range0, + false, + range0, + { + IfKeyword = range0 + IsElif = false + ThenKeyword = range0 + ElseKeyword = Some range0 + IfToThenRange = range0 + } + ) + + /// try {body} with | {exc} as exc -> {handler} + let pipeThroughTryWith (exc : SynPat) (handler : SynExpr) (body : SynExpr) : SynExpr = + let clause = + SynMatchClause.Create (SynPat.As (exc, SynPat.CreateNamed (Ident.Create "exc"), range0), None, handler) + + SynExpr.TryWith ( + body, + [ clause ], + range0, + DebugPointAtTry.Yes range0, + DebugPointAtWith.Yes range0, + { + TryKeyword = range0 + TryToWithRange = range0 + WithKeyword = range0 + WithToEndRange = range0 + } + ) + + /// {a} = {b} + let equals (a : SynExpr) (b : SynExpr) = + SynExpr.CreateApp ( + SynExpr.CreateAppInfix ( + SynExpr.CreateLongIdent ( + SynLongIdent.SynLongIdent ( + Ident.CreateLong "op_Equality", + [], + [ Some (IdentTrivia.OriginalNotation "=") ] + ) + ), + a + ), + b + ) + + /// Given e.g. "float", returns "Double.Parse" + let parseFunction (typeName : string) : LongIdent = + match typeName with + | "float32" -> [ "System" ; "Single" ] + | "float" -> [ "System" ; "Double" ] + | "byte" + | "uint8" -> [ "System" ; "Byte" ] + | "sbyte" -> [ "System" ; "SByte" ] + | "int16" -> [ "System" ; "Int16" ] + | "int" -> [ "System" ; "Int32" ] + | "int64" -> [ "System" ; "Int64" ] + | "uint16" -> [ "System" ; "UInt16" ] + | "uint" + | "uint32" -> [ "System" ; "UInt32" ] + | "uint64" -> [ "System" ; "UInt64" ] + | _ -> failwith $"Unable to identify a parsing function `string -> %s{typeName}`" + |> fun a -> List.append a [ "Parse" ] + |> List.map Ident.Create + + /// Given `node.["town"]`, for example, choose how to obtain a JSON value from it. + let rec parseNode (options : JsonParseOption) (fieldType : SynType) (node : SynExpr) : SynExpr = + // TODO: parsing format for DateTime etc match fieldType with - | OptionType ty -> failwith "TODO: options" - | PrimitiveType typeName -> createParseLineValue propertyName typeName - | ListType (PrimitiveType typeName) -> createParseLineList "List" propertyName typeName - // TODO: support recursive lists + | DateOnly -> + asValueGetValue "string" node + |> pipeThroughFunction (SynLongIdent.Create [ "System" ; "DateOnly" ; "Parse" ]) + | DateTime -> + asValueGetValue "string" node + |> pipeThroughFunction (SynLongIdent.Create [ "System" ; "DateTime" ; "Parse" ]) + | NumberType typeName -> + let basic = asValueGetValue typeName node + + match options.JsonNumberHandlingArg with + | None -> basic + | Some option -> + let reraise = + (SynExpr.CreateApp (SynExpr.CreateIdent (Ident.Create "reraise"), SynExpr.CreateConst SynConst.Unit)) + + let cond = + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "exc" ; "Message" ; "Contains" ]), + SynExpr.CreateConst (SynConst.CreateString "cannot be converted to") + ) + + let trueBranch = + ifThenElse + (equals + option + (SynExpr.CreateLongIdent ( + SynLongIdent.Create + [ + "System" + "Text" + "Json" + "Serialization" + "JsonNumberHandling" + "AllowReadingFromString" + ] + ))) + (asValueGetValue "string" node + |> pipeThroughFunction (SynLongIdent.CreateFromLongIdent (parseFunction typeName))) + reraise + + let handler = ifThenElse cond trueBranch reraise + + basic + |> pipeThroughTryWith + (SynPat.IsInst ( + SynType.LongIdent (SynLongIdent.Create [ "System" ; "InvalidOperationException" ]), + range0 + )) + handler + | PrimitiveType typeName -> asValueGetValue typeName node + | OptionType ty -> + parseNode options ty (SynExpr.CreateIdentString "v") + |> createParseLineOption node + | ListType ty -> + parseNode options ty (SynExpr.CreateLongIdent (SynLongIdent.CreateString "elt")) + |> asArrayMapped "List" node + | ArrayType ty -> + parseNode options ty (SynExpr.CreateLongIdent (SynLongIdent.CreateString "elt")) + |> asArrayMapped "Array" node | _ -> // Let's just hope that we've also got our own type annotation! - createParseLineCallThrough propertyName fieldType + let typeName = + match fieldType with + | SynType.LongIdent ident -> ident.LongIdent + | _ -> failwith $"Unrecognised type: %+A{fieldType}" + + typeJsonParse typeName node + + /// propertyName is probably a string literal, but it could be a [] variable + /// The result of this function is the body of a let-binding (not including the LHS of that let-binding). + let createParseRhs (options : JsonParseOption) (propertyName : SynExpr) (fieldType : SynType) : SynExpr = + SynExpr.DotIndexedGet (SynExpr.CreateIdentString "node", propertyName, range0, range0) + |> parseNode options fieldType + + let stripOptionalParen (expr : SynExpr) = + match expr with + | SynExpr.Paren (expr, _, _, _) -> expr + | expr -> expr + + let isJsonNumberHandling (literal : LongIdent) : bool = + match List.rev literal |> List.map (fun ident -> ident.idText) with + | [ _ ; "JsonNumberHandling" ] + | [ _ ; "JsonNumberHandling" ; "Serialization" ] + | [ _ ; "JsonNumberHandling" ; "Serialization" ; "Json" ] + | [ _ ; "JsonNumberHandling" ; "Serialization" ; "Json" ; "Text" ] + | [ _ ; "JsonNumberHandling" ; "Serialization" ; "Json" ; "Text" ; "System" ] -> true + | _ -> false let createMaker (typeName : LongIdent) (fields : SynField list) = let xmlDoc = PreXmlDoc.Create " Parse from a JSON node." @@ -205,13 +376,44 @@ module internal JsonParseGenerator = | None -> failwith "didn't get an ID on field" | Some id -> id + let attrs = attrs |> List.collect (fun l -> l.Attributes) + let propertyNameAttr = attrs - |> List.collect (fun l -> l.Attributes) |> List.tryFind (fun attr -> attr.TypeName.AsString.EndsWith ("JsonPropertyName", StringComparison.Ordinal) ) + let options = + (JsonParseOption.None, attrs) + ||> List.fold (fun options attr -> + if attr.TypeName.AsString.EndsWith ("JsonNumberHandling", StringComparison.Ordinal) then + let qualifiedEnumValue = + match stripOptionalParen attr.ArgExpr with + | SynExpr.LongIdent (_, SynLongIdent (ident, _, _), _, _) when + isJsonNumberHandling ident + -> + // Make sure it's fully qualified + SynExpr.CreateLongIdent ( + SynLongIdent.Create + [ + "System" + "Text" + "Json" + "Serialization" + "JsonNumberHandling" + "AllowReadingFromString" + ] + ) + | _ -> attr.ArgExpr + + { + JsonNumberHandlingArg = Some qualifiedEnumValue + } + else + options + ) + let propertyName = match propertyNameAttr with | None -> @@ -237,7 +439,7 @@ module internal JsonParseGenerator = SynBinding.Let ( isInline = false, isMutable = false, - expr = createParseRhs (id.ToString ()) propertyName fieldType, + expr = createParseRhs options propertyName fieldType, valData = inputVal, pattern = pattern )