🐫

README.md

https://gist.github.com/314maro/9524814 をF#+FParsecで書いた

ラムダ

🐫 変数👉 式

括弧

🌜 式🌛

コメント

未実装 🌝 コメ🌝 ネストできる🌞 ント🌞

例

🐫 🐭 👉 🐫 🐮 👉 🐫 🐯 👉 🐭 🐯 🌜 🐮 🐯 🌛 🌝 Sコンビネータ🌞

rakuda.fs

// F# の詳細については、http://fsharp.net を参照してください
// 詳細については、'F# チュートリアル' プロジェクトを参照してください。
open FParsec.Primitives
open FParsec.CharParsers
open FParsec.Error
open FParsec
open System.Collections.Generic
type RakudaFunc = {
    FunctionBody: SynExpr
    Var: VariableScope
    ArgName: string
    }
and SynConst = 
    | Int of int32
    | String of string
    | Function of RakudaFunc
    | Bool of bool
    | Unit
and SynExpr = 
    | Lambda of string * SynExpr
    | Variable of string
    | Const of SynConst
    | Plus of SynExpr * SynExpr
    | Minus of SynExpr * SynExpr
    | Mul of SynExpr * SynExpr
    | Div of SynExpr * SynExpr
    | Mod of SynExpr * SynExpr
    | Equal of SynExpr * SynExpr
    | NotEqual of SynExpr * SynExpr
    | FuncApp of SynExpr * SynExpr
    | Let of string * SynExpr
    | Comma of SynExpr * SynExpr
    | Conditional of SynExpr * SynExpr * SynExpr
and VariableScope = {
    Parent: option<VariableScope>
    VarMap: Dictionary<string, SynConst>
    }
let emoemo e = match e with
                | "🐫"|"👉"|"🌜"|"🌛"|"🌝"|"🌞" -> false
                | other -> true
let variable2str v = v//new string(List.toArray v)
let variable = (
                (next2CharsSatisfy
                    (fun c -> fun d ->
                        if System.Char.IsSurrogatePair (c, d) then emoemo ((string c) + (string d)) else false)) >>. anyString 2)
                    <|> (many1Satisfy2 (fun c -> isLetter c || c = '_') (fun c -> isLetter c || isDigit c || c = '_'))


let lambda, lambdaref = createParserForwardedToRef<SynExpr, 'b>()
let expr, exprref = createParserForwardedToRef<SynExpr, 'b>()
//http://blog.livedoor.jp/gab_km/archives/1437534.html
let stringLiteral =
    let escape = anyOf "\"\\/bfnrt"
                 |>> function
                     | 'b' -> "\b"
                     | 'f' -> "\u000C"
                     | 'n' -> "\n"
                     | 'r' -> "\r"
                     | 't' -> "\t"
                     | c   -> string c // その他の文字はそのままにします
    let unicodeEscape =
        // 16進文字 ([0-9a-fA-F]) を数値 (0-15) に変換します
        let hex2int c = (int c &&& 15) + (int c >>> 6)*9

        pstring "u" >>. pipe4 hex hex hex hex (fun h3 h2 h1 h0 ->
            (hex2int h3)*4096 + (hex2int h2)*256 + (hex2int h1)*16 + hex2int h0
            |> char |> string
        )

    let escapedCharSnippet = pstring "\\" >>. (escape <|> unicodeEscape)
    let normalCharSnippet  = manySatisfy (fun c -> c <> '"' && c <> '\\')

    between (pstring "\"") (pstring "\"")
            (stringsSepBy normalCharSnippet escapedCharSnippet)
let literal = (pint32 |>> Int) <|> (stringLiteral |>> String) <|> (pstring "false" |>> fun v -> Bool(false)) <|> (pstring "true" |>> fun v -> Bool(true))
//http://www.quanttec.com/fparsec/reference/operatorprecedenceparser.html
let opp = new OperatorPrecedenceParser<_,_,_>()

let ws = spaces

type Assoc = Associativity

let adjustPosition offset (pos: Position) =
    Position(pos.StreamName, pos.Index + int64 offset,
             pos.Line, pos.Column + int64 offset)

