From d1abff9b798c86c58a6e3629f03c0463677527fb Mon Sep 17 00:00:00 2001 From: kjnilsson Date: Tue, 11 Apr 2017 19:06:55 +0100 Subject: [PATCH] first pattern matching steps --- Test/Program.fs | 8 +++++ Test/Test.fsproj | 17 ++++++++++ ce.erl | 2 +- flatc/Program.fs | 64 +++++++++++++++++++++++++++++++++-- flatc/cerl.fs | 87 ++++++++++++++++++++++++++++++++++++++++++------ 5 files changed, 164 insertions(+), 14 deletions(-) create mode 100755 Test/Program.fs create mode 100755 Test/Test.fsproj diff --git a/Test/Program.fs b/Test/Program.fs new file mode 100755 index 0000000..a7458f5 --- /dev/null +++ b/Test/Program.fs @@ -0,0 +1,8 @@ +// Learn more about F# at http://fsharp.org + +open System + +[] +let main argv = + printfn "Hello World from F#!" + 0 // return an integer exit code diff --git a/Test/Test.fsproj b/Test/Test.fsproj new file mode 100755 index 0000000..5a7b519 --- /dev/null +++ b/Test/Test.fsproj @@ -0,0 +1,17 @@ + + + + Exe + netcoreapp1.1 + + + + + + + + + + + + diff --git a/ce.erl b/ce.erl index a71f027..cd87cc3 100644 --- a/ce.erl +++ b/ce.erl @@ -5,5 +5,5 @@ ast(File) -> {ok, Bin} = file:read_file(File), {ok, Toks, _} = core_scan:string(binary_to_list(Bin)), - {pok, Ast} = core_parse:parse(Toks), + {ok, Ast} = core_parse:parse(Toks), Ast. diff --git a/flatc/Program.fs b/flatc/Program.fs index c2a7255..240dcf3 100755 --- a/flatc/Program.fs +++ b/flatc/Program.fs @@ -97,7 +97,7 @@ module Compiler = |> List.map (fun x -> x.FullName, x.FullType.TypeDefinition) let mkName (name : string) num = - if Char.IsLower name.[0] then + if Char.IsUpper name.[0] then sprintf "%s%i" name num else sprintf "_%s%i" name num @@ -130,6 +130,9 @@ module Compiler = let modCall left right exps = cerl.ModCall ((left, right), exps) + let apply f args = + cerl.App (f, args) + let lambda args expr = cerl.Lambda (args, expr) @@ -146,8 +149,15 @@ module Compiler = function | "op_Multiply" -> Some "*" | "op_Addition" -> Some "+" + | "op_Subtraction" -> Some "-" | _ -> None + let (|Lit|_|) (o: obj) = + match o with + | :? int as i -> cerl.LInt i |> Some + | x -> None + + //TODO: should we consult the FSharpType as well? let mapConst (o : obj) = match o with @@ -159,10 +169,39 @@ module Compiler = | Intr2Erl x -> let erlang = litAtom "erlang" |> constr let mul = litAtom x |> constr - let exprss, nm = foldNames nm processExpr exprs - modCall erlang mul exprss, nm + let args, nm = foldNames nm processExpr exprs + modCall erlang mul args, nm + | name -> //apply + let func = litAtom name |> constr + let args, nm = foldNames nm processExpr exprs + apply func args, nm | x -> failwithf "not implemented %A" x + and processPat nm (expr : FSharpExpr) : (cerl.Pat * cerl.Guard * Map) = + match expr with + | BasicPatterns.Call (_expr, f, _, _typeSig, [BasicPatterns.Value (_) + BasicPatterns.Const (Lit cVal, _)]) + when f.LogicalName = "op_Equality" -> + cerl.PLit cVal, cerl.Guard (litAtom "true" |> constr), nm + (* mapCall nm f expressions *) + (* | BasicPatterns.Const (o, t) -> *) + (* mapConst o, nm *) + | x -> failwithf "not implemented %A" x + + and processITEs d nm expr : (int * (cerl.Pat * cerl.Guard * Map)) list = + [ + match expr with + | BasicPatterns.IfThenElse(fi, BasicPatterns.DecisionTreeSuccess(idx, []), esle) -> + let pat, guard, nm' = processPat nm fi + yield idx, (pat, guard, nm') + // need to pass orig nm here as each branch need the same outer scope + yield! processITEs d nm esle + | BasicPatterns.DecisionTreeSuccess(idx, []) -> + // TODO PVar - need to pass it + yield idx, (cerl.PVar d, cerl.Guard (litAtom "true" |> constr), nm) + | x -> failwithf "processITE not impl %A" x ] + + and processExpr nm (expr : FSharpExpr) : (cerl.Exps * Map) = let res, nmOut = match expr with @@ -178,6 +217,25 @@ module Compiler = let v', nm = safeVar true nm v.LogicalName let next, nm = processExpr nm expr mkLet v' ass next, nm + | BasicPatterns.DecisionTree (BasicPatterns.IfThenElse (iff, thenn, elsee) as e, l) as tree -> + printfn "tree %A" tree + // hacky way to get at the expr between 'match' and 'with' + let v, caseExpr, nm = + match iff with + | BasicPatterns.Call (_, _, _, _, [e1;_]) -> + match processExpr nm e1 with + | cerl.Exp (cerl.Constr (cerl.Var v)) as e, nm -> v, e, nm + | x -> failwithf "caseExprinner not imp %A" x + | x -> failwithf "caseExpr not imp %A" x + + let ites = processITEs v nm e |> Map + let alts : List> = + l |> List.mapi (fun i (mfvs, e) -> + let pat, grd, nm = ites.[i] + // we can throw away nm now as have branched + let e, _ = processExpr nm e + cerl.Constr <| cerl.Alt (cerl.Pat pat, grd, e)) + cerl.Case (caseExpr, alts), nm | x -> failwithf "not implemented %A" x constr res, nmOut diff --git a/flatc/cerl.fs b/flatc/cerl.fs index 2d39650..37f672c 100644 --- a/flatc/cerl.fs +++ b/flatc/cerl.fs @@ -8,6 +8,31 @@ module Util = let prtNl() = printf "\r\n" +type Prt = + | Prt of (string * Prt) list + | Term + | Closing of string + +let t : Prt = + Prt ["module 'test' ['square'/1,", Prt ["'module_info'/0", Term + "'module_info'/1", Term] + "'square'/1", Prt ["fun (_core0) ->", + Prt ["call 'erlang':'*'", + Prt ["(_core0, core0)", Term]]] + "end", Term] + +let rec printItem ((Indent ind) as i) (l, p) = + printf "%s%s" ind l + rend (i+4) p +and rend i (prt : Prt) = + match prt with + | Prt items -> + for itm in items do + printf "%s" System.Environment.NewLine + printItem i itm + | Closing s -> printf "%s" s + | Term -> () + type Var = string @@ -25,7 +50,7 @@ type Literal = | LAtom of Atom // ^ atom literal | LNil // ^ empty list with - static member prt indent lit = + static member prt (Indent indent) lit = match lit with | LChar c -> sprintf "%s$%c'" indent c @@ -55,22 +80,49 @@ and Pat = | PList of ExprList // ^ list pattern | PBinary of List> // ^ list of bitstring patterns | PAlias of Alias // ^ alias pattern +with + static member prt pat = + match pat with + | PVar v -> v + | PLit l -> Literal.prt 0 l + | PTuple tup -> + let pats = List.map Pat.prt tup + sprintf "{%s}" (String.concat "," pats) + | x -> failwithf "Pat.prt not impl %A" x and Alias = Alias of Var * Pat +and Guard = Guard of Exps + and Pats = | Pat of Pat // ^ single pattern | Pats of List // ^ list of patterns +with + static member prt pats = + match pats with + | Pat p -> sprintf "<%s>" (Pat.prt p) + | pl -> failwithf "not impl %A" pl -and Alt = Alt of Pats * Guard * Exps - -and Guard = Guard of Exps +and Alt = Alt of Pats * Guard * Exps +with + static member prt ((Indent indent) as i) (Alt (pats, Guard guardExps, exps)) = + let pat = Pats.prt pats + let guard = Exps.prt 0 guardExps + let body = Exps.prt (i+4) exps + sprintf "%s%s when %s ->\r\n%s\r\n" indent pat guard body and TimeOut = TimeOut of Exps * Exps and Ann<'T> = | Constr of 'T // ^ core erlang construct | Ann of 'T * List // ^ core erlang annotated construct +(* with *) +(* static member prt indent a = *) +(* match a with *) +(* | Constr t -> *) +(* (^T : (static member prt : ^T -> int -> string) indent t) *) +(* | _ -> failwith "not imp;" *) + (* sprintf "%s'%s'/%i" indent name arity *) and Function = Function of Atom * int with @@ -100,23 +152,39 @@ and Exp = with static member prt ((Indent indent) as i) expr = match expr with - | Var v -> v + | Var v -> sprintf "%s%s" indent v | Lit lit -> - Literal.prt indent lit + Literal.prt i lit | Lambda (vars, exps) -> let expsp = Exps.prt (i+4) exps let varsp = String.concat "," vars sprintf "%sfun (%s) ->\r\n%s" indent varsp expsp + | App (targetExps, args) -> + let target = Exps.prt (i+4) targetExps + let arity = List.length args + let argsp = args |> List.map (Exps.prt i) |> String.concat "," + sprintf "%sapply\r\n%s/%i\r\n%s (%s)" indent target arity indent argsp | ModCall ((left, right), args) -> - let leftExp = Exps.prt 0 left + let leftExp = Exps.prt (i+4) left let rightExp = Exps.prt 0 right let argsp = args |> List.map (Exps.prt 0) |> String.concat "," - sprintf "%scall %s:%s\r\n%s (%s)" indent leftExp rightExp indent argsp + sprintf "%scall\r\n%s:%s\r\n%s (%s)" indent leftExp rightExp indent argsp | Let ((v, e), next) -> let vars = String.concat "," v let assign = Exps.prt (i+4) e let next' = Exps.prt (i+4) next sprintf "%slet <%s> =\r\n%s\r\n%sin\r\n%s" indent vars assign indent next' + | Case (caseExpr, alts) -> + let caseExpr = Exps.prt 0 caseExpr + let alts = + List.fold(fun s a -> + match a with + | Constr a -> + let x = Alt.prt (i+4) a + sprintf "%s%s\r\n" s x + | x -> failwithf "not imple %A" x) "" alts + sprintf "%scase %s of\r\n%send" indent caseExpr alts + | x -> failwithf "%A not implemented" x and Exps = @@ -142,8 +210,7 @@ and FunDef = FunDef of Ann * Ann and Module = Module of Atom * List * List * List with static member prt (Module (Atom name, funs, attribs, defs)) = - [ //let m = sprintf "module '%s' [" name - let indent = 11 + name.Length + [ let indent = 11 + name.Length match funs with | f :: funs -> yield Function.prt 0 f |> sprintf "module '%s' [%s" name