Create a new version of paste:

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

[<RequireQualifiedAccess>]
type CollectionType =
    | Array
    | List
    | CSharpList

[<RequireQualifiedAccess>]
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<option<_>>

    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<Nullable<_>>).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 "[<JsonProperty(\"%s\")>]" 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

[<EntryPoint>]
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