Forth - Exercism

Forth.fs

module Forth

type Token = 
    | IntegerLiteral of int
    | WordDefinitionStart
    | WordName of string
    | WordDefinitionEnd

type Stack = int list
type FMachine = {
    Stack : Stack;
    Words : Map<string, List<Opcode>>;
}
and Opcode = 
    | PushInt  of int
    | CallWord of string
    | DefnWord of string * List<Opcode>
    | Builtin  of string * (Stack -> Stack)

    
let tokenize input = 
    let regex r =  new System.Text.RegularExpressions.Regex(r)
    
    let lexer = regex @"((?<lexeme>(\w[\w-_]*|-?\d+|[+-/*;:]))\s*)*"
    let matches = lexer.Match(input)

    [ for l in matches.Groups.["lexeme"].Captures do 
        let lexeme = l.Value.ToUpper() 
        let token = 
            match lexeme with
            | ":"    -> WordDefinitionStart
            | ";"    -> WordDefinitionEnd
            | lexeme -> match System.Int32.TryParse lexeme with
                        | true, intval -> IntegerLiteral intval
                        | false, _     -> WordName lexeme
        yield token
    ]

let parse tokens =
    let lookahead tokens = 
        let isTerminator t = match t with
                                | WordDefinitionEnd -> true
                                | _ -> false

        let idx = List.findIndex isTerminator tokens

        let lead = List.take idx tokens
        let tail = List.skip (idx + 1) tokens

        lead, tail

    let rec parseTokens ops tokens : List<Opcode> =
        match tokens with
        | [] -> List.rev ops
        | IntegerLiteral i    :: rest -> parseTokens (PushInt i :: ops) rest
        | WordName word       :: rest -> parseTokens (CallWord word :: ops) rest
        | WordDefinitionStart :: rest ->
            match lookahead rest with
            | (WordName word :: defn), rest -> 
                let parsedDefn = parseTokens [] defn
                parseTokens (DefnWord (word, parsedDefn):: ops) rest
            | _ -> failwith "Expected a word name after word definition operator"
        | WordDefinitionEnd :: _ -> failwith "Unexpected word definition terminator" // lookahead removes terminators for well-formed word definitions
        
    parseTokens [] tokens

let rec execute machine ops = 
    let inlineWords (words : Map<string,List<Opcode>>) defn = 
        let inliner op = 
            match op with
            | DefnWord (_,_)-> failwith "Unexpected nested word definition!" // cannot happen due to how lookahead operates!
            | CallWord word -> words.[word]
            | _             -> [ op ]

        defn |> List.collect inliner

    let rec evalOp machine op = 
        match op with
        | PushInt i             -> ({machine with Stack = i :: machine.Stack}, [])
        | DefnWord (word, defn) -> let inlined = inlineWords machine.Words defn
                                   ({machine with Words = machine.Words.Add(word, inlined) }, [])
        | CallWord word         -> let defn = machine.Words.[word]
                                   (machine, defn)
        | Builtin (word, code)  -> ({machine with Stack = code machine.Stack}, [])

    match ops with
    | [] -> machine
    | op :: rest -> let machine2, subroutine = evalOp machine op
                    execute machine2 <| List.append subroutine rest

let evaluate input =
    let InitBuiltinWord (word: string) f =
        let upper  = word.ToUpperInvariant()
        upper, [ Builtin (upper, f word) ]

    let BinaryOp f name stack = 
        match stack with
        | a :: b :: rest -> (f b a) :: rest
        | _ -> failwith <| sprintf "Binary operator '%s' needs at least 2 items on the stack" name
    
    let StackManipulationOp f name stack = 
        match stack with
        | a :: rest -> f a rest
        | _ -> failwith <| sprintf "Unary stack operator '%s' needs at least 1 item on the stack" name

    let StackManipulationBinaryOp f name stack = 
        match stack with
        | a :: b :: rest -> f a b rest
        | _ -> failwith <| sprintf "Binary stack operator '%s' needs at least 2 items on the stack" name
        
    let machine = { Stack = []; Words = Map.ofList [
        InitBuiltinWord "+"    <| BinaryOp (+);
        InitBuiltinWord "-"    <| BinaryOp (-);
        InitBuiltinWord "*"    <| BinaryOp (*);
        InitBuiltinWord "/"    <| BinaryOp (/);
        InitBuiltinWord "DUP"  <| StackManipulationOp (fun a rest -> a::a::rest)
        InitBuiltinWord "DROP" <| StackManipulationOp (fun a rest -> rest)
        InitBuiltinWord "SWAP" <| StackManipulationBinaryOp (fun a b rest -> b::a::rest)
        InitBuiltinWord "OVER" <| StackManipulationBinaryOp (fun a b rest -> b::a::b::rest)
    ]}

    try
        let machine = 
            input 
            |> List.collect (tokenize >> parse)
            |> execute machine
        Some ( machine.Stack |> List.rev)
    with
    | _ -> None

