ligo interpreter : moving combinators do a dedicated module
This commit is contained in:
parent
69ddce1860
commit
ce70c82122
@ -1,42 +1,10 @@
|
|||||||
open Trace
|
open Trace
|
||||||
open Ligo_interpreter.Types
|
open Ligo_interpreter.Types
|
||||||
|
open Ligo_interpreter.Combinators
|
||||||
include Stage_common.Types
|
include Stage_common.Types
|
||||||
|
|
||||||
module Env = Ligo_interpreter.Environment
|
module Env = Ligo_interpreter.Environment
|
||||||
|
|
||||||
(* combinators ? *)
|
|
||||||
let v_pair : value * value -> value =
|
|
||||||
fun (a,b) -> V_Record (LMap.of_list [(Label "0", a) ; (Label "1",b)])
|
|
||||||
|
|
||||||
let v_bool : bool -> value =
|
|
||||||
fun b -> V_Ct (C_bool b)
|
|
||||||
|
|
||||||
let v_unit : unit -> value =
|
|
||||||
fun () -> V_Ct (C_unit)
|
|
||||||
|
|
||||||
let v_some : value -> value =
|
|
||||||
fun v -> V_Construct ("Some", v)
|
|
||||||
|
|
||||||
let v_none : unit -> value =
|
|
||||||
fun () -> V_Construct ("None", v_unit ())
|
|
||||||
|
|
||||||
let get_pair : value -> (value * value) result =
|
|
||||||
fun p ->
|
|
||||||
let err = simple_error "value is not a pair" in
|
|
||||||
( match p with
|
|
||||||
| V_Record lmap ->
|
|
||||||
let%bind fst = trace_option err @@
|
|
||||||
LMap.find_opt (Label "0") lmap in
|
|
||||||
let%bind snd = trace_option err @@
|
|
||||||
LMap.find_opt (Label "1") lmap in
|
|
||||||
ok (fst,snd)
|
|
||||||
| _ -> fail err )
|
|
||||||
|
|
||||||
let is_true : value -> bool result =
|
|
||||||
fun b -> match b with
|
|
||||||
| V_Ct (C_bool b) -> ok b
|
|
||||||
| _ -> simple_fail "value is not a bool"
|
|
||||||
|
|
||||||
|
|
||||||
let apply_comparison : Ast_typed.constant -> value list -> value result =
|
let apply_comparison : Ast_typed.constant -> value list -> value result =
|
||||||
fun c operands -> match (c,operands) with
|
fun c operands -> match (c,operands) with
|
||||||
@ -183,7 +151,7 @@ let rec apply_operator : Ast_typed.constant -> value list -> value result =
|
|||||||
(V_Ct C_unit) elts
|
(V_Ct C_unit) elts
|
||||||
| ( C_FOLD_WHILE , [ V_Func_val (arg_name, body, env) ; init ] ) ->
|
| ( C_FOLD_WHILE , [ V_Func_val (arg_name, body, env) ; init ] ) ->
|
||||||
let rec aux el =
|
let rec aux el =
|
||||||
let%bind (b,folded_val) = get_pair el in
|
let%bind (b,folded_val) = extract_pair el in
|
||||||
let env' = Env.extend env (arg_name, folded_val) in
|
let env' = Env.extend env (arg_name, folded_val) in
|
||||||
let%bind res = eval body env' in
|
let%bind res = eval body env' in
|
||||||
let%bind continue = is_true b in
|
let%bind continue = is_true b in
|
||||||
|
34
src/stages/ligo_interpreter/combinators.ml
Normal file
34
src/stages/ligo_interpreter/combinators.ml
Normal file
@ -0,0 +1,34 @@
|
|||||||
|
open Trace
|
||||||
|
open Types
|
||||||
|
|
||||||
|
let v_pair : value * value -> value =
|
||||||
|
fun (a,b) -> V_Record (LMap.of_list [(Label "0", a) ; (Label "1",b)])
|
||||||
|
|
||||||
|
let v_bool : bool -> value =
|
||||||
|
fun b -> V_Ct (C_bool b)
|
||||||
|
|
||||||
|
let v_unit : unit -> value =
|
||||||
|
fun () -> V_Ct (C_unit)
|
||||||
|
|
||||||
|
let v_some : value -> value =
|
||||||
|
fun v -> V_Construct ("Some", v)
|
||||||
|
|
||||||
|
let v_none : unit -> value =
|
||||||
|
fun () -> V_Construct ("None", v_unit ())
|
||||||
|
|
||||||
|
let extract_pair : value -> (value * value) result =
|
||||||
|
fun p ->
|
||||||
|
let err = simple_error "value is not a pair" in
|
||||||
|
( match p with
|
||||||
|
| V_Record lmap ->
|
||||||
|
let%bind fst = trace_option err @@
|
||||||
|
LMap.find_opt (Label "0") lmap in
|
||||||
|
let%bind snd = trace_option err @@
|
||||||
|
LMap.find_opt (Label "1") lmap in
|
||||||
|
ok (fst,snd)
|
||||||
|
| _ -> fail err )
|
||||||
|
|
||||||
|
let is_true : value -> bool result =
|
||||||
|
fun b -> match b with
|
||||||
|
| V_Ct (C_bool b) -> ok b
|
||||||
|
| _ -> simple_fail "value is not a bool"
|
@ -1,3 +1,4 @@
|
|||||||
module Types = Types
|
module Types = Types
|
||||||
module PP = PP
|
module PP = PP
|
||||||
module Environment = Environment
|
module Environment = Environment
|
||||||
|
module Combinators = Combinators
|
Loading…
Reference in New Issue
Block a user