「スクリプト言語の作り方」の10日目の「やはり配列も使いたい」をF#で。 FParsecと継続渡し形式を使って。

Env.fs

namespace FStone

module Env =
  type Env<'Key, 'Value when 'Key : comparison> = 
    | Env of Map<'Key, 'Value>

  let empty = Env(Map.empty)

  let add key value (Env(m)) =
    Env(Map.add key value m)

  let tryFind key (Env(m)) =
    Map.tryFind key m

  let merge (Env(outer)) (Env(inner)) =
    Env(Map.ofList ((Map.toList outer) @ (Map.toList inner)))

  let private intersectMap lhs rhs = 
    rhs |> Map.filter (fun key _ -> lhs |> Map.containsKey key)

  let intersect (Env(outer)) (Env(inner)) =
    Env(intersectMap outer inner)

  let update (Env(outer)) (Env(inner)) =
    Env(Map.ofList ((Map.toList outer) @ (Map.toList (intersectMap outer inner))))

  let make m =
    Env(m)

    

Eval.fs

namespace FStone

open FStone
open FStone.Parser
open FStone.Env

module Eval =

  type Value =
    | Num of int
    | Str of string
    | Bool of bool
    | Fun of Ast * Ast * Env<string, Value>
    | NativeFun of (Env<string, Value> -> Value list -> Env<string, Value> * Value)
    | Var of string * Value
    | Class of Ast * Value option * Env<string, Value>
    | Obj of Env<string, Value>
    | Member of string * string * Value
    | Array of Value list
    | Element of string * int list * Value
    | Undef
 
  let rec resolveValue var =
    match var with
    | Var(_, v) -> resolveValue v
    | Member(_, memberId, Obj(env)) -> 
      match Env.tryFind memberId env with
      | Some v -> resolveValue v
      | None -> Undef
    | Element(_, indexList, Array(elements)) ->
      let rec loop elements indexList =
        match indexList with
        | x :: [] ->
          List.nth elements x
        | x :: xs ->
          match List.nth elements x with
          | Array elements -> loop elements xs
          | _ -> failwith "invalid index"
        | _ -> failwith "invalid index"
      let element = loop elements indexList
      resolveValue element
    | _ -> var

  let toString value =
    let invariant = System.Globalization.CultureInfo.InvariantCulture
    let rec serialize (buf:System.Text.StringBuilder) value =
      match value with
      | Num n -> buf.Append(n.ToString(invariant))
      | Str s -> buf.Append("\"").Append(s).Append("\"")
      | Bool b -> buf.Append(b.ToString().ToLowerInvariant())
      | Fun(_, block, _) -> buf.Append(sprintf "<fun:%s>" (string(block.GetHashCode())))
      | NativeFun f -> buf.Append(sprintf "<fun:%s>" (string f))
      | Var _ -> serialize buf (resolveValue value)
      | Class(body, _, _) -> buf.Append(sprintf "<class:%s>" (string(body.GetHashCode())))
      | Obj _ -> buf.Append("<obj:>")
      | Member _ -> serialize buf (resolveValue value)
      | Array array ->
        buf.Append("[") |>ignore
        for element in array do
          (serialize buf element).Append(", ") |> ignore
        if not (List.isEmpty array) then buf.Remove(buf.Length - 2, 2) |> ignore
        buf.Append("]")
      | Element _ -> serialize buf (resolveValue value)
      | Undef -> buf.Append("undef")
    let buf = serialize (new System.Text.StringBuilder()) (resolveValue value)
    buf.ToString()

  let assign env lhs rhs cont =
    match lhs, resolveValue rhs with
    | Var(id, _), value -> 
      let newEnv = Env.add id value env
      cont newEnv value
    | Member(objId, memberId, Obj(objEnv)), value ->
      let newObjEnv = Env.add memberId value objEnv
      let newObj = Obj(newObjEnv)
      let newEnv = Env.add objId newObj env
      cont newEnv value
    | Element(id, indexList, Array(elements)), value ->
      let rec loop elements indexList =
        match indexList with
        | x :: [] ->
          elements 
          |> List.mapi (fun i element -> 
            if i = x then value else element)
          |> Array
        | x :: xs ->
          elements 
          |> List.mapi (fun i element -> 
            if i = x then 
              match element with
              | Array elements -> loop elements xs
              | _ -> failwith "invalid index"
            else 
              element)
          |> Array
        | _ -> failwith "invalid index"
      let array = loop elements indexList
      let newEnv = Env.add id array env
      cont newEnv value
    | _ -> failwith (sprintf "%A is not a L-Value." lhs)

  let rec evalBinaryOp env lhs rhs cont map =
    eval env lhs (fun env lhs ->
    eval env rhs (fun env rhs -> 
      cont env (map(resolveValue lhs, resolveValue rhs))))

  and evalBinaryExpr env op lhs rhs cont =
      match op with
      | Dot ->
        eval env lhs (fun env lhs ->
          match lhs with
          | Var(objId, Obj(objEnv)) -> 
            let rhsEnv = Env.add "this" (Obj objEnv) objEnv
            eval rhsEnv rhs (fun resultEnv result -> 
              let obj = Obj(resultEnv)
              let newEnv = Env.add objId obj env
              match result with
              | Var(memberId, _) ->
                cont newEnv (Member(objId, memberId, obj))
              | _ ->
                cont newEnv result)
          | _ -> failwith (sprintf "unsupported operation(%s) for %A " (string op) lhs))
      | Assign -> 
        eval env lhs (fun env lhs ->
        eval env rhs (fun env rhs -> 
          assign env lhs rhs cont))
      | Eq -> 
        evalBinaryOp env lhs rhs cont (function
          | Num l, Num r -> Bool(l = r)
          | Str l, Str r -> Bool(l = r)
          | Bool l, Bool r -> Bool(l = r)
          | l, r -> failwith (sprintf "unsupported operation(%s) for %A and %A" (string op) l r))
      | Ne -> 
        evalBinaryOp env lhs rhs cont (function
          | Num l, Num r -> Bool(l <> r)
          | Str l, Str r -> Bool(l <> r)
          | Bool l, Bool r -> Bool(l <> r)
          | l, r -> failwith (sprintf "unsupported operation(%s) for %A and %A" (string op) l r))
      | Gt ->
        evalBinaryOp env lhs rhs cont (function
          | Num l, Num r -> Bool(l > r)
          | Str l, Str r -> Bool(l > r)
          | Bool l, Bool r -> Bool(l > r)
          | l, r -> failwith (sprintf "unsupported operation(%s) for %A and %A" (string op) l r))
      | Lt ->
        evalBinaryOp env lhs rhs cont (function
          | Num l, Num r -> Bool(l < r)
          | Str l, Str r -> Bool(l < r)
          | Bool l, Bool r -> Bool(l < r)
          | l, r -> failwith (sprintf "unsupported operation(%s) for %A and %A" (string op) l r))
      | Plus ->
        evalBinaryOp env lhs rhs cont (function
          | Num l, Num r -> Num(l + r)
          | Str l, Str r -> Str(l + r)
          | Str l, r -> Str(l + (toString r))
          | l, Str r -> Str((toString l) + r)
          | l, r -> Str((toString l) + (toString r)))
      | Minus ->
        evalBinaryOp env lhs rhs cont (function
          | Num l, Num r -> Num(l - r)
          | l, r -> failwith (sprintf "unsupported operation(%s) for %A and %A" (string op) l r))
      | Multi -> 
        evalBinaryOp env lhs rhs cont (function
          | Num l, Num r -> Num(l * r)
          | l, r -> failwith (sprintf "unsupported operation(%s) for %A and %A" (string op) l r))
      | Div ->
        evalBinaryOp env lhs rhs cont (function
          | Num l, Num r -> Num(l / r)
          | l, r -> failwith (sprintf "unsupported operation(%s) for %A and %A" (string op) l r))
      | Mod -> 
        evalBinaryOp env lhs rhs cont (function
          | Num l, Num r -> Num(l % r)
          | l, r -> failwith (sprintf "unsupported operation(%s) for %A and %A" (string op) l r))

  and eval env ast cont =
    match ast with
    | NumberLiteral n -> 
      cont env (Num n)
    | Name id -> 
      match Env.tryFind id env with
      | Some(v) -> cont env (Var(id, v))
      | None -> cont env (Var(id, Undef))
    | StringLiteral s -> 
      cont env (Str s)
    | BinaryExpr(op, lhs, rhs) ->
      evalBinaryExpr env op lhs rhs cont
    | NegativeExpr operand ->
      eval env operand (fun env operand ->
        match operand with
        | Num(n) -> cont env (Num(n * -1))
        | _ -> failwith (sprintf "%A is not number" operand))
    | BlockStmt statements ->
      let rec loop env statements cont result = 
        match statements with
        | [] -> cont env (resolveValue result)
        | x :: xs -> 
          eval env x (fun env result -> 
            loop env xs cont result)
      loop env statements cont Undef
    | IfStmt((cond, thenBlock), elseBlock) ->
      eval env cond (fun env cond -> 
        let doThen() =
          eval env thenBlock cont
        match cond with
        | Bool(c) when c = true -> doThen()
        | Num(n) when n <> 0 -> doThen()
        | Str(s) when s <> "" -> doThen()
        | _ -> 
          match elseBlock with
          | Some(block) -> eval env block cont
          | _ -> cont env Undef)
    | WhileStmt(cond, block) as whileStmt ->
      eval env cond (fun env cond -> 
        let doWhile() =
          eval env block (fun env _ -> eval env whileStmt cont)
        match cond with
        | Bool(c) when c = true -> doWhile()
        | Num(n) when n <> 0 -> doWhile()
        | Str(s) when s <> "" -> doWhile()
        | _ -> 
          cont env (Bool false) )
    | DefStmt(id, parameters, block) ->
      eval env id (fun env id ->
        match id with
        | Var(id, _) -> 
          let f = Fun(parameters, block, env)
          let env = Env.add id f env
          cont env f
        | _ -> failwith (sprintf "%A is not def." id))
    | PrimaryExpr(expr, postfixes) ->
      eval env expr (fun exprEnv expr ->
        let rec loopPostfixes env value postfixes cont =
          match postfixes with
          | [] -> cont env value
          | postfix :: tailPostfixes ->
            eval env postfix (fun argsEnv postfix ->
              match value, postfix with
              | Var(id, Fun(parameters, block, funEnv)), Array(args) -> 
                eval argsEnv parameters (fun paramsEnv -> function
                  | Array(``params``) ->
                    let rec loop paramsEnv list = 
                      match list with
                      | [] -> 
                        eval (Env.merge funEnv paramsEnv) block (fun resultEnv result -> 
                          let freeEnv = Env.intersect funEnv resultEnv 
                          let f = Fun(parameters, block, freeEnv)
                          let newEnv = Env.add id f (Env.update argsEnv freeEnv)
                          loopPostfixes newEnv result tailPostfixes cont)
                      | (param, arg) :: xs -> 
                        assign paramsEnv param arg (fun paramsEnv _ -> loop paramsEnv xs)
                    loop paramsEnv (List.zip ``params`` args)
                  | _ -> failwith (sprintf "parameters %A is not found" parameters))
              | Var(id, NativeFun(f)), Array(args) -> 
                let env, result = f exprEnv args
                loopPostfixes env result tailPostfixes cont
              | Var(id, Array(elements)), Num(n) ->
                loopPostfixes env (Element(id, [n], Array(elements))) tailPostfixes cont
              | Element(id, indexList, Array(elements)), Num(n) ->
                loopPostfixes env (Element(id, indexList @ [n], Array(elements))) tailPostfixes cont
              | _ -> failwith (sprintf "%A is not resolved" value))
        loopPostfixes env expr postfixes cont)
    | FunExpr(parameters, block) ->
      let f = Fun(parameters, block, env)
      let newEnv = Env.add (string (block.GetHashCode())) f env
      cont newEnv f
    | ArgsExpr elements
    | ParamsExpr elements
    | ElementsExpr elements ->
      let rec loop env list acc = 
        match list with
        | [] -> cont env (Array(List.rev acc))
        | x :: xs -> 
          eval env x (fun env value -> loop env xs (value :: acc))
      loop env elements []
    | ClassBodyExpr members ->
      let rec loop env members cont = 
        match members with
        | [] -> cont env Undef
        | x :: xs -> 
          eval env x (fun env result -> loop env xs cont)
      loop env members cont
    | ClassStmt(id, pid, body) ->
      eval env id (fun env id ->
        match id with
        | Var(id, _) -> 
          match pid with
          | Some(pid) ->
            eval env pid (fun env pid ->
              match pid with
              | Var(pid, pclass) ->
                match pclass with
                | Class(_) -> 
                  let cls = Class(body, Some(pclass), env)
                  let env = Env.add id cls env
                  cont env cls
                | _ -> failwith (sprintf "%A is not class." pid)
              | _ -> failwith (sprintf "%A is not found." pid))
          | _ ->
            let cls = Class(body, None, env)
            let env = Env.add id cls env
            cont env cls
        | _ -> failwith (sprintf "%A is not found." id))
    | NewExpr cls ->
      eval env cls (fun env cls -> 
        let rec loop cls cont =
          match cls with
          | Var(_, Class(body, parent, clsEnv)) 
          | Class(body, parent, clsEnv) ->
            match parent with
            | Some(parent) ->
              loop parent (fun resultEnv result -> 
                eval (Env.merge clsEnv resultEnv) body (fun resultEnv result -> 
                  cont resultEnv result))
            | _ ->
              eval clsEnv body (fun resultEnv result -> 
                cont resultEnv result)
          | otherwise -> failwith (sprintf "%A is not class. new operator not applied." cls)
        loop cls (fun resultEnv result ->
          cont env (Obj(resultEnv))))
    | IndexExpr index ->
      eval env index (fun env index ->
        cont env index)

  let emptyEnv = Env.empty

  open FParsec

  let nativeEnv() =
    let hadnleOneArg args map =
      match args with
      | x :: [] ->
        map (resolveValue x)
      | otherwise -> invalidArg "values" ("invalid arguments size: " + string (List.length args))

    let print env args =
      hadnleOneArg args (fun value ->
        System.Console.WriteLine(toString value)
        env, Undef)

    let length env args =
      hadnleOneArg args (function
        | Str(s) -> env, Num(String.length s)
        | otherwise -> invalidArg "values.[0]" (sprintf "unsupported type: %A" otherwise))

    let toInt env args =
      hadnleOneArg args (function
        | Str(s) -> env, Num(int s)
        | otherwise -> invalidArg "values.[0]" (sprintf "unsupported type: %A" otherwise))

    let startTime = System.DateTime.Now.Ticks
    let currentTime env args =
      match args with
      | [] -> env, (Num(int (System.DateTime.Now.Ticks - startTime)))
      | otherwise -> invalidArg "values" (sprintf "invalid arguments size: %d" (List.length args))

    let eval env args =
      hadnleOneArg args (function
        | Str(s) -> 
          let ast =
            run Parser.program s |> function
            | Success(result, _, _)   -> result
            | Failure(errorMsg, _, _) -> failwith errorMsg
          eval env ast (fun env result -> env, result)
        | otherwise -> invalidArg "values.[0]" ("unsupported type: " + string otherwise))

    Env.make (Map.ofList
      [
        "print", NativeFun(print)
        "length", NativeFun(length)
        "toInt", NativeFun(toInt)
        "currentTime", NativeFun(currentTime)
        "eval", NativeFun(eval)
      ])

Parser.fs

namespace FStone

open FParsec
open System.Text

module Parser =

  type P<'t> = Parser<'t, unit>

  (* ast *)
  type Op =
    | Assign
    | Eq
    | Ne
    | Gt
    | Lt
    | Plus
    | Minus
    | Multi
    | Div
    | Mod
    | Dot
    override this.ToString() =
      match this with
      | Assign -> "="
      | Eq -> "=="
      | Ne -> "<>"
      | Gt -> ">"
      | Lt -> "<"
      | Plus -> "+"
      | Minus -> "-"
      | Multi -> "*"
      | Div -> "/"
      | Mod -> "%"
      | Dot -> "."

  type Ast =
    | NumberLiteral of int
    | Name of string
    | StringLiteral of string
    | BinaryExpr of Op * Ast * Ast
    | NegativeExpr of Ast
    | BlockStmt of Ast list
    | IfStmt of (Ast * Ast) * Ast option
    | WhileStmt of Ast * Ast
    | DefStmt of Ast * Ast * Ast
    | PrimaryExpr of Ast * Ast list
    | FunExpr of Ast * Ast
    | ArgsExpr of Ast list
    | ParamsExpr of Ast list
    | ClassBodyExpr of Ast list
    | ClassStmt of Ast * Ast option * Ast
    | NewExpr of Ast
    | ElementsExpr of Ast list
    | IndexExpr of Ast

  (* lexer *)
  let str = pstring
  let comment : P<_> = pstring "#" >>. skipRestOfLine true
  let ws = skipSepBy spaces comment
  let NUMBER : P<_> = pint32 .>> ws |>> NumberLiteral  
  let STRING : P<_> =
    let escape = 
      anyOf "\"\\n" |>> function
      | 'n' -> "\n"
      | c   -> string c
    let escapedCharSnippet = pstring "\\" >>. (escape)
    let normalCharSnippet  = manySatisfy (fun c -> c <> '"' && c <> '\\')
    between (pstring "\"") (pstring "\"")
            (stringsSepBy normalCharSnippet escapedCharSnippet) .>> ws |>> StringLiteral
  let isIdentifierStart = fun c -> isAsciiLetter c || c = '_' // "A-Za-z_"
  let isIdentifierCont  = fun c -> isAsciiLetter c || isDigit c || c = '_' // A-Za-z_0-9
  let IDENTIFIER : P<_> = many1Satisfy2 isIdentifierStart isIdentifierCont .>> ws |>> Name

  (* parser *)
  let binaryExpr op lhs rhs = BinaryExpr(op, lhs, rhs)
  let negativeExpr operand = NegativeExpr(operand)
  let newExpr operand = NewExpr(operand)

  let opp = new OperatorPrecedenceParser<Ast,unit,unit>()
  let expr = opp.ExpressionParser

  let args : P<_> = sepEndBy expr (ws >>. pchar ',' .>> ws)

  let arguments = 
    between
      (pchar '(' .>> ws) (ws >>. pchar ')' .>> ws) 
      (args) |>> ArgsExpr

  let parameter = IDENTIFIER

  let parameters : P<_> = sepBy parameter (ws >>. pchar ',' .>> ws)
  
  let parameter_list = 
    between 
      (ws >>. pchar '(' .>> ws) (ws >>. pchar ')' .>> ws) 
      (parameters) |>> ParamsExpr

  let (statement, statementRef) : (P<Ast> * P<Ast> ref) = createParserForwardedToRef()
  
  let block = 
    between
      (ws >>. pchar '{' .>> ws) (ws >>. pchar '}' .>> ws) 
      (many statement)
   |>> BlockStmt 

  let ``fun`` = ws >>. str "fun" >>. ws >>. parameter_list .>>. block |>> FunExpr

  let dot = pchar '.' >>. IDENTIFIER

  let elements = sepBy expr (ws >>. pchar ',' .>> ws) |>> ElementsExpr

  let index = pchar '[' >>. ws >>. expr .>> ws .>> pchar ']' .>> ws |>> IndexExpr

  let primary = 
    ``fun`` <|>
    (NUMBER <|> 
     IDENTIFIER <|> 
     STRING <|>
     between (str "[" .>> ws) (ws .>> str "]" .>> ws) elements <|>
     between (str "(" .>> ws) (ws .>> str ")" .>> ws) expr)
     .>>. (many (index <|> arguments)) |>> PrimaryExpr

  opp.TermParser <- primary
  opp.AddOperator(InfixOperator("=", ws, 10, Associativity.Right, binaryExpr Assign))
  opp.AddOperator(InfixOperator("==", ws, 20, Associativity.Left, binaryExpr Eq))
  opp.AddOperator(InfixOperator("<>", ws, 20, Associativity.Left, binaryExpr Ne))
  opp.AddOperator(InfixOperator(">", ws, 30, Associativity.Left, binaryExpr Gt))
  opp.AddOperator(InfixOperator("<", ws, 30, Associativity.Left, binaryExpr Lt))
  opp.AddOperator(InfixOperator("+", ws, 40, Associativity.Left, binaryExpr Plus))
  opp.AddOperator(InfixOperator("-", ws, 40, Associativity.Left, binaryExpr Minus))
  opp.AddOperator(InfixOperator("*", ws, 50, Associativity.Left, binaryExpr Multi))
  opp.AddOperator(InfixOperator("/", ws, 50, Associativity.Left, binaryExpr Div))
  opp.AddOperator(InfixOperator("%", ws, 50, Associativity.Left, binaryExpr Mod))
  opp.AddOperator(PrefixOperator("-", ws, 60, true, negativeExpr))
  opp.AddOperator(PostfixOperator(".new", ws, 70, true, newExpr))
  opp.AddOperator(InfixOperator(".", ws, 80, Associativity.Left, binaryExpr Dot))

  let def = 
    ws 
    >>. str "def" 
    >>. ws 
    >>. pipe3 IDENTIFIER (parameter_list) block (fun x y z -> x, y, z) |>> DefStmt

  let simple = ws >>. expr

  let ``member`` = attempt def <|> simple

  let class_body = 
    between
      (ws >>. pchar '{' .>> ws) (ws >>. pchar '}' .>> ws) 
      (many ``member``)
   |>> ClassBodyExpr 

  let defclass = 
    ws 
    >>. str "class" 
    >>. ws 
    >>. pipe3 IDENTIFIER (opt (str "extends" >>. ws >>. IDENTIFIER)) class_body (fun x y z -> x, y, z) |>> ClassStmt

  do 
    statementRef := 
      let ifStmt = ws .>> str "if" >>. simple .>>. block .>>. opt (str "else" >>. block) |>> IfStmt
      let whileStmt = ws .>> str "while" >>. simple .>>. block |>> WhileStmt  
      attempt ifStmt <|> attempt whileStmt <|> simple

  let program = many (attempt defclass <|> attempt def <|> statement) .>> ws .>> eof |>> BlockStmt 

Test.fs

namespace FStone
 
open FParsec
open NUnit.Framework
 
module Test =

  let parse str =
    run Parser.program str |> function
      | Success(result, _, _)   -> result
      | Failure(errorMsg, _, _) -> failwith errorMsg
 
  let eval env str = 
    let ast = parse str
    Eval.eval env ast (fun _  result -> result) 
 
  let isEqualTo expected actual = 
    if (expected <> actual) then
      let msg = sprintf "expected:\n%A\n actual:\n%A" expected actual 
      raise <| System.Exception(msg)

  [<Test>]
  let ``test array``() =
    let n = System.Environment.NewLine
    use out = new System.IO.StringWriter()
    System.Console.SetOut(out)
    """
    a = [2, 3, 4]
    print(a[1])
    a[1] = "three"
    print("a[1]: " + a[1])
    b = [["one", 1], ["two", 2]]
    print(b[1][0] + ":" + b[1][1])
    """
    |> eval (Eval.nativeEnv())
    |> function
      | Eval.Undef -> 
        string out 
        |> isEqualTo ("3" + n + "\"a[1]: three\"" + n + "\"two:2\"" + n)
      | otherwise -> failwith (sprintf "%A" otherwise)