Forth.fsproj

<Project Sdk="Microsoft.NET.Sdk">

  <PropertyGroup>
    <TargetFramework>netcoreapp3.0</TargetFramework>

    <IsPackable>false</IsPackable>
  </PropertyGroup>

  <ItemGroup>
    <Compile Include="Forth.fs" />
    <Compile Include="ForthTests.fs" />
  </ItemGroup>

  <ItemGroup>
    <PackageReference Include="Microsoft.NET.Test.Sdk" Version="16.6.1" />
    <PackageReference Include="xunit" Version="2.4.1" />
    <PackageReference Include="xunit.runner.visualstudio" Version="2.4.2" />
    <PackageReference Include="FsUnit.xUnit" Version="3.8.1" />
  </ItemGroup>

</Project>

ForthTests.fs

// This file was auto-generated based on version 1.7.1 of the canonical data.

module ForthTests

open FsUnit.Xunit
open Xunit

open Forth

[<Fact>]
let ``Parsing and numbers - numbers just get pushed onto the stack`` () =
    let expected = Some [1; 2; 3; 4; 5]
    evaluate ["1 2 3 4 5"] |> should equal expected

[<Fact>]
let ``Addition - can add two numbers`` () =
    let expected = Some [3]
    evaluate ["1 2 +"] |> should equal expected

[<Fact>]
let ``Addition - errors if there is nothing on the stack`` () =
    let expected = None
    evaluate ["+"] |> should equal expected

[<Fact>]
let ``Addition - errors if there is only one value on the stack`` () =
    let expected = None
    evaluate ["1 +"] |> should equal expected

[<Fact>]
let ``Subtraction - can subtract two numbers`` () =
    let expected = Some [-1]
    evaluate ["3 4 -"] |> should equal expected

[<Fact>]
let ``Subtraction - errors if there is nothing on the stack`` () =
    let expected = None
    evaluate ["-"] |> should equal expected

[<Fact>]
let ``Subtraction - errors if there is only one value on the stack`` () =
    let expected = None
    evaluate ["1 -"] |> should equal expected

[<Fact>]
let ``Multiplication - can multiply two numbers`` () =
    let expected = Some [8]
    evaluate ["2 4 *"] |> should equal expected

[<Fact>]
let ``Multiplication - errors if there is nothing on the stack`` () =
    let expected = None
    evaluate ["*"] |> should equal expected

[<Fact>]
let ``Multiplication - errors if there is only one value on the stack`` () =
    let expected = None
    evaluate ["1 *"] |> should equal expected

[<Fact>]
let ``Division - can divide two numbers`` () =
    let expected = Some [4]
    evaluate ["12 3 /"] |> should equal expected

[<Fact>]
let ``Division - performs integer division`` () =
    let expected = Some [2]
    evaluate ["8 3 /"] |> should equal expected

[<Fact>]
let ``Division - errors if dividing by zero`` () =
    let expected = None
    evaluate ["4 0 /"] |> should equal expected

[<Fact>]
let ``Division - errors if there is nothing on the stack`` () =
    let expected = None
    evaluate ["/"] |> should equal expected

[<Fact>]
let ``Division - errors if there is only one value on the stack`` () =
    let expected = None
    evaluate ["1 /"] |> should equal expected

[<Fact>]
let ``Combined arithmetic - addition and subtraction`` () =
    let expected = Some [-1]
    evaluate ["1 2 + 4 -"] |> should equal expected

[<Fact>]
let ``Combined arithmetic - multiplication and division`` () =
    let expected = Some [2]
    evaluate ["2 4 * 3 /"] |> should equal expected

[<Fact>]
let ``Dup - copies a value on the stack`` () =
    let expected = Some [1; 1]
    evaluate ["1 dup"] |> should equal expected

[<Fact>]
let ``Dup - copies the top value on the stack`` () =
    let expected = Some [1; 2; 2]
    evaluate ["1 2 dup"] |> should equal expected

[<Fact>]
let ``Dup - errors if there is nothing on the stack`` () =
    let expected = None
    evaluate ["dup"] |> should equal expected

[<Fact>]
let ``Drop - removes the top value on the stack if it is the only one`` () =
    let expected: int list option = Some []
    evaluate ["1 drop"] |> should equal expected

