F# PC NuML

namespace FuML.NumlParser

open System
open System.IO
open FParsec

type num =
    | Int of int32
    | Float of double


type Atom =
    | Number of num
    | String of string
    | Bool of bool
    | Nil of unit

type Type =
    | Flat of string
    | TypeTuple of Type list
    | TypeArray of Type

type Exp =
    | Atom of Atom
    | ExpTuple of Exp list
    | Where of Exp * Bind list
    | Lambda of Arg list * Exp
    | Variable of string
    | Infix of Infix
    | Call of Call
    | Branch of Branch
    | ExpArray of Exp list

and Bind = {name: string;exp: Exp}

and Arg =
    {name: string
     _type: Type option}

    override this.ToString() = $"{this.name}:{this._type}"

and Infix = {left: Exp;op: string;right: Exp}
and Branch = {pred: Exp;_then: Exp;_else: Exp}

and Call =
    {is_native: bool
     name: string
     args: Exp list}

type Stat =
    | Decl of Decl
    | Bind of Bind

and Decl =
    | VarDecl of Bind
    | FunctDecl of FunctDecl

and FunctDecl =
    {name: string
     args: Arg list
     _type: Type option
     body: Stat list * Exp}

type NumlParser() =
    static let concat(str1: string,str2: string) = str1 + str2
    static let concatList(values: Collections.Generic.IEnumerable<'t>) = String.Concat values
    static let digitWithoutZero = regex "[1-9]"
    static let blank opt = opt |> Option.defaultValue ""
    static let NativeVarPrefix = pstring "$$"
    static let Comma = pstring ","
    static let KW_Else = pstring "else"
    static let KW_End = pstring "end"
    static let KW_Funct = pstring "funct"
    static let KW_If = pstring "if"
    static let KW_Let = pstring "let"
    static let KW_Then = pstring "then"
    static let KW_Where = pstring "where"
    static let Id = regex "[a-zA-Z_]+[a-zA-Z0-9_]*"
    static let Ws = regex "[ \t\n\r]+"

    static let FComment =
        (choice
            [pstring "//|" >>. restOfLine true
             pstring "/|" >>. (charsTillString "|\\" true Int32.MaxValue)
             Ws ]
         |>> ignore)

    static let ntoa(n: num) =
        match n with
        | Int i -> Convert.ToString i
        | Float f -> Convert.ToString f


    static let TTrue = (pstring "true" |>> fun _ -> true)

    static let TFalse = (pstring "false" |>> fun _ -> false)

    static let TNil = (pstring "nil" |>> fun _ -> ())

    static member Stat = (NumlParser.Decl |>> Decl) <|> (NumlParser.Bind |>> Bind)

    static member Block = ((many NumlParser.Stat) .>>. NumlParser.PExp)

    static member Decl = (NumlParser.VarDecl <|> NumlParser.FunctDecl)

    static member VarDecl = (KW_Let >>. NumlParser.Bind |>> VarDecl)

    static member FunctDecl =
        (((KW_Let >>. Id
           .>>. NumlParser.FunctArgs
           .>>. opt(pstring "==>" >>. NumlParser.Type)
           .>> pstring "="
           .>>. NumlParser.Block)
          |>> (fun (((name,args),_type),body) ->
              {name = name
               args = args
               _type = _type
               body = body}))
         |>> FunctDecl)

    static member Bool = (TTrue <|> TFalse)

    static member IntMod = (NumlParser.FSign .>>. NumlParser.FIntPos |>> concat |>> int)

    static member TFloat =
        let dotPart = (pstring "." .>>. NumlParser.FIntPos) |>> concat

        let exponent =
            (opt(
                NumlParser.FExponent
                <|> (dotPart .>>. (opt NumlParser.FExponent |>> blank) |>> concat)
             )
             |>> blank)

        ((NumlParser.IntMod |>> Int |>> ntoa) .>>. exponent |>> concat |>> double)

    static member PNumber = (NumlParser.IntMod |>> Int) <|> (NumlParser.TFloat |>> Float)

    static member PString = NumlParser.TString
    static member PNil = TNil

    static member POpInfix = regex "[+\\-*/<>]|[<=>]=|[<>]"

    member this.readFile(path: string) =
        File.ReadAllTextAsync path |> Async.AwaitTask |> Async.RunSynchronously

    static member FSign =
        (opt(regex "[+~]")
         |>> fun sign ->
             match sign with
             | Some "~" -> "-"
             | Some "+"
             | _ -> "+")

    static member FExponent =
        (regex "[Ee]" .>>. NumlParser.FSign |>> concat .>>. NumlParser.FIntPos |>> concat)


    static member TString =
        let quote = pstring "\"" in

        (quote >>. many(regex "[^\"]" <|> pstring "\\\"") .>> quote |>> concatList)


    static member FIntPos =
        (choice
            [pstring "0"
             digitWithoutZero .>>. many digit |>> fun (first,rest) -> first + concatList rest ])

    static member PAtom =
        (choice
            [NumlParser.PNumber |>> Atom.Number
             NumlParser.PString |>> Atom.String
             NumlParser.Bool |>> Atom.Bool
             NumlParser.PNil |>> Atom.Nil ])
        |>> Exp.Atom

    static member PTuple = (pstring "(" >>. NumlParser.PExpList .>> pstring ",)") |>> Exp.ExpTuple

    static member PExpList =
        ((NumlParser.PExp .>>. many(Comma >>. NumlParser.PExp)) |>> fun (a,b) -> a :: b)

    static member PExp =
        (choice
            [NumlParser.PAtom
             NumlParser.PTuple
             NumlParser.PWhere
             NumlParser.PLambda
             (Id |>> Variable)
             NumlParser.PInfixOp
             NumlParser.PInfixOp
             NumlParser.PCall
             NumlParser.PBranch
             NumlParser.PArray
             (pstring "(" >>. NumlParser.PExp .>> pstring ")") ])

    static member PInfixOp =
        ((NumlParser.PExp .>>. NumlParser.POpInfix) .>>. NumlParser.PExp
         |>> fun ((a,op),b) -> {left = a;op = op;right = b})
        |>> Exp.Infix

    static member Bind =
        ((Id .>> pstring "=") .>>. NumlParser.PExp)
        |>> fun (name,exp) -> {name = name;exp = exp}

    static member PWhere =
        let binds =
            (((NumlParser.Bind |>> fun b -> [b])
              .>>. (opt(many(Comma >>. NumlParser.Bind) .>> KW_End) |>> Option.defaultValue []))
             |>> fun (a,b) -> a @ b) in

        ((NumlParser.PExp .>> KW_Where) .>>. binds) |>> Exp.Where

    static member PLambda =
        (((KW_Funct >>. NumlParser.FunctArgs) .>> pstring "==>") .>>. NumlParser.PExp)
        |>> Exp.Lambda

    static member FunctArgs = many1 NumlParser.Arg

    static member Arg: Parser<Arg,unit> =
        (Id .>>. opt(pstring ":" >>. NumlParser.Type))
        |>> fun (name,_type) -> {name = name;_type = _type}

    static member Type =
        choice
            [Id |>> Type.Flat
             NumlParser.TupleType |>> Type.TypeTuple
             NumlParser.ArrayType |>> Type.TypeArray ]



    //'(' type (',' type)* ',)'
    static member TupleType =
        (((pstring "(" >>. NumlParser.Type) .>>. many(Comma >>. NumlParser.Type))
         .>> pstring ",)"
         |>> fun (a,b) -> a :: b)


    static member ArrayType = (pstring "[" >>. NumlParser.Type .>> pstring "]" |>> Type.TypeArray)

    static member PCall =
        (((opt(NativeVarPrefix |>> fun _ -> true) |>> Option.defaultValue false)
          .>>. Id
          .>>. (many1 NumlParser.PExp))
         |>> fun ((is_native,name),args) ->
             {is_native = is_native
              name = name
              args = args})
        |>> Exp.Call


    static member PBranch =
        ((KW_If >>. NumlParser.PExp .>> KW_Then .>>. NumlParser.PExp .>> KW_Else
          .>>. NumlParser.PExp)
         |>> fun ((pred,_then),_else) ->
             {pred = pred
              _then = _then
              _else = _else})
        |>> Exp.Branch


    static member PArray = (pstring "[" >>. NumlParser.PExpList .>> pstring "]") |>> Exp.ExpArray