// To simplify infix operator definitions, we define a helper function.
let addInfixOperator str prec assoc mapping =
    let op = InfixOperator(str, getPosition .>> ws, prec, assoc, (),
                           fun opPos leftTerm rightTerm ->
                               mapping
                                   (adjustPosition -str.Length opPos)
                                   leftTerm rightTerm)
    opp.AddOperator(op)

addInfixOperator "+" 10 Assoc.Left (fun opPos leftTerm rightTerm -> Plus(leftTerm, rightTerm))
addInfixOperator "-" 10 Assoc.Left (fun opPos leftTerm rightTerm -> Minus(leftTerm, rightTerm))
addInfixOperator "*" 11 Assoc.Left (fun opPos leftTerm rightTerm -> Mul(leftTerm, rightTerm))
addInfixOperator "/" 11 Assoc.Left (fun opPos leftTerm rightTerm -> Div(leftTerm, rightTerm))
addInfixOperator "%" 11 Assoc.Left (fun opPos leftTerm rightTerm -> Mod(leftTerm, rightTerm))
addInfixOperator "=" 9 Assoc.Left (fun opPos leftTerm rightTerm -> Equal(leftTerm, rightTerm))
addInfixOperator "<>" 9 Assoc.Left (fun opPos leftTerm rightTerm -> NotEqual(leftTerm, rightTerm))
addInfixOperator "," 1 Assoc.Left (fun opPos leftTerm rightTerm -> Comma(leftTerm, rightTerm))
let addTernaryOperator str1 str2 prec assoc mapping =
    let op = TernaryOperator(str1, getPosition .>> ws, str2, getPosition .>> ws, prec, assoc, (),
                           fun opPos term1 term2 term3 ->
                               mapping term1 term2 term3)
    opp.AddOperator(op)
addTernaryOperator "?" ":" 15 Assoc.Right (fun opPos term1 term2 term3 -> Conditional(term1, term2, term3))

let lparen = pstring "(" <|> pstring "🌜"
let rparen = pstring ")" <|> pstring "🌛"
let letexpr = (pstring "let" >>. spaces >>. variable .>> spaces .>> pchar '=') .>>. (spaces >>. expr) |>> Let
let term = spaces >>. (letexpr <|>
            attempt((lparen >>. spaces >>. rparen) |>> fun v -> Const Unit) <|>
            between (lparen) (rparen) expr
            <|> (literal |>> Const) <|> lambda <|> (variable |>> function v -> Variable (variable2str v))) .>> spaces
let fapp = spaces >>. (attempt(
                        ((chainl1 term ((spaces(* >>. pchar '.' *)>>. notFollowedByEof >>. notFollowedBy(rparen) >>. notFollowedBy(anyOf "+-*/%=<?:")) |>> (fun v w z -> FuncApp (w, z)))))) <|> term) .>> spaces
