open System open FParsec open System.Text.RegularExpressions open Newtonsoft.Json open Microsoft.FSharp open Microsoft.FSharp.Reflection open System.Reflection.Metadata let inline (^) f x = f x let (<||>) f1 f2 x = f1 x || f2 x let (<&&>) f1 f2 x = f1 x && f2 x type Json = | JBool | JBoolOption | JNull | JInt | JIntOption | JFloat | JFloatOption | JString | JDateTimeOffset | JDateTimeOffsetOption | JStringOption | JList of Json list | JEmptyObjectOption | JObject of (string * Json) list | JObjectOption of (string * Json) list | JArray of Json | JArrayOption of Json [] type CollectionType = | Array | List | CSharpList [] type GenerationType = | JustTypes | NewtonsoftJsonProperties let listGenerator = sprintf "%s list" let arrayGenerator = sprintf "%s array" let charpListGenerator = sprintf "List<%s>" type TypeInfo = { Name: string Attributes: string list} type FieldInfo = { Name: string Type: string Attributes: string list } type Type = { TypeIdentification: TypeInfo FieldIdentifications: FieldInfo list } type NewtonsoftFile = { ModuleName: string Opens: string seq TypeDefinitions: Type list } type OutputType = | NewtonsoftType of NewtonsoftFile | JustTypes of Type list type HandlerProvider = { TypeHandler: (string -> FieldInfo list -> Type) FieldHandler: (string -> Json -> FieldInfo) FileHandler: (Type list -> OutputType)} let ws = spaces let str s = pstring s let stringLiteral = let escape = anyOf "\"\\/bfnrt" |>> function | 'b' -> "\b" | 'f' -> "\u000C" | 'n' -> "\n" | 'r' -> "\r" | 't' -> "\t" | c -> string c let unicodeEscape = str "u" >>. pipe4 hex hex hex hex (fun h3 h2 h1 h0 -> let hex2int c = (int c &&& 15) + (int c >>> 6)*9 (hex2int h3)*4096 + (hex2int h2)*256 + (hex2int h1)*16 + hex2int h0 |> char |> string ) between (str "\"") (str "\"") (stringsSepBy (manySatisfy (fun c -> c <> '"' && c <> '\\')) (str "\\" >>. (escape <|> unicodeEscape))) let stringOrDateTime (str: string) = if DateTimeOffset.TryParse(str, ref (DateTimeOffset())) then JDateTimeOffset else JString let jstringOrDate = stringLiteral |>> stringOrDateTime let jnumber = pfloat |>> (fun x -> if x = Math.Floor(x) then JInt else JFloat) let jtrue = stringReturn "true" JBool let jfalse = stringReturn "false" JBool let jnull = stringReturn "null" JNull let jvalue, jvalueRef = createParserForwardedToRef() let listBetweenStrings sOpen sClose pElement f = between (str sOpen) (str sClose) (ws >>. sepBy (pElement .>> ws) (str "," .>> ws) |>> f) let keyValue = tuple2 stringLiteral (ws >>. str ":" >>. ws >>. jvalue) let jlist = listBetweenStrings "[" "]" jvalue JList let jobject = listBetweenStrings "{" "}" keyValue JObject do jvalueRef := choice [jobject jlist jstringOrDate jnumber jtrue jnull jfalse] let json = ws >>. jvalue .>> ws .>> eof let parseJsonString str = run json str let isDateTimeOffset = function JDateTimeOffset _ | JDateTimeOffsetOption _ -> true | _ -> false let isArray = function JArray _ | JArrayOption _ -> true | _ -> false let isList = function JList _ -> true | _ -> false let isString = function JStringOption | JString -> true | _ -> false let isNumber = function JInt | JFloat| JIntOption | JFloatOption -> true | _ -> false let isNull = function JNull -> true | _ -> false let isBool = function JBool | JBoolOption -> true | _ -> false let isObject = function JObject _ | JObjectOption _ -> true | _ -> false let isDateTimeOption = function JDateTimeOffsetOption -> true | _ -> false let isBoolOption = function JBoolOption -> true | _ -> false let isStringOption = function JStringOption -> true | _ -> false let isArrayOption = function JArrayOption _ -> true | _ -> false let isObjectOption = function JObjectOption _ -> true | _ -> false let isNumberOption = function JIntOption | JFloatOption -> true | _ -> false let typeOrder = function | JInt | JIntOption -> 1 | JFloat | JFloatOption -> 2 | _ -> failwith "Not number type" let checkStringOption = List.exists (isNull <||> isStringOption) let checkArrayOption = List.exists (isNull <||> isArrayOption) let checkObjectOption = List.exists (isNull <||> isObjectOption) let checkNumberOption = List.exists (isNull <||> isNumberOption) let checkBoolOption = List.exists (isNull <||> isBoolOption) let checkDateTimeOption = List.exists (isNull <||> isDateTimeOption) let (|EmptyList|_|) = function | [] -> Some EmptyList | _ -> None let (|NullList|_|) = function | list when list |> List.forall isNull -> Some ^ NullList | _ -> None let (|NumberList|_|) = function | list when list |> List.forall (isNumber <||> isNull) -> Some ^ NumberList list | _ -> None let (|StringList|_|) = function | list when list |> List.forall (isString <||> isNull) -> Some ^ StringList list | _ -> None let (|DateTimeOffsetList|_|) = function | list when list |> List.forall (isDateTimeOffset <||> isNull) -> Some ^ DateTimeOffsetList list | _ -> None let (|BoolList|_|) = function | list when list |> List.forall (isBool <||> isNull) -> Some ^ BoolList list | _ -> None let (|ObjectList|_|) = function | list when list |> List.forall (isObject <||> isNull) -> Some ^ ObjectList list | _ -> None let (|ListList|_|) = function | list when list |> List.forall (isList <||> isNull) -> Some ^ ListList list | _ -> None let (|ArrayList|_|) = function | list when list |> List.forall (isArray <||> isNull) -> Some ^ ArrayList list | _ -> None let rec aggreagateListToSingleType jsonList = let getOptionType isOption istanceType = match istanceType, isOption with | JInt, true -> JIntOption | JFloat, true -> JFloatOption | JBool, true -> JBoolOption | JString, true -> JStringOption | JDateTimeOffset, true -> JDateTimeOffsetOption | JObject x, true -> JObjectOption x | JArray x, true -> JArrayOption x | x, _ -> x match jsonList with | EmptyList -> JEmptyObjectOption | NullList -> JEmptyObjectOption | StringList list -> JString |> getOptionType (list |> checkStringOption) | DateTimeOffsetList list -> JDateTimeOffset |> getOptionType (list |> checkDateTimeOption) | BoolList list -> JBool |> getOptionType (list |> checkBoolOption) | NumberList list -> list |> List.filter (not << isNull) |> List.distinct |> List.map(fun x -> (x, typeOrder x)) |> List.maxBy snd |> fst |> getOptionType (list |> checkNumberOption) | ObjectList list -> list |> List.filter (not << isNull) |> List.map(function JObject list | JObjectOption list -> list) |> List.collect id |> List.groupBy fst |> List.map(fun (key, value) -> (key, (aggreagateListToSingleType (value |> List.map snd)))) |> JObject |> getOptionType (list |> checkObjectOption) | ListList list -> list |> List.filter (not << isNull) |> List.map(function JList x -> x) |> List.collect id |> aggreagateListToSingleType |> JArray |> getOptionType (list |> checkArrayOption) | ArrayList list -> list |> List.filter (not << isNull) |> List.map(function JArray list | JArrayOption list -> list) |> aggreagateListToSingleType |> JArray |> getOptionType (list |> checkArrayOption) | _ -> JEmptyObjectOption let rec castArray = List.map(fun (key, value) -> match value with | JObject list -> key, JObject ^ castArray list | JList list -> key, JArray ^ aggreagateListToSingleType list | _ -> key, value) let fixName (name: string) = let getFirstChar (name: string) = name.Chars 0 let toUpperFirst name = ((Char.ToUpper ^ getFirstChar name) |> Char.ToString) + name.Substring 1 let newFieldName = Regex.Replace(name, "[!@#$%^&*()\-=+|/><\[\]\.\\*`]+", "") |> toUpperFirst if (not <| Char.IsLetter ^ getFirstChar name) && getFirstChar name <> '_' then "The" + newFieldName else newFieldName let rec extractObject json = match json with | JArray obj | JArrayOption obj -> extractObject obj | JObject _ | JObjectOption _ -> Some json | _ -> None let rec deep resultHandler node = let rec tailDeep acc jobjs = match jobjs with | [] -> acc |> List.distinctBy(fun { TypeIdentification = { Name = name } ; FieldIdentifications = _ } -> name) | (name, (JObject list))::xs | (name, (JObjectOption list))::xs -> let newType = list |> List.distinctBy (fun (name, _) -> name) |> List.map (fun (key, value) -> resultHandler.FieldHandler key value) |> fun x -> resultHandler.TypeHandler name x let newJobjs = list |> List.map(fun (key, value) -> (key, extractObject value)) |> List.choose(fun (key, v) -> match v with Some j -> Some (key, j) | None -> None) tailDeep (newType::acc) (newJobjs @ xs) | _ -> failwith "unexpected" tailDeep [] [node] |> resultHandler.FileHandler let joinByNewLine = sprintf "%s\n%s" let typeIdentificationToString (typeIdentification: TypeInfo) = match typeIdentification.Attributes with | [] -> sprintf "type %s =" typeIdentification.Name | attribues -> attribues |> List.fold joinByNewLine "" |> (fun x -> sprintf "\t%s\ntype %s =" x typeIdentification.Name) let fieldIdentificationToString (fieldIdentification: FieldInfo) = match fieldIdentification.Attributes with | [] -> sprintf "%s: %s" fieldIdentification.Name fieldIdentification.Type | attributes -> sprintf "\n%s\n%s: %s" (attributes |> List.reduce joinByNewLine) fieldIdentification.Name fieldIdentification.Type let fieldsToString = function | [] -> "" | fields -> fields |> List.map fieldIdentificationToString |> List.reduce (sprintf "%s\n\t %s") let typeDefinitionToString typeDefinition = sprintf "%s\n\t{ %s }" (typeIdentificationToString typeDefinition.TypeIdentification) (fieldsToString typeDefinition.FieldIdentifications) let allTypeDefinitionsToString = List.map typeDefinitionToString >> List.reduce (sprintf "%s\n\n%s") let opensToString<'a> = Seq.fold (sprintf "%s\n%s") "" let newtonsoftToString file = sprintf "module %s\n%s\n\n%s" file.ModuleName (opensToString file.Opens) (allTypeDefinitionsToString file.TypeDefinitions) let toView = function | NewtonsoftType file -> file |> newtonsoftToString | JustTypes typeList -> typeList |> allTypeDefinitionsToString type OptionConverter() = inherit JsonConverter() override x.CanConvert(t) = t.IsGenericType && t.GetGenericTypeDefinition() = typedefof> override x.WriteJson(writer, value, serializer) = let value = if value = null then null else let _,fields = FSharpValue.GetUnionFields(value, value.GetType()) fields.[0] serializer.Serialize(writer, value) override x.ReadJson(reader, t, existingValue, serializer) = let innerType = t.GetGenericArguments().[0] let innerType = if innerType.IsValueType then (typedefof>).MakeGenericType([|innerType|]) else innerType let value = serializer.Deserialize(reader, innerType) let cases = FSharpType.GetUnionCases(t) if value = null then FSharpValue.MakeUnion(cases.[0], [||]) else FSharpValue.MakeUnion(cases.[1], [|value|]) let newtonsoftGenerator = let getName { Name = name; Type = _; Attributes = _ } = name let generateAttributes name = [sprintf "[]" name] let rec fieldHandler listGenerator name = function | JBool -> { Name = name |> fixName; Type = "bool"; Attributes = (generateAttributes name) } | JBoolOption -> { Name = name |> fixName; Type = "bool option"; Attributes = (generateAttributes name) } | JNull -> { Name = name |> fixName; Type = "Object option"; Attributes = (generateAttributes name) } | JInt -> { Name = name |> fixName; Type = "int64"; Attributes = (generateAttributes name) } | JIntOption -> { Name = name |> fixName; Type = "int64 option"; Attributes = (generateAttributes name) } | JFloat -> { Name = name |> fixName; Type = "float"; Attributes = (generateAttributes name) } | JFloatOption -> { Name = name |> fixName; Type = "float option"; Attributes = (generateAttributes name) } | JString -> { Name = name |> fixName; Type = "string"; Attributes = (generateAttributes name) } | JDateTimeOffset -> { Name = name |> fixName; Type = "DateTimeOffset"; Attributes = (generateAttributes name) } | JDateTimeOffsetOption -> { Name = name |> fixName; Type = "DateTimeOffset option"; Attributes = (generateAttributes name) } | JStringOption -> { Name = name |> fixName; Type = "string option"; Attributes = (generateAttributes name) } | JEmptyObjectOption -> { Name = name |> fixName; Type = "Object option"; Attributes = (generateAttributes name) } | JObject _ -> { Name = name |> fixName; Type = name; Attributes = (generateAttributes name) } | JObjectOption _ -> { Name = name |> fixName; Type = sprintf "%s %s" name "option"; Attributes = (generateAttributes name) } | JArray obj -> { Name = name |> fixName; Type = fieldHandler listGenerator name obj |> getName |> listGenerator; Attributes = (generateAttributes name) } | JArrayOption obj -> { Name = name |> fixName; Type = fieldHandler listGenerator name obj |> getName |> listGenerator; Attributes = (generateAttributes name) } | _ -> failwith "translateToString unexcpected" let typeHandler name fieldIndetifications = { TypeIdentification = { Name = name |> fixName; Attributes = [] }; FieldIdentifications = fieldIndetifications } let opens = [ "open System" "open Newtonsoft.Json"] let fileHandler types = { ModuleName = "Json2FSharp" Opens = opens TypeDefinitions = types } |> NewtonsoftType { TypeHandler = typeHandler FieldHandler = fieldHandler listGenerator FileHandler = fileHandler } let justTypesGenerator = let getName { Name = name; Type = _; Attributes = _ } = name let generateAttributes _ = [] let rec fieldHandler listGenerator name = function | JBool -> { Name = name |> fixName; Type = "bool"; Attributes = (generateAttributes name) } | JBoolOption -> { Name = name |> fixName; Type = "bool option"; Attributes = (generateAttributes name) } | JNull -> { Name = name |> fixName; Type = "Object option"; Attributes = (generateAttributes name) } | JInt -> { Name = name |> fixName; Type = "int64"; Attributes = (generateAttributes name) } | JIntOption -> { Name = name |> fixName; Type = "int64 option"; Attributes = (generateAttributes name) } | JFloat -> { Name = name |> fixName; Type = "float"; Attributes = (generateAttributes name) } | JFloatOption -> { Name = name |> fixName; Type = "float option"; Attributes = (generateAttributes name) } | JString -> { Name = name |> fixName; Type = "string"; Attributes = (generateAttributes name) } | JDateTimeOffset -> { Name = name |> fixName; Type = "DateTimeOffset"; Attributes = (generateAttributes name) } | JDateTimeOffsetOption -> { Name = name |> fixName; Type = "DateTimeOffset option"; Attributes = (generateAttributes name) } | JStringOption -> { Name = name |> fixName; Type = "string option"; Attributes = (generateAttributes name) } | JEmptyObjectOption -> { Name = name |> fixName; Type = "Object option"; Attributes = (generateAttributes name) } | JObject _ -> { Name = name |> fixName; Type = name; Attributes = (generateAttributes name) } | JObjectOption _ -> { Name = name |> fixName; Type = sprintf "%s %s" name "option"; Attributes = (generateAttributes name) } | JArray obj -> { Name = name |> fixName; Type = fieldHandler listGenerator name obj |> getName |> listGenerator; Attributes = (generateAttributes name) } | JArrayOption obj -> { Name = name |> fixName; Type = fieldHandler listGenerator name obj |> getName |> listGenerator; Attributes = (generateAttributes name) } | _ -> failwith "translateToString unexcpected" let typeHandler name fieldIndetifications = { TypeIdentification = { Name = name |> fixName; Attributes = [] }; FieldIdentifications = fieldIndetifications } { TypeHandler = typeHandler FieldHandler = fieldHandler listGenerator FileHandler = JustTypes} let generateRecords fileHandler (str: string) mainObject = match parseJsonString str with | Success(result, _, _) -> let rootObject = match mainObject with | Some x -> x | None -> "RootObject" match castArray [rootObject |> fixName, result] with | [x] -> printfn "%s" ^ (deep fileHandler x |> toView) | _ -> printfn "Failure" | Failure(errorMsg, _, _) -> printfn "Failure: %s" errorMsg [] let main argv = let getFileGenerator = function | GenerationType.JustTypes -> justTypesGenerator | GenerationType.NewtonsoftJsonProperties -> newtonsoftGenerator let testExample = @" { ""employees"": [[{""name"": ""2012-04-23T18:25:43.511Z""}, {""name"": null} ]], ""employees2"": [[{""name"": ""2012-04-23T18:25:43.511Z""}, {""name"": null} ]] }" generateRecords (getFileGenerator GenerationType.NewtonsoftJsonProperties) testExample None Console.ReadKey() |> ignore 0 // return an integer exit code