Funk in Funk (very much unfinished)

compiler.fnk

;;;;;;;;;;
; Prelude
;;;;;;;;;;

if := {
    |True body _| body()
    |False _ body| body()
}

when := {
    |True body| body()
    |False _|
}

switch := {|x f| f x}


;;;;;;;;;;
; Tokenizer
;;;;;;;;;;

lexFunk := {|code|
    offset := new(0)
    currentLine := new(1)
    bracketStack := ["{"]

    at := {|chars|
        c := code CharAt (*offset)
        0 Until (chars Size) Any {chars CharAt _ == c}
    }

    consume := {|tag chars| consumeAt tag chars chars}

    consumeAt := {|tag prefix chars|
        if(at prefix) {
            from := *offset
            line := *currentLine
            while {at chars} { offset += 1 }
            value := code Slice from (*offset)
            skipWhitespace(False)
            {|Tag| tag |Line| line |Value| value}
        } {
            {|Tag| Empty}
        }
    }

    consumeOne := {|tag char|
        if(code CharAt (*offset) == char) {
            from := *offset
            line := *currentLine
            offset += 1
            when(char == "{" || char == "[" || char == "(") { bracketStack Push char }
            when(char == "}" || char == "]" || char == ")") { bracketStack Pop }
            skipWhitespace(char == "{")
            {|Tag| tag |Line| line}
        } {
            {|Tag| Empty}
        }
    }

    skipWhitespace := {|forceIgnoreLine|
        c := code CharCodeAt (*offset)
        ignoreLine := forceIgnoreLine || bracketStack Top {|Some b| b != "{" |None| False}
        when(c == 0 || c == 32 || (ignoreLine && (c == 10 || c == 13)) || c == 59) {
            if(c == 59) {
                while { code CharCodeAt (*offset) != 10 && *offset < code Size } {
                    offset += 1
                }
            } {
                when(c == 10) { currentLine += 1 }
                offset += 1
            }
            skipWhitespace(forceIgnoreLine)
        }
    }

    lexString := {
        c := code CharCodeAt (*offset)
        if(c == 34) {
            from := *offset
            line := *currentLine
            offset += 1
            while {code CharCodeAt (*offset) != 34} { offset += 1 }
            offset += 1
            value := code Slice (from + 1) (*offset - 1)
            skipWhitespace(False)
            {|Tag| String |Line| line |Value| value}
        } {
            {|Tag| Empty |Value| ""}
        }
    }

    lexOperator := {
        operator := consume Operator "!@#$%&/=?+|^~*-:.<>"
        if(operator Tag == "Empty") {
            operator
        } {
            switch(operator Value) {
                |"|"| {|Tag| Pipe |Line| operator Line}
                |"."| {|Tag| Dot |Line| operator Line}
                |"||"| {|Tag| And |Line| operator Line}
                |"&&"| {|Tag| Or |Line| operator Line}
                |":="| {|Tag| Define |Line| operator Line}
                |"="| {|Tag| Assign |Line| operator Line}
                |"+="| {|Tag| Increment |Line| operator Line}
                |"-="| {|Tag| Decrement |Line| operator Line}
                |"*="| {|Tag| Multiply |Line| operator Line}
                |_| operator
            }
        }
    }
    lexLower := {consumeAt Lower "abcdefghijklmnopqrstuvwxyz" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"}
    lexUpper := {consumeAt String "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"}
    lexNumber := {consume Number "0123456789"}

    lexToken := {
        c := code CharCodeAt (*offset)
        if(c == 10 || c == 13) {
            line := *currentLine
            skipWhitespace(True)
            {|Tag| Line |Line| line}
        } {
            token := new {|Tag| Empty}
            when((*token) Tag == Empty) { token = lexNumber() }
            when((*token) Tag == Empty) { token = lexUpper() }
            when((*token) Tag == Empty) { token = lexLower() }
            when((*token) Tag == Empty) { token = lexOperator() }
            when((*token) Tag == Empty) { token = lexString() }
            when((*token) Tag == Empty) { token = consumeOne LeftRound "(" }
            when((*token) Tag == Empty) { token = consumeOne RightRound ")" }
            when((*token) Tag == Empty) { token = consumeOne LeftSquare "[" }
            when((*token) Tag == Empty) { token = consumeOne RightSquare "]" }
            when((*token) Tag == Empty) { token = consumeOne LeftCurly "{" }
            when((*token) Tag == Empty) { token = consumeOne RightCurly "}" }
            when((*token) Tag == Empty) { token = consumeOne Comma "," }
            when((*token) Tag == Empty) { token = consumeOne Wildcard "_" }
            *token
        }
    }

    skipWhitespace(True)
    tokens := []
    token := new(lexToken())
    while {(*token) Tag != Empty} {
        tokens Push (*token)
        token = lexToken()
    }
    when((*offset) != code Size) {
        system Throw ("Unexpected character '" + code CharAt (*offset) + "' at line " + (*currentLine))
    }
    tokens

}

;;;;;;;;;;
; Parser
;;;;;;;;;;


parseFunk := {|code|
    
    tokens := lexFunk(code)
    offset := new(0)

    empty := {|Tag| Empty}
    any := {|rules|
        rules Head {
            |None| empty
            |Some rule| 
                result := rule()
                switch(result Tag) {
                    |Empty| any(rules Drop 1)
                    |_| result
                }
        }
    }
    sequence := {|rule separator|
        list := []
        parsed := new(rule())
        done := new(False)
        while { (*parsed) Tag != Empty && !(*done) } {
            list Push (*parsed)
            parsed = rule()
            done = separator() Tag == Empty
        }
        list
    }

    current := { tokens Get (*offset) {|Some x| x |None| empty} }
    ahead := { tokens Get (*offset + 1) {|Some x| x |None| empty} }
    next := { offset += 1 }

    parseToken := {|tag| 
        if(current() Tag == tag) { 
            result := current()
            next()
            result 
        } { 
            empty 
        }
    }
    parseLine := { parseToken Line }
    parseLower := { parseToken Lower }
    parseUpper := { parseToken Upper }
    parseNumber := { parseToken Number }
    parseString := { parseToken String }

    parseLambda := {
        if(current() Tag != LeftCurly) { empty } {
            line := current() Line
            next()
            if(current() Tag != Pipe) {
                statements := parseStatements()
                when(current() Tag != RightCurly) {
                    system Throw ("Expected '}' after function at line " + line)
                }
                next()
                pattern := {|Tag| Wildcard |Line| line}
                cases := {|Tag| Case |Line| line |Pattern| pattern |Body| statements}
                {|Tag| Function |Line| line |Cases| cases}
            } {
                cases := []
                while {current() Tag == Pipe} {
                    next()
                    primaryPattern := any [parseUpper, parseNumber, parseString, parseLower]
                    when(primaryPattern Tag == Empty) {
                        when(current() != Wildcard) {
                            system Throw ("Expected '_' wildcard pattern at line " + (current() Line))
                            next()
                        }
                    }
                    extraPatterns := []
                    extraPattern := new(parseLower())
                    while { (*extraPattern) Tag != Empty || current() Tag == Wildcard } {
                        when((*extraPattern) Tag == Empty) { next() }
                        extraPatterns Push (*extraPattern)
                        extraPattern = parseLower()
                    }
                    when(current() Tag != Pipe) {
                        system Throw ("Expected '|' after pattern at line " + (current() Line))
                    }
                    next()
                    statements := new(parseStatements())
                    extraPatterns Reverse Each {|extra|
                        body := *statements
                        extraCases := {|Tag| Case |Line| extra Line |Pattern| extra |Body| body}
                        statement := {|Tag| Function |Line| extra Line |Cases| extraCases}
                        statements = [statement]
                    }
                    case := {|Tag| Case |Line| line |Pattern| primaryPattern |Body| *statements}
                    cases Push case
                }
                when(current() Tag != RightCurly) {
                    system Throw ("Expected '}' after function at line " + line)
                }
                next()
                {|Tag| Function |Line| line |Cases| cases}                
            }
        } 
    }

    parseTerm := {
        any [parseLambda, parseLower]
    }

    parseAssignment := {
        tag := ahead() Tag
        if(tag == Define || tag == Assign || tag == Increment || tag == Decrement || tag == Multiply) {
            line := (current() Line)
            when(current() Tag != Lower) {
                system Throw ("Expected variable before '=' at line " + line)
            }
            name := current() Value
            next()
            next()
            term := parseTerm()
            when(term Tag == Empty) {
                system Throw ("Expected term after '=' at line " + line)
            }
            {|Tag| tag |Line| line |Name| name |Value| term}                
        } { 
            parseTerm()
        }
    }

    parseStatements := {
        sequence parseAssignment parseLine
    }

    result := parseStatements()
    when(*offset < tokens Size) {
        system Throw ("Unexpected " + current() Token + " at line " + current() Line)
    }
    result
}


;;;;;;;;;;
; Emitter
;;;;;;;;;;


;lexFunk (system GetCode) Each {system Log (_ Tag)}

system Dir (parseFunk (system GetCode) Map {_ Tag})

;system Dir (parseFunk "{|x| x}" Map {_ Tag})