opp.TermParser <- fapp 
do exprref := opp.ExpressionParser
let lambdaarg = (variable |>> function v -> variable2str v) <|> (lparen >>. spaces >>. rparen |>> fun _ -> "")
do lambdaref := ((pstring @"\" <|> pstring "🐫") >>. spaces >>.
                lambdaarg) .>>.
                (spaces >>. (pstring "->" <|> pstring "👉") >>. expr)
                |>> function v -> Lambda v

let test p str = 
    match run p str with
    | Success(result, a, b)   -> printfn "Success: %A, %A, %A" result a b
    | Failure(errorMsg, a, b) -> printfn "Failure: %s, %A, %A" errorMsg a b
let rec findVar name var =
    match var.VarMap.ContainsKey(name) with//Map.tryFind name var.VarMap with
    | true -> var.VarMap.[name]
    | false ->
        match var.Parent with
        | Some p -> findVar name p
        | None -> var.VarMap.[name]//Map.find name var.VarMap//error shori yokuwakaranai

//どうにかしたいop (+) right left
let rplus left right =
    match left with
        | Int left ->
            match right with
                | Int right -> Int (left + right)
        | String left ->
            match right with
                | right -> String (left + (string right))
let rminus left right =
    match left with
        | Int left ->
            match right with
                | Int right -> Int (left - right)
let rmul left right =
    match left with
        | Int left ->
            match right with
                | Int right -> Int (left * right)
let rdiv left right =
    match left with
        | Int left ->
            match right with
                | Int right -> Int (left / right)
let rmod left right =
    match left with
        | Int left ->
            match right with
                | Int right -> Int (left % right)
let requal left right = Bool (left = right)
let rnotequal left right = Bool (left <> right)
let rcast typ exp =
    match exp with
        | (typ : 'a) -> exp
let rec eval expr var =
    match expr with
    | Plus (a, b) ->
        rplus (eval a var) (eval b var)
    | Minus (a, b) ->
        rminus (eval a var) (eval b var)
    | Mul (a, b) ->
        rmul (eval a var) (eval b var)
    | Div (a, b) ->
        rdiv (eval a var) (eval b var)
    | Mod (a, b) ->
        rmod (eval a var) (eval b var)
    | Equal (a, b) ->
        requal (eval a var) (eval b var)
    | NotEqual (a, b) ->
        rnotequal (eval a var) (eval b var)
    | Const a ->
        a
    | Variable name ->
        findVar name var
    | Lambda (name, body) ->
        Function {FunctionBody = body; Var = var; ArgName = name}
    | FuncApp (func, arg) ->
        let func = eval func var
        match func with
        | Function func ->
            let arg = eval arg var
            let dic = new Dictionary<string, SynConst>();
            dic.Add(func.ArgName, arg)
            eval func.FunctionBody {Parent = Some func.Var; VarMap = dic}//new Map<string, SynConst>([(func.ArgName, arg)])}
        | other ->
            String "error expr"//tenuki
    | Let (name, expr) ->
        let expr = eval expr var
        var.VarMap.Add(name, expr)
        Unit
    | Comma (expr1, expr2) ->
        ignore (eval expr1 var)
        eval expr2 var
    | Conditional (cond, first, second) ->
        let cond = eval cond var
        match cond with
            | Bool cond -> if cond then eval first var else eval second var
let runexpr str = //(let if = \cond->\d->\e->cond ? d : e),if (1=1) (\_->"then") (\_->"else"))
    match run expr str with
    | Success(result, a, b)   -> printf "Success: %A = \n" result;printfn "%A" (eval result ({Parent = None; VarMap = new Dictionary<string, SynConst>()(*new Map<string, SynConst>([])*)}))
    | Failure(errorMsg, a, b) -> printfn "Failure: %s %A %A" errorMsg a b
[<EntryPoint>]
let main argv = 
    test expr "1 + 2 * 3"
    test expr "add 1 2 3"
    runexpr "1 + 2"
    runexpr "1 - (2 - 3)"
    //runexpr "() + ()"//debug yo->unit impl sitanode kesu
    runexpr "\x->x + 1"
    test expr "\x->\y->x+y"
    test expr "🐫🐭👉🐫y👉🐫z👉🐭+y+z"
    test expr "🐫 🐭 👉  🐫 y 👉  🐫 z 👉  🐭 + y + z"
    test expr "add 1 2 3"
    test expr "(🐫 🐭 👉  🐫 y 👉  🐫 z 👉  🐭 + y + z) 1 2 3"
    runexpr "(🐫 🐭 👉  🐫 y 👉  🐫 z 👉  🐭 + y + z) 1 2 3"
    runexpr "(🐫 🐭 👉 🐭 + 1) 2"
    runexpr "(\x->x + 1) 2"
    runexpr @"(let if = 🐫 cond 👉 🐫d 👉 🐫e 👉 cond ? d() : e()),if (1=1) (🐫 _ 👉 ""then"") (🐫 _ 👉""else""))"
    runexpr "🐫 🐭 👉  🐫 🐮 👉  🐫 🐯 👉  🐭 🐯 🌜 🐮 🐯 🌛" (*Sコンビネータ*)
    while true do
        try
            runexpr (System.Console.ReadLine ())
        with e
            | e as exn -> printfn "%A" e
    ignore (System.Console.ReadLine ())
    0 // 整数の終了コードを返します