スクリプト言語の作り方の7日目のインタープリタをF#で。 FParsecと継続渡し形式を使って。

Env.fs

namespace FStone

module Env =
  type Env<'Key, 'Value when 'Key : comparison> = 
    private 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(parent)) (Env(child)) =
    Env(Map.ofList ((Map.toList parent) @ (Map.toList child)))

  let update (Env(parent)) (Env(child)) =
    let intersection = child |> Map.filter (fun key _ -> parent |> Map.containsKey key)
    Env(Map.ofList ((Map.toList parent) @ (Map.toList intersection)))

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>
    | Var of string * Value
    | Args of Value list
    | Params of Value list
    | Undefined

  let assign env lhs rhs cont =
    match lhs, rhs with
    | Var(id, _), v -> cont (Env.add id v env) v
    | _ -> failwith (sprintf "%A is not variable." lhs)

  let matchNum env cont lhs rhs success otherwise =
    match lhs, rhs with
    | Var(_, Num(l)), Var(_, Num(r)) 
    | Var(_, Num(l)), Num(r) 
    | Num(l), Var(_, Num(r)) 
    | Num(l), Num(r) -> cont env (success l r)
    | _ -> cont env (otherwise())

  let evalBinaryOp env op lhs rhs cont =
      let unsupport() =
        failwith (sprintf "unsupported operation(%A) for %A and %A" op lhs rhs)
      match op with
      | Assign -> 
        assign env lhs rhs cont
      | Eq -> 
        matchNum env cont lhs rhs (fun l r -> Bool(l = r)) unsupport
      | Ne -> 
        matchNum env cont lhs rhs (fun l r -> Bool(l <> r)) unsupport
      | Gt ->
        matchNum env cont lhs rhs (fun l r -> Bool(l > r)) unsupport
      | Lt ->
        matchNum env cont lhs rhs (fun l r -> Bool(l < r)) unsupport
      | Plus ->
        matchNum env cont lhs rhs (fun l r -> Num(l + r)) unsupport
      | Minus ->
        matchNum env cont lhs rhs (fun l r -> Num(l - r)) unsupport
      | Multi -> 
        matchNum env cont lhs rhs (fun l r -> Num(l * r)) unsupport
      | Div ->
        matchNum env cont lhs rhs (fun l r -> Num(l / r)) unsupport
      | Mod -> 
        matchNum env cont lhs rhs (fun l r -> Num(l % r)) unsupport

  let rec 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, Undefined))
    | StringLiteral(s) -> 
      cont env (Str s)
    | BinaryExpr(op, lhs, rhs) ->
      eval env lhs (fun env lhs ->
      eval env rhs (fun env rhs -> 
        evalBinaryOp 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
        | [] -> 
          match result with
          | Var(_, blockResult) 
          | blockResult -> cont env blockResult
        | x :: xs -> 
          eval env x (fun env result -> loop env xs cont result)
      loop env statements cont Undefined
    | 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 Undefined )
    | 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, arguments) ->
      match arguments with
      | Some(arguments) ->
        eval env expr (fun exprEnv expr ->
        eval exprEnv arguments (fun argsEnv arguments ->
          match expr, arguments with
          | Var(id, Fun(parameters, block, funEnv)), Args(args) -> 
            eval argsEnv parameters (fun paramsEnv -> function
              | Params(``params``) ->
                let rec loop paramsEnv list = 
                  match list with
                  | [] -> 
                    eval (Env.merge funEnv paramsEnv) block (fun resultEnv result -> 
                      let f = Fun(parameters, block, Env.update funEnv resultEnv)
                      cont (Env.add id f argsEnv) result)
                  | (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))
          | _ -> failwith (sprintf "function %A is not found" expr)))
      | _ -> 
        eval env expr cont
    | FunExpr(parameters, block) ->
      let f = Fun(parameters, block, env)
      cont (Env.add (string(f.GetHashCode())) f env) f
    | ArgsExpr(arguments) ->
      let rec loop env list acc = 
        match list with
        | [] -> cont env (Args(List.rev acc))
        | x :: xs -> 
          eval env x (fun env value -> loop env xs (value :: acc))
      loop env arguments []
    | ParamsExpr(parameters) ->
      let rec loop env list acc = 
        match list with
        | [] -> cont env (Params(List.rev acc))
        | x :: xs -> 
          eval env x (fun env value -> loop env xs (value :: acc))
      loop env parameters []

FStoneTest.fs

namespace FStone

open FParsec
open NUnit.Framework

module FStoneTest =
  let parse str =
    run Parser.program str |> function
      | Success(result, _, _)   -> result
      | Failure(errorMsg, _, _) -> failwith errorMsg

  let eval str = 
    let ast = parse str
    Eval.eval Env.empty 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 fib``() =
    """
    def fib (n) {
      if n < 2 {
        n
      } else {
        fib(n - 1) + fib(n - 2)
      }
    }
    fib(6)
    """
    |> eval 
    |> function
      | Eval.Num(n) -> n |> isEqualTo 8
      | otherwise -> failwith (sprintf "%A" otherwise)

  [<Test>]
  let ``test closure``() =
    """
    def counter (c) {
      fun () { c = c + 1 }
    }
    c1 = counter(0)
    c2 = counter(0)
    c1()
    c1()
    c2()
    c1()
    """
    |> eval 
    |> function
      | Eval.Num(n) -> n |> isEqualTo 3
      | otherwise -> failwith (sprintf "%A" otherwise)

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

  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 option
    | FunExpr of Ast * Ast
    | ArgsExpr of Ast list
    | ParamsExpr of Ast list

  (* 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 opp = new OperatorPrecedenceParser<Ast,unit,unit>()
  let expr = opp.ExpressionParser

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

  let arguments = 
    between
      (ws >>. 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 primary = 
    ``fun`` <|>
    (NUMBER <|> 
     IDENTIFIER <|> 
     STRING <|> 
     between (str "(" .>> ws) (ws .>> str ")" .>> ws) expr) 
     .>>. opt arguments |>> PrimaryExpr

  opp.TermParser <- primary
  opp.AddOperator(InfixOperator("=", ws, 1, Associativity.Right, binaryExpr Assign))
  opp.AddOperator(InfixOperator("==", ws, 1, Associativity.Left, binaryExpr Eq))
  opp.AddOperator(InfixOperator("<>", ws, 1, Associativity.Left, binaryExpr Ne))
  opp.AddOperator(InfixOperator(">", ws, 2, Associativity.Left, binaryExpr Gt))
  opp.AddOperator(InfixOperator("<", ws, 2, Associativity.Left, binaryExpr Lt))
  opp.AddOperator(InfixOperator("+", ws, 3, Associativity.Left, binaryExpr Plus))
  opp.AddOperator(InfixOperator("-", ws, 3, Associativity.Left, binaryExpr Minus))
  opp.AddOperator(InfixOperator("*", ws, 4, Associativity.Left, binaryExpr Multi))
  opp.AddOperator(InfixOperator("/", ws, 4, Associativity.Left, binaryExpr Div))
  opp.AddOperator(InfixOperator("%", ws, 4, Associativity.Left, binaryExpr Mod))
  opp.AddOperator(PrefixOperator("-", ws, 5, true, negativeExpr))

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

  do 
    statementRef := 
      let simple = ws >>. expr
      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 def <|> statement) .>> ws .>> eof |>> BlockStmt