[<Fact>]
let ``Drop - removes the top value on the stack if it is not the only one`` () =
    let expected = Some [1]
    evaluate ["1 2 drop"] |> should equal expected

[<Fact>]
let ``Drop - errors if there is nothing on the stack`` () =
    let expected = None
    evaluate ["drop"] |> should equal expected

[<Fact>]
let ``Swap - swaps the top two values on the stack if they are the only ones`` () =
    let expected = Some [2; 1]
    evaluate ["1 2 swap"] |> should equal expected

[<Fact>]
let ``Swap - swaps the top two values on the stack if they are not the only ones`` () =
    let expected = Some [1; 3; 2]
    evaluate ["1 2 3 swap"] |> should equal expected

[<Fact>]
let ``Swap - errors if there is nothing on the stack`` () =
    let expected = None
    evaluate ["swap"] |> should equal expected

[<Fact>]
let ``Swap - errors if there is only one value on the stack`` () =
    let expected = None
    evaluate ["1 swap"] |> should equal expected

[<Fact>]
let ``Over - copies the second element if there are only two`` () =
    let expected = Some [1; 2; 1]
    evaluate ["1 2 over"] |> should equal expected

[<Fact>]
let ``Over - copies the second element if there are more than two`` () =
    let expected = Some [1; 2; 3; 2]
    evaluate ["1 2 3 over"] |> should equal expected

[<Fact>]
let ``Over - errors if there is nothing on the stack`` () =
    let expected = None
    evaluate ["over"] |> should equal expected

[<Fact>]
let ``Over - errors if there is only one value on the stack`` () =
    let expected = None
    evaluate ["1 over"] |> should equal expected

[<Fact>]
let ``User-defined words - can consist of built-in words`` () =
    let expected = Some [1; 1; 1]
    evaluate [": dup-twice dup dup ;"; "1 dup-twice"] |> should equal expected

[<Fact>]
let ``User-defined words - execute in the right order`` () =
    let expected = Some [1; 2; 3]
    evaluate [": countup 1 2 3 ;"; "countup"] |> should equal expected

[<Fact>]
let ``User-defined words - can override other user-defined words`` () =
    let expected = Some [1; 1; 1]
    evaluate [": foo dup ;"; ": foo dup dup ;"; "1 foo"] |> should equal expected

[<Fact>]
let ``User-defined words - can override built-in words`` () =
    let expected = Some [1; 1]
    evaluate [": swap dup ;"; "1 swap"] |> should equal expected

[<Fact>]
let ``User-defined words - can override built-in operators`` () =
    let expected = Some [12]
    evaluate [": + * ;"; "3 4 +"] |> should equal expected

[<Fact>]
let ``User-defined words - can use different words with the same name`` () =
    let expected = Some [5; 6]
    evaluate [": foo 5 ;"; ": bar foo ;"; ": foo 6 ;"; "bar foo"] |> should equal expected

[<Fact>]
let ``User-defined words - can define word that uses word with the same name`` () =
    let expected = Some [11]
    evaluate [": foo 10 ;"; ": foo foo 1 + ;"; "foo"] |> should equal expected

[<Fact>]
let ``User-defined words - cannot redefine numbers`` () =
    let expected = None
    evaluate [": 1 2 ;"] |> should equal expected

[<Fact>]
let ``User-defined words - errors if executing a non-existent word`` () =
    let expected = None
    evaluate ["foo"] |> should equal expected

[<Fact>]
let ``Case-insensitivity - DUP is case-insensitive`` () =
    let expected = Some [1; 1; 1; 1]
    evaluate ["1 DUP Dup dup"] |> should equal expected

[<Fact>]
let ``Case-insensitivity - DROP is case-insensitive`` () =
    let expected = Some [1]
    evaluate ["1 2 3 4 DROP Drop drop"] |> should equal expected

[<Fact>]
let ``Case-insensitivity - SWAP is case-insensitive`` () =
    let expected = Some [2; 3; 4; 1]
    evaluate ["1 2 SWAP 3 Swap 4 swap"] |> should equal expected

[<Fact>]
let ``Case-insensitivity - OVER is case-insensitive`` () =
    let expected = Some [1; 2; 1; 2; 1]
    evaluate ["1 2 OVER Over over"] |> should equal expected

[<Fact>]
let ``Case-insensitivity - user-defined words are case-insensitive`` () =
    let expected = Some [1; 1; 1; 1]
    evaluate [": foo dup ;"; "1 FOO Foo foo"] |> should equal expected

[<Fact>]
let ``Case-insensitivity - definitions are case-insensitive`` () =
    let expected = Some [1; 1; 1; 1]
    evaluate [": SWAP DUP Dup dup ;"; "1 swap"] |> should equal expected