// Learn more about F# at http://fsharp.org

open System
open FParsec
open System.Text.RegularExpressions
open Newtonsoft.Json
open Microsoft.FSharp
open Microsoft.FSharp.Reflection

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

let listGenerator = sprintf "%s list"
let arrayGenerator = sprintf "%s array"
let charpListGenerator = sprintf "List<%s>"

type TypeIdentification =
    { Name: string
      Attributes: string list}

type FieldIdentification =
    { Name: string
      Type: string
      Attributes: string list }

type TypeDefinition =
    { TypeIdentification: TypeIdentification
      FieldIdentifications: FieldIdentification list }

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 rec aggreagateListToSingleType jsonList =
    let isDateTime = 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 getOptionType istanceType isOption =
        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
    | [] -> JEmptyObjectOption
    | list when list |> List.forall isNull -> JEmptyObjectOption
    | list when list |> List.forall (isNumber <||> isNull) ->
        let newType =
                list
                |> List.filter (not << isNull)
                |> List.distinct
                |> List.map(fun x -> (x, typeOrder x))
                |> List.maxBy (fun (_, rank) -> rank)
                |> fst
        getOptionType newType (list |> checkNumberOption)

    | list when list |> List.forall (isString <||> isNull) ->
        getOptionType JString (list |> checkStringOption)

    | list when list |> List.forall (isDateTime <||> isNull) ->
        getOptionType JDateTimeOffset (list |> checkDateTimeOption)

    | list when list |> List.forall (isBool <||> isNull) ->
        getOptionType JBool (list |> checkBoolOption)

    | list when list |> List.forall (isObject <||> isNull) ->
        let getObjects =
            List.filter (not << isNull)
            >> List.map(function JObject list | JObjectOption list -> list | _ -> failwith "Excpected JObject")

        let res =
            list
            |> getObjects
            |> List.collect(fun x -> x)
            |> List.groupBy(fun (key, _) -> key)
            |> List.map(fun (key, value) -> (key, (aggreagateListToSingleType (value |> List.map snd))))
        getOptionType (JObject res) (list |> checkObjectOption)

    | list when list |> List.forall (isList <||> isNull) ->
        let getLists = List.filter (not << isNull) >> List.map(function JList x -> x | _ -> failwith "Excpected JList")

        let res =
            list
            |> getLists
            |> List.collect(fun x -> x)
            |> aggreagateListToSingleType

        getOptionType (JArray res) (list |> checkArrayOption)

    | list when list |> List.forall (isArray <||> isNull) ->
        let getObjs =
            List.filter (not << isNull)
            >> List.map(function JArray list | JArrayOption list -> list | _ -> failwith "Excpected JArray")

        let res =
            list
            |> getObjs
            |> aggreagateListToSingleType

        getOptionType (JArray res) (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 translateToString listGenerator =
    let getName { Name = name; Type = _; Attributes = _ } = name

    fixName
    >> fun name ->
        function
        | JBool ->                  { Name = name; Type = "bool"; Attributes = [] }
        | JBoolOption ->            { Name = name; Type = "bool option"; Attributes = [] }
        | JNull ->                  { Name = name; Type = "Object option"; Attributes = [] }
        | JInt ->                   { Name = name; Type = "int64"; Attributes = [] }
        | JIntOption ->             { Name = name; Type = "int64 option"; Attributes = [] }
        | JFloat ->                 { Name = name; Type = "float"; Attributes = [] }
        | JFloatOption ->           { Name = name; Type = "float option"; Attributes = [] }
        | JString ->                { Name = name; Type = "string"; Attributes = [] }
        | JDateTimeOffset ->        { Name = name; Type = "DateTimeOffset"; Attributes = [] }
        | JDateTimeOffsetOption ->  { Name = name; Type = "DateTimeOffset option"; Attributes = [] }
        | JStringOption ->          { Name = name; Type = "string option"; Attributes = [] }
        | JEmptyObjectOption ->     { Name = name; Type = "Object option"; Attributes = [] }
        | JObject _ ->              { Name = name; Type = name; Attributes = [] }
        | JObjectOption _ ->        { Name = name; Type = sprintf "%s %s" name "option"; Attributes = [] }
        | JArray obj ->             { Name = name; Type = translateToString listGenerator name obj |> getName |> listGenerator; Attributes = [] }
        | JArrayOption obj ->       { Name = name; Type = translateToString listGenerator name obj |> getName |> listGenerator; Attributes = [] }
        | _ -> failwith "translateToString unexcpected"

let rec extractObject json =
    match json with
    | JArray obj
    | JArrayOption obj -> extractObject obj
    | JObject _
    | JObjectOption _  -> Some json
    | _ -> None

let rec deep listGenerator 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 (name, value) -> translateToString listGenerator name value)
                |> fun x -> { TypeIdentification = { Name = name |> fixName; Attributes = [] }; FieldIdentifications = 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]

let typeDefinitionToType typeDefinition =
    let joinByNewLine = sprintf "%s\n%s"

    let typeDef =
        match typeDefinition.TypeIdentification.Attributes with
        | [] -> sprintf "type %s =" typeDefinition.TypeIdentification.Name
        | attributes ->
             attributes
             |> List.fold joinByNewLine ""
             |> (fun x -> sprintf "%s\ntype %s =" x typeDefinition.TypeIdentification.Name)

    let fieldDefinitionToType fieldDefinition =
        match fieldDefinition.Attributes with
        | [] -> sprintf "%s: %s" fieldDefinition.Name fieldDefinition.Type
        | attributes -> sprintf "\n%s\n%s: %s" (attributes |> List.reduce joinByNewLine) fieldDefinition.Name fieldDefinition.Type

    let fieldDef =
        match typeDefinition.FieldIdentifications with
        | [] -> ""
        | fields ->
                fields
                |> List.map fieldDefinitionToType
                |> List.reduce (sprintf "%s\n\t  %s")

    sprintf "%s\n\t{ %s }" typeDef fieldDef

let typesToView =
    List.map typeDefinitionToType
    >> List.reduce (sprintf "%s\n\n%s")

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 generateRecords (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 listGenerator x |> typesToView)
        | _ -> printfn "Failure"
    | Failure(errorMsg, _, _) -> printfn "Failure: %s" errorMsg

[<EntryPoint>]
let main argv =

    let testExample = @"
    {
        ""employees"": [[{""name"": ""2012-04-23T18:25:43.511Z""}, {""name"": null} ]],
        ""employees2"": [[{""name"": ""2012-04-23T18:25:43.511Z""}, {""name"": null} ]]
    }"

    generateRecords testExample None

    Console.ReadKey() |> ignore
    0 // return an integer exit code