FSKalc/Program.fs

(* FSKalc, a simple calculator implemented as a tree-walker interpreter *)

open FParsec
open System

(* Lexer *)

let manyCharsBetween popen pclose pchar = popen >>? manyCharsTill pchar pclose
let anyStringBetween popen pclose = manyCharsBetween popen pclose anyChar

let pcomment: Parser<unit, unit> = (skipString "(*" |> anyStringBetween <| skipString "*)") |>> ignore
//let pwhitespace: Parser<unit, unit> = (pcomment <|> spaces) |> many1 |>> ignore
let pwhitespace = spaces

let pnumber: Parser<double, unit> = pfloat .>> pwhitespace
let pidentifier: Parser<string, unit> =
    let isIdentChar c = isLetter c || c = '_'

    many1SatisfyL isIdentChar "identifier" .>> pwhitespace

type Symbol =
    | Caret
    | Minus
    | Plus
    | Slash
    | Star
    | SlashSlash
    | Percent

let pleftparen = skipString "(" .>> pwhitespace
let prightparen = skipString ")" .>> pwhitespace
let pequal = skipString "=" .>> pwhitespace
let ppower = stringReturn "^" <| Caret .>> pwhitespace
let pminus = stringReturn "-" <| Minus .>> pwhitespace
let pplus = stringReturn "+" <| Plus .>> pwhitespace
let pstar = stringReturn "*" <| Star .>> pwhitespace
let pslashslash = skipString "/" >>? (stringReturn "/" <| SlashSlash .>> pwhitespace)
let pslash = stringReturn "/" <| Slash .>> pwhitespace
let ppercent = stringReturn "%" <| Percent .>> pwhitespace


(* Parser 

    - expressions prefixed by 'e'
    - statements prefixed by 's'

*)

// EXPRESSIONS

type Expression =
    | Number of double
    | VarGet of string
    | Grouping of Expression list
    | Power of Expression * List<Expression>
    | Negate of Expression
    | Factor of Expression * List<Symbol * Expression>
    | Term of Expression * List<Symbol * Expression>

let expr, exprref = createParserForwardedToRef()

// literals and function call

let enumber = pnumber |>> Number
let evarget = pidentifier |>> VarGet

// parentheses

let egrouping = pleftparen >>. (many1 expr) .>> prightparen |>> Grouping

let primary = enumber <|> evarget <|> egrouping

// power

let epower = choice [
    primary .>>.? many1 (ppower >>. primary) |>> Power
    primary
]

// unary

let enegate = choice [
    pminus >>? epower |>> Negate
    epower
]

// factor

let pfactorop = pstar <|> pslashslash <|> pslash <|> ppercent


let efactor = choice [
    enegate .>>.? many1 (pfactorop .>>. enegate) |>> Factor
    enegate
]


let ptermop = pplus <|> pminus

let eterm = choice [
    efactor .>>.? many1 (ptermop .>>. efactor) |>> Term
    efactor
]

do exprref := eterm

// STATEMENTS

type Statement =
    | ExprStatement of Expression
    | VarSet of string * Expression
    | FuncDef of string * List<string> * Expression

let sexprstmt = expr |>> ExprStatement

let sfuncdef = pidentifier .>>.? ((many1 pidentifier) .>>. (pequal >>. expr))  |>> (fun (a, (b, c)) -> FuncDef (a, b, c))

let svarset = pidentifier .>>.? (pequal >>. expr) |>> VarSet

let stmt = choice [
    sfuncdef // first, so it falls through if multiple args not provided
    svarset // second so it falls through if no =
    sexprstmt
]

// REPL oriented => only 1 statement at once
let program = pwhitespace >>. stmt

type Value =
    | Number of double
    | Native of string
    | Function of List<string> * Expression
    | Fail of string



// Store global variables
let mutable globals: Collections.Generic.Dictionary<string, Value> = new Collections.Generic.Dictionary<string, Value>()

// Native/builtin functions

globals["sin"] <- Native "sin"
globals["cos"] <- Native "cos"
globals["tan"] <- Native "tan"

globals["arccos"] <- Native "arccos"
globals["arcsin"] <- Native "arcsin"
globals["arctan"] <- Native "arctan"

globals["sqrt"] <- Native "sqrt"
globals["log"] <- Native "log"
globals["ln"] <- Native "ln"
globals["exp"] <- Native "exp"


// native values

globals["pi"] <- Number Math.PI
globals["tau"] <- Number Math.Tau
globals["e"] <- Number Math.E
globals["inf"] <- Number infinity
globals["nan"] <- Number nan
globals["ans"] <- Number 0


// exec

let varGet key =
    let suc, value = globals.TryGetValue(key)
    match suc with
    | true -> value
    | false -> $"Attempt to get the value of undefined global variable {key}." |> Fail

let applyOp op left right = 
    match op, left, right with
    | Plus, Number x, Number y -> Number (x + y)
    | Minus, Number x, Number y -> Number (x - y)
    | Star, Number x, Number y -> Number (x * y)
    | Slash, Number x, Number y -> Number (x / y)
    | Percent, Number x, Number y -> Number (x % y)
    | SlashSlash, Number x, Number y -> Number (floor x / y)
    | Caret, Number x, Number y -> Number (x ** y)
    | _ -> Fail $"Invalid operation {op} on {left} and {right}."

let negate value =
    match value with
    | Number x -> Number -x
    | _ -> Fail $"Attempt to negate invalid type {value}."

let rec execExpr expr =
    match expr with
    | Expression.Number num -> Number num
    | VarGet key -> varGet key
    | Factor (left, rights)
    | Term (left, rights) ->
        // left associative ops
        let mutable res = execExpr left
        for (op, right) in rights do
            res <- execExpr right |> applyOp op res
        res
    | Negate expr -> negate <| execExpr expr
    | Power (left, rights) ->
        // right associative ops
        // parser only creates a power node if rights contains at least 1 element
        let mutable res = execExpr rights[rights.Length - 1]
        let mutable x = rights.Length - 2
        while x > 0 do
            res <- applyOp Caret (execExpr rights[x]) res
            x <- x - 1
        applyOp Caret (execExpr left) res
    | Grouping exprs ->
        match exprs.Length with
        | 1 -> execExpr exprs.Head
        | 0 -> Fail "() is an invalid expression"
        | _ ->
            let func = exprs.Head |> execExpr
            let args = exprs.Tail |> List.map execExpr

            match func with
            | Function (parameters, f) ->
                // function call
                let argLen = args.Length
                let paramLen = parameters.Length
                if paramLen <> argLen then
                    Fail $"Invalid number of arguments, expected {paramLen}, got {argLen}"
                else
                    List.iter2 (fun k v -> globals[k] <- v) parameters args
                    execExpr f
            | Native n ->
                // native call TODO
                func
            | _ -> Fail $"Attempt to call an invalid type {func}"

let printValue value =
    match value with
    | Number x -> printfn "%A" x
    | _ -> printfn "%A" value

let execStmt stmt =
    match stmt with
    | ExprStatement expr -> 
        let res = execExpr expr 
        globals["ans"] <- res
        printValue res
    | VarSet (name, expr) ->
        let res = execExpr expr
        globals[name] <- res
        printValue res
    | FuncDef (name, parameters, expr) -> globals[name] <- Function (parameters, expr)

printfn "FSKalc"
while true do
    let source = Console.ReadLine ()
    match run program source with
    | Success(result, _, _) ->
        execStmt result
    | Failure(errorMsg, _, _) -> printfn "Parser error: %s" errorMsg