balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

tmp

Browse Source
This commit is contained in:
Galfour 2019-03-20 14:53:34 +00:00
parent fa4b570950
commit 1918bc00d1
64 changed files with 795 additions and 1003 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -6,6 +6,7 @@ __pycache__
*.pyc
/_build
*/_build
/_opam
/_docker_build
/docs/_build

85
src/ligo/ast_simplified.ml Normal file
View File

@ -0,0 +1,85 @@
module SMap = Ligo_helpers.X_map.String
type name = string
type type_name = string
type 'a name_map = 'a SMap.t
type 'a type_name_map = 'a SMap.t
type program = declaration list
and declaration =
| Type_declaration of named_type_expression
| Constant_declaration of named_expression
(* | Macro_declaration of macro_declaration *)
and annotated_expression = {
expression: expression ;
type_annotation: te option ;
}
and named_expression = {
name: name ;
annotated_expression: ae ;
}
and named_type_expression = {
type_name: type_name ;
type_expression: type_expression ;
}
and te = type_expression
and ae = annotated_expression
and te_map = type_expression type_name_map
and e_map = expression name_map
and type_expression =
| Type_tuple of te list
| Type_sum of te_map
| Type_record of te_map
| Type_variable of type_name
| Type_constant of type_name * te list
and expression =
| Literal of literal
| Constant of name * ae list (* For language constants, like (Cons hd tl) or (plus i j) *)
| Variable of name
| Tuple of ae list
| Constructor of name * ae list (* For user defined constructors *)
| Lambda of {
binder: name ;
input_type: type_expression ;
output_type: type_expression ;
body: block ;
}
and literal =
| Bool of bool
| Number of int
| String of string
| Bytes of bytes
and block = instruction list
and b = block
and instruction =
| Assignment of named_expression
| Matching of matching
| Loop of ae * b
| Skip
| Fail of ae
and matching =
| Match_bool of {
match_true : b ;
match_false : b ;
}
| Match_list of {
match_nil : b ;
match_cons : name * name * b ;
}
| Match_option of {
match_none : b ;
match_some : name * b ;
}
| Match_tuple of (name * b) list

137
src/ligo/ast_typed.ml Normal file
View File

@ -0,0 +1,137 @@
module SMap = Ligo_helpers.X_map.String
let list_of_smap (s:'a SMap.t) : (string * 'a) list =
List.rev @@ SMap.fold (fun k v p -> (k, v) :: p) s []
type name = string
type type_name = string
type 'a name_map = 'a SMap.t
type 'a type_name_map = 'a SMap.t
type program = declaration list
and declaration =
| Constant_declaration of named_expression
(* | Macro_declaration of macro_declaration *)
and annotated_expression = {
expression: expression ;
type_annotation: tv ;
}
and named_expression = {
name: name ;
annotated_expression: ae ;
}
and tv = type_value
and ae = annotated_expression
and tv_map = type_value type_name_map
and e_map = expression name_map
and type_value =
| Type_tuple of tv list
| Type_sum of tv_map
| Type_record of tv_map
| Type_constant of type_name * tv list
and expression =
| Literal of literal
| Constant of name * ae list (* For language constants, like (Cons hd tl) or (plus i j) *)
| Variable of name
| Tuple of ae list
| Constructor of name * ae list (* For user defined constructors *)
| Lambda of {
binder: name ;
input_type: type_value ;
output_type: type_value ;
body: block ;
}
and literal =
| Bool of bool
| Number of int
| String of string
| Bytes of bytes
and block = instruction list
and b = block
and instruction =
| Assignment of named_expression
| Matching of matching
| Loop of ae * b
| Skip
| Fail of ae
and matching =
| Match_bool of {
match_true : b ;
match_false : b ;
}
| Match_list of {
match_nil : b ;
match_cons : name * name * b ;
}
| Match_option of {
match_none : b ;
match_some : name * b ;
}
| Match_tuple of (name * b) list
open Ligo_helpers.Trace
let rec type_value_eq (ab: (type_value * type_value)) : unit result = match ab with
| Type_tuple a, Type_tuple b -> (
let%bind _ =
Assert.assert_true ~msg:"tuples with different sizes"
@@ List.(length a = length b) in
bind_list_iter type_value_eq (List.combine a b)
)
| Type_constant (a, a'), Type_constant (b, b') -> (
let%bind _ =
Assert.assert_true ~msg:"constants with different sizes"
@@ List.(length a' = length b') in
let%bind _ =
Assert.assert_true ~msg:"constants with different names"
@@ (a = b) in
trace (simple_error "constant sub-expression")
@@ bind_list_iter type_value_eq (List.combine a' b')
)
| Type_sum a, Type_sum b -> (
let a' = list_of_smap a in
let b' = list_of_smap b in
let aux ((ka, va), (kb, vb)) =
let%bind _ =
Assert.assert_true ~msg:"different keys in sum types"
@@ (ka = kb) in
type_value_eq (va, vb)
in
trace (simple_error "sum type")
@@ bind_list_iter aux (List.combine a' b')
)
| Type_record a, Type_record b -> (
let a' = list_of_smap a in
let b' = list_of_smap b in
let aux ((ka, va), (kb, vb)) =
let%bind _ =
Assert.assert_true ~msg:"different keys in record types"
@@ (ka = kb) in
type_value_eq (va, vb)
in
trace (simple_error "record type")
@@ bind_list_iter aux (List.combine a' b')
)
| _ -> simple_fail "Different kinds of types"
let merge_annotation (a:type_value option) (b:type_value option) : type_value option result =
match a, b with
| None, None -> ok None
| Some a, None -> ok (Some a)
| None, Some b -> ok (Some b)
| Some a, Some b ->
let%bind _ = type_value_eq (a, b) in
ok (Some a)

2
src/ligo/bin/cli.ml
View File

@ -1 +1 @@
let () = print_int 42
let () = ()

8
src/ligo/dune
View File

@ -1,9 +1,3 @@
(ocamllex
(modules lexer))
(menhir
(modules parser))
(library
(name ligo)
(public_name ligo)
@ -17,5 +11,5 @@
(preprocess
(pps ppx_let)
)
(flags (:standard -w +1..62-4-9-44-40-42@39@33 ))
(flags (:standard -w +1..62-4-9-44-40-42-48@39@33 ))
)

76
src/ligo/lexer.mll
View File

@ -1,76 +0,0 @@
{
open Parser
exception Error of string
exception Unexpected_character of string
}
(* This rule analyzes a single line and turns it into a stream of
tokens. *)
rule token = parse
(*
| "//" ([^ '\n']* ) (['\n' '\r']+)
{ Lexing.new_line lexbuf ; token lexbuf }
*)
| ('\r'? '\n' '\r'?)
{ Lexing.new_line lexbuf; token lexbuf }
| [' ' '\t']
{ token lexbuf }
| '"' ( [^ '"' '\\'] | ( '\\' [^ '"'] ) ) as s '"'
{ STRING s }
| "let" { LET }
| "if" { IF }
(* | "then" { THEN } *)
| "elseif" { ELSEIF }
| "else" { ELSE }
(* | "in" { IN } *)
| "type" { TYPE }
| "function" { FUNCTION }
| "while"
{ WHILE }
| "foreach"
{ FOREACH }
| "of"
{ OF }
| (['a'-'z']['a'-'z''A'-'Z''0'-'9''_']+) as v
{ VAR_NAME v }
| (['A'-'Z']['a'-'z''A'-'Z''0'-'9''_']+) as t
{ TYPE_NAME t }
(* | ['0'-'9']+'.'['0'-'9']* as i { FLOAT (float_of_string i) } *)
| ['0'-'9']+ as i
{ INT (int_of_string i) }
(*
| '+' { PLUS }
| '-' { MINUS }
| '*' { TIMES }
| '/' { DIV }
| ";;" { DOUBLE_SEMICOLON }
*)
| '=' { EQUAL }
| ',' { COMMA }
| ';' { SEMICOLON }
| ':' { COLON }
| '&'
{ AND }
| '|'
{ AND }
| '.'
{ DOT }
| '@'
{ AT }
| '('
{ LPAREN }
| ')'
{ RPAREN }
(*
| '[' { LSQUARE }
| ']' { RSQUARE }
*)
| '{'
{ LBRACKET }
| '}'
{ RBRACKET }
| eof { EOF }
| _
{ raise (Unexpected_character (Printf.sprintf "At offset %d: unexpected character.\n" (Lexing.lexeme_start lexbuf))) }

0
src/ligo/helpers/dictionary.ml → src/ligo/ligo-helpers/dictionary.ml
View File

0
src/ligo/helpers/dictionary.mli → src/ligo/ligo-helpers/dictionary.mli
View File

0
src/ligo/helpers/dune → src/ligo/ligo-helpers/dune
View File

0
src/ligo/helpers/environment.ml → src/ligo/ligo-helpers/environment.ml
View File

0
src/ligo/helpers/ligo-helpers.opam → src/ligo/ligo-helpers/ligo-helpers.opam
View File

0
src/ligo/helpers/location.ml → src/ligo/ligo-helpers/location.ml
View File

0
src/ligo/helpers/option.ml → src/ligo/ligo-helpers/option.ml
View File

11
src/ligo/helpers/trace.ml → src/ligo/ligo-helpers/trace.ml
View File

@ -50,6 +50,17 @@ let rec bind_list = function
ok @@ hd :: tl
)
let bind_fold_list f init lst =
let aux x y =
x >>? fun x ->
f x y
in
List.fold_left aux (ok init) lst
let bind_list_iter f lst =
let aux () y = f y in
bind_fold_list aux () lst
let bind_or (a, b) =
match a with
| Ok x -> ok x

0
src/ligo/helpers/tree.ml → src/ligo/ligo-helpers/tree.ml
View File

0
src/ligo/helpers/wrap.ml → src/ligo/ligo-helpers/wrap.ml
View File

1
src/ligo/ligo-helpers/x_map.ml Normal file
View File

@ -0,0 +1 @@
module String = Map.Make(String)

0
src/ligo/parser/.Lexer.ml.tag → src/ligo/ligo-parser/.Lexer.ml.tag
View File

0
src/ligo/parser/.LexerMain.tag → src/ligo/ligo-parser/.LexerMain.tag
View File

0
src/ligo/parser/.Parser.mly.tag → src/ligo/ligo-parser/.Parser.mly.tag
View File

0
src/ligo/parser/.ParserMain.tag → src/ligo/ligo-parser/.ParserMain.tag
View File

0
src/ligo/parser/.links → src/ligo/ligo-parser/.links
View File

0
src/ligo/parser/AST.ml → src/ligo/ligo-parser/AST.ml
View File

0
src/ligo/parser/AST.mli → src/ligo/ligo-parser/AST.mli
View File

174
src/ligo/parser/AST2.ml → src/ligo/ligo-parser/AST2.ml
View File

@ -7,15 +7,13 @@ open Region
module SMap = Map.Make(String)
module O = struct
type asttodo = [`TODO]
type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *)
type name_and_region = {name: string; orig: Region.t}
type type_name = name_and_region
type var_name = name_and_region
type field_name = name_and_region
type record_key = [`Field of field_name | `Component of int]
type pattern =
PVar of var_name
| PWild
@ -29,9 +27,7 @@ module O = struct
| PSome of pattern
| PCons of pattern * pattern
| PNull
| PRecord of record_key precord
and 'key precord = ('key * pattern) list
| PRecord of (field_name * pattern) SMap.t
type type_constructor =
Option
@ -40,8 +36,8 @@ module O = struct
| Map
type type_expr_case =
Sum of (type_name * type_expr) list
| Record of record_key type_record
Sum of (type_name * type_expr) SMap.t
| Record of (field_name * type_expr) SMap.t
| TypeApp of type_constructor * (type_expr list)
| Function of { arg: type_expr; ret: type_expr }
| Ref of type_expr
@ -49,18 +45,18 @@ module O = struct
| Int
| Unit
| Bool
and 'key type_record = ('key * type_expr) list
and type_expr = { type_expr: type_expr_case; name: type_name option; orig: Region.t }
type typed_var = { name:var_name; ty:type_expr }
type typed_var = { name:var_name; ty:type_expr; orig: asttodo }
type type_decl = { name:type_name; ty:type_expr }
type type_decl = { name:type_name; ty:type_expr; orig: asttodo }
type expr =
App of { operator: operator; arguments: expr list }
| Var of var_name
| Constant of constant
| Record of (field_name * expr) list
| Lambda of lambda
and decl = { name:var_name; ty:type_expr; value: expr }
@ -73,33 +69,36 @@ module O = struct
}
and operator =
Function of var_name
| Construcor of var_name
| UpdateField of record_key
| GetField of record_key
| Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod
| Neg | Not
| Tuple | Set | List
| MapLookup
Function of var_name
| Constructor of var_name
| UpdateField of field_name
| GetField of field_name
| Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod
| Neg | Not
| Set | List
| MapLookup
and constant =
Unit | Int of Z.t | String of string | Bytes of MBytes.t | False | True
| Null of type_expr | EmptySet of type_expr | CNone of type_expr
Unit
| Int of Z.t | String of string | Bytes of MBytes.t
| False | True
| Null of type_expr
| EmptySet of type_expr
| CNone of type_expr
and instr =
Assignment of { name: var_name; value: expr }
| While of { condition: expr; body: instr list }
| ForCollection of { list: expr; key: var_name; value: var_name option; body: instr list }
| If of { condition: expr; ifso: instr list; ifnot: instr list }
| Match of { expr: expr; cases: (pattern * instr list) list }
| DropUnit of expr (* expr returns unit, drop the result. *)
| Fail of { expr: expr }
Assignment of { name: var_name; value: expr; orig: asttodo }
| While of { condition: expr; body: instr list; orig: asttodo }
| ForCollection of { list: expr; var: var_name; body: instr list; orig: asttodo }
| Match of { expr: expr; cases: (pattern * instr list) list; orig: asttodo }
| ProcedureCall of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *)
| Fail of { expr: expr; orig: asttodo }
type ast = {
types : type_decl list;
storage_decl : typed_var;
operations_decl : typed_var;
declarations : decl list;
orig : AST.t
}
end
@ -126,6 +125,8 @@ let fold_map f a l =
(* Simplify the AST *)
let name_and_region_of_int i = O.{name = string_of_int i; orig = Region.ghost}
let s_nsepseq : ('a,'sep) Utils.nsepseq -> 'a list =
fun (first, rest) -> first :: (map snd rest)
@ -155,17 +156,26 @@ let s_type_constructor {value=name;region} : O.type_constructor =
(* TODO: escape the name, prevent any \x1b and other weird characters from appearing in the output *)
| _ -> failwith ("Unknown type constructor: " ^ name)
let named_list_to_map (l : (O.name_and_region * 'a) list) : (O.name_and_region * 'a) SMap.t =
List.fold_left
(fun m ((x,_) as p) ->
let {name;_} : O.name_and_region = x in
SMap.add name p m)
SMap.empty
l
let rec s_cartesian {value=sequence; region} : O.type_expr =
let () = ignore (region) in
s_nsepseq sequence
|>map s_type_expr
|> mapi (fun i p -> `Component i, p)
|> mapi (fun i p -> name_and_region_of_int i, p)
|> named_list_to_map
|> (fun x -> (Record x : O.type_expr_case))
|> type_expr region
and s_sum_type {value=sequence; region} : O.type_expr =
let () = ignore (region) in
type_expr region (Sum (map s_variant (s_nsepseq sequence)))
type_expr region (Sum (map s_variant (s_nsepseq sequence) |> named_list_to_map))
and s_variant {value=(constr, kwd_of, cartesian); region} =
let () = ignore (kwd_of,region) in
@ -173,11 +183,11 @@ and s_variant {value=(constr, kwd_of, cartesian); region} =
and s_record_type {value=(kwd_record, field_decls, kwd_end); region} : O.type_expr =
let () = ignore (kwd_record,region,kwd_end) in
type_expr region (Record (map s_field_decl (s_nsepseq field_decls)))
type_expr region (Record (map s_field_decl (s_nsepseq field_decls) |> named_list_to_map) : O.type_expr_case)
and s_field_decl {value=(var, colon, type_expr); region} =
and s_field_decl {value=(var, colon, type_expr); region} : O.type_name * O.type_expr =
let () = ignore (colon,region) in
(`Field (s_name var), s_type_expr type_expr)
((s_name var), (s_type_expr type_expr))
and s_type_app {value=(type_name,type_tuple); region} : O.type_expr =
let () = ignore (region) in
@ -208,15 +218,15 @@ and s_type_expr (orig : I.type_expr) : O.type_expr = match orig with
let s_type_decl I.{value={kwd_type;name;kwd_is;type_expr;terminator}; region} : O.type_decl =
let () = ignore (kwd_type,kwd_is,terminator,region) in
let ty = s_type_expr type_expr in
O.{ name = s_name name; ty = { ty with name = Some (s_name name) } }
O.{ name = s_name name; ty = { ty with name = Some (s_name name) }; orig = `TODO }
let s_storage_decl I.{value={kwd_storage; name; colon; store_type; terminator}; region} : O.typed_var =
let () = ignore (kwd_storage,colon,terminator,region) in
O.{ name = s_name name; ty = s_type_expr store_type }
O.{ name = s_name name; ty = s_type_expr store_type; orig = `TODO }
let s_operations_decl I.{value={kwd_operations;name;colon;op_type;terminator}; region} : O.typed_var =
let () = ignore (kwd_operations,colon,terminator,region) in
O.{ name = s_name name; ty = s_type_expr op_type }
O.{ name = s_name name; ty = s_type_expr op_type; orig = `TODO }
let s_empty_list {value=(l, (lbracket, rbracket, colon, type_expr), r); region} : O.expr =
let () = ignore (l, lbracket, rbracket, colon, r, region) in
@ -232,13 +242,15 @@ let s_none {value=(l, (c_None, colon, type_expr), r); region} : O.expr =
let parameters_to_tuple (parameters : (string * O.type_expr) list) : O.type_expr =
(* TODO: use records with named fields to have named arguments. *)
let parameter_tuple = O.Record (mapi (fun i (_name,ty) -> `Component i, ty) parameters) in
let parameter_tuple : O.type_expr_case =
Record (mapi (fun i (_name,ty) -> name_and_region_of_int i, ty) parameters |> named_list_to_map) in
O.{ type_expr = parameter_tuple; name = None; orig = Region.ghost }
and parameters_to_decls singleparam (parameters : (string * O.type_expr) list) : O.decl list =
let f i (name,ty) =
O.{ name = {name; orig=Region.ghost};
ty = ty;
value = App { operator = O.GetField (`Component i);
value = App { operator = O.GetField (name_and_region_of_int i);
arguments = [Var singleparam] } }
in mapi f parameters
@ -270,7 +282,7 @@ and s_expr : I.expr -> O.expr =
| False c_False -> let () = ignore (c_False) in Constant (False)
| True c_True -> let () = ignore (c_True) in Constant (True)
| Unit c_Unit -> let () = ignore (c_Unit) in Constant (Unit)
| Tuple {value=(l,tuple,r); region} -> let () = ignore (l,r,region) in App { operator = Tuple; arguments = map s_expr (s_nsepseq tuple)}
| Tuple {value=(l,tuple,r); region} -> let () = ignore (l,r,region) in s_tuple_expr (tuple |> s_nsepseq |> map s_expr)
| List list -> s_list list
| EmptyList empty_list -> s_empty_list empty_list
| Set set -> s_set set
@ -282,6 +294,9 @@ and s_expr : I.expr -> O.expr =
| MapLookUp map_lookup -> s_map_lookup map_lookup
| ParExpr {value=(lpar,expr,rpar); region} -> let () = ignore (lpar,rpar,region) in s_expr expr
and s_tuple_expr tuple : O.expr =
Record (mapi (fun i e -> name_and_region_of_int i, e) tuple)
and s_map_lookup I.{value = {map_name; selector; index}; region} : O.expr =
let {value = lbracket, index_expr, rbracket; region=region2} = index in
let () = ignore (selector, lbracket, rbracket, region2, region) in
@ -292,7 +307,7 @@ and s_some_app {value=(c_Some, {value=(l,arguments,r); region=region2}); region}
match s_nsepseq arguments with
[] -> failwith "tuple cannot be empty"
| [a] -> s_expr a
| l -> App { operator = Tuple; arguments = map s_expr l }
| l -> s_tuple_expr (map s_expr l)
and s_list {value=(l, list, r); region} : O.expr =
let () = ignore (l, r, region) in
@ -347,8 +362,8 @@ and s_ptuple {value=(lpar, sequence, rpar); region} =
let () = ignore (lpar, rpar, region) in
s_nsepseq sequence
|> map s_core_pattern
|> mapi (fun i p -> `Component i, p)
|> fun x -> O.PRecord x
|> mapi (fun i p -> name_and_region_of_int i, p)
|> fun x -> O.PRecord (x |> named_list_to_map)
and s_psome {value=(c_Some,{value=(l,psome,r);region=region2});region} : O.pattern =
let () = ignore (c_Some,l,r,region2,region) in
@ -398,20 +413,27 @@ and s_instruction : I.instruction -> O.instr list = function
and s_conditional I.{kwd_if;test;kwd_then;ifso;kwd_else;ifnot} : O.instr =
let () = ignore (kwd_if,kwd_then,kwd_else) in
If { condition = s_expr test; ifso = s_instruction ifso; ifnot = s_instruction ifnot }
let test = s_expr test in
let ifso = O.PTrue, s_instruction ifso in
let ifnot = O.PFalse, s_instruction ifnot in
Match {
expr = test;
cases = [ifso; ifnot];
orig = `TODO
}
and s_match_instr I.{kwd_match;expr;kwd_with;lead_vbar;cases;kwd_end} : O.instr =
let {value=cases;region} = cases in
let () = ignore (kwd_match,kwd_with,lead_vbar,kwd_end,region) in
Match { expr = s_expr expr; cases = map s_case (s_nsepseq cases) }
Match { expr = s_expr expr; cases = map s_case (s_nsepseq cases); orig = `TODO }
and s_ass_instr {value=(variable,ass,expr); region} : O.instr =
let () = ignore (ass,region) in
Assignment { name = s_name variable; value = s_expr expr }
Assignment { name = s_name variable; value = s_expr expr; orig = `TODO }
and s_while_loop {value=(kwd_while, expr, block); region} : O.instr list =
let () = ignore (kwd_while,region) in
[While {condition = s_expr expr; body = s_block block}]
[While {condition = s_expr expr; body = s_block block; orig = `TODO}]
and s_for_loop : I.for_loop -> O.instr list = function
ForInt for_int -> s_for_int for_int
@ -425,28 +447,34 @@ and s_for_int ({value={kwd_for;ass;down;kwd_to;bound;step;block}; region} : I.fo
| None -> O.Lt, O.Add in
let step = s_step step
in [
Assignment { name; value = s_expr expr };
Assignment { name; value = s_expr expr; orig = `TODO };
(* TODO: lift the declaration of the variable, to avoid creating a nested scope here. *)
While {
condition = App { operator = condition;
arguments = [Var name; s_expr bound] };
arguments = [Var name; s_expr bound]};
body = append (s_block block)
[O.Assignment { name;
value = App { operator;
arguments = [Var name; step]}}]
arguments = [Var name; step]};
orig = `TODO }];
orig = `TODO
}
]
and s_for_collect ({value={kwd_for;var;bind_to;kwd_in;expr;block}; _} : I.for_collect reg) : O.instr list =
let () = ignore (kwd_for,kwd_in) in
[
O.ForCollection {
list = s_expr expr;
key = s_name var;
value = s_bind_to bind_to;
body = s_block block
}
]
let for_instr =
match s_bind_to bind_to with
Some _ ->
failwith "TODO: For on maps is not supported yet!"
| None ->
O.ForCollection {
list = s_expr expr;
var = s_name var;
body = s_block block;
orig = `TODO
}
in [for_instr]
and s_step : (I.kwd_step * I.expr) option -> O.expr = function
Some (kwd_step, expr) -> let () = ignore (kwd_step) in s_expr expr
@ -462,7 +490,13 @@ and s_loop : I.loop -> O.instr list = function
and s_fun_call {value=(fun_name, arguments); region} : O.expr =
let () = ignore (region) in
App { operator = Function (s_name fun_name); arguments = s_arguments arguments }
let {value=fun_name_string;_} = fun_name in
let firstchar = String.sub fun_name_string 0 1 in
(* If it starts with a capital letter, then it is a constructor *)
if String.equal firstchar (String.uppercase_ascii firstchar) then
App { operator = Constructor (s_name fun_name); arguments = s_arguments arguments }
else
App { operator = Function (s_name fun_name); arguments = s_arguments arguments }
and s_constr_app {value=(constr, arguments); region} : O.expr =
let () = ignore (region) in
@ -474,11 +508,11 @@ and s_arguments {value=(lpar, sequence, rpar); region} : O.expr list =
match map s_expr (s_nsepseq sequence) with
[] -> [Constant Unit]
| [single_argument] -> [single_argument]
| args -> [App { operator = Tuple; arguments = args }] ;
| args -> [s_tuple_expr args] ;
and s_fail ((kwd_fail, expr) : (I.kwd_fail * I.expr)) : O.instr =
let () = ignore (kwd_fail) in
Fail { expr = s_expr expr }
Fail { expr = s_expr expr; orig = `TODO }
@ -488,7 +522,7 @@ and s_single_instr : I.single_instr -> O.instr list = function
| Match {value; _} -> [s_match_instr value]
| Ass instr -> [s_ass_instr instr]
| Loop loop -> s_loop loop
| ProcCall fun_call -> [DropUnit (s_fun_call fun_call)]
| ProcCall fun_call -> [ProcedureCall { expr = s_fun_call fun_call; orig = `TODO }]
| Null kwd_null -> let () = ignore (kwd_null) in
[]
| Fail {value; _} -> [s_fail value]
@ -502,13 +536,13 @@ and gensym =
fun ty ->
i := !i + 1;
(* TODO: Region.ghost *)
({name = {name=(string_of_int !i) ^ "gensym"; orig = Region.ghost}; ty} : O.typed_var)
({name = {name=(string_of_int !i) ^ "gensym"; orig = Region.ghost}; ty; orig = `TODO} : O.typed_var)
and s_fun_decl I.{value={kwd_function;name;param;colon;ret_type;kwd_is;local_decls;block;kwd_with;return;terminator}; region} : O.decl =
let () = ignore (kwd_function,colon,kwd_is,kwd_with,terminator,region) in
let tuple_type = s_parameters param |> parameters_to_tuple in
let single_argument = gensym tuple_type in
let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in
let ({name = single_argument_xxx; ty = _; orig = `TODO} : O.typed_var) = single_argument in
O.{
name = s_name name;
ty = type_expr region (Function { arg = tuple_type;
@ -527,7 +561,7 @@ and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;term
let () = ignore (kwd_procedure,kwd_is,terminator,region) in
let tuple_type = s_parameters param |> parameters_to_tuple in
let single_argument = gensym tuple_type in
let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in
let ({name = single_argument_xxx; ty = _; orig = `TODO} : O.typed_var) = single_argument in
O.{
name = s_name name;
ty = type_expr region (Function { arg = tuple_type;
@ -546,7 +580,7 @@ and s_entry_decl I.{value={kwd_entrypoint;name;param;kwd_is;local_decls;block;te
let () = ignore (kwd_entrypoint,kwd_is,terminator,region) in
let tuple_type = s_parameters param |> parameters_to_tuple in
let single_argument = gensym tuple_type in
let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in
let ({name = single_argument_xxx; ty = _; orig = `TODO} : O.typed_var) = single_argument in
O.{
name = s_name name;
ty = type_expr region (Function { arg = tuple_type;
@ -594,10 +628,10 @@ let s_ast (ast : I.ast) : O.ast =
let storage_decl = match storage_decl with
Some x -> x
| None -> failwith "Missing storage declaration" in
let operations_decl = match operations_decl with
Some x -> x
| None -> failwith "Missing storage declaration"
in {types; storage_decl; operations_decl; declarations}
let () = match operations_decl with
Some _ -> failwith "Operations declaration is not allowed anymore TODO"
| None -> ()
in {types; storage_decl; declarations; orig = ast}

0
src/ligo/parser/Error.mli → src/ligo/ligo-parser/Error.mli
View File

0
src/ligo/parser/EvalOpt.ml → src/ligo/ligo-parser/EvalOpt.ml
View File

0
src/ligo/parser/EvalOpt.mli → src/ligo/ligo-parser/EvalOpt.mli
View File

0
src/ligo/parser/FQueue.ml → src/ligo/ligo-parser/FQueue.ml
View File

0
src/ligo/parser/FQueue.mli → src/ligo/ligo-parser/FQueue.mli
View File

0
src/ligo/parser/LexToken.mli → src/ligo/ligo-parser/LexToken.mli
View File

0
src/ligo/parser/LexToken.mll → src/ligo/ligo-parser/LexToken.mll
View File

0
src/ligo/parser/Lexer.mli → src/ligo/ligo-parser/Lexer.mli
View File

0
src/ligo/parser/Lexer.mll → src/ligo/ligo-parser/Lexer.mll
View File

0
src/ligo/parser/LexerMain.ml → src/ligo/ligo-parser/LexerMain.ml
View File

0
src/ligo/parser/MBytes.ml → src/ligo/ligo-parser/MBytes.ml
View File

0
src/ligo/parser/MBytes.mli → src/ligo/ligo-parser/MBytes.mli
View File

0
src/ligo/parser/Markup.ml → src/ligo/ligo-parser/Markup.ml
View File

0
src/ligo/parser/Markup.mli → src/ligo/ligo-parser/Markup.mli
View File

0
src/ligo/parser/ParToken.mly → src/ligo/ligo-parser/ParToken.mly
View File

0
src/ligo/parser/Parser.mly → src/ligo/ligo-parser/Parser.mly
View File

38
src/ligo/parser/ParserMain.ml → src/ligo/ligo-parser/ParserMain.ml
View File

@ -34,12 +34,40 @@ let lib_path =
in List.fold_right mk_I libs ""
*)
(* Preprocessing the input source and opening the input channels *)
let prefix =
match EvalOpt.input with
None | Some "-" -> "temp"
| Some file -> Filename.(file |> basename |> remove_extension)
let suffix = ".pp.li"
let pp_input =
if Utils.String.Set.mem "cpp" EvalOpt.verbose
then prefix ^ suffix
else let pp_input, pp_out = Filename.open_temp_file prefix suffix
in close_out pp_out; pp_input
let cpp_cmd =
match EvalOpt.input with
None | Some "-" ->
Printf.sprintf "cpp -traditional-cpp - -o %s" pp_input
| Some file ->
Printf.sprintf "cpp -traditional-cpp %s -o %s" file pp_input
let () =
if Utils.String.Set.mem "cpp" EvalOpt.verbose
then Printf.eprintf "%s\n%!" cpp_cmd;
if Sys.command cpp_cmd <> 0 then
external_ (Printf.sprintf "the command \"%s\" failed." cpp_cmd)
(* Instanciating the lexer *)
module Lexer = Lexer.Make (LexToken)
let Lexer.{read; buffer; get_pos; get_last; close} =
Lexer.open_token_stream EvalOpt.input
Lexer.open_token_stream (Some pp_input)
and cout = stdout
@ -78,6 +106,8 @@ let () =
(* Temporary: force dune to build AST2.ml *)
let () =
let open Typecheck2 in
let _ = temporary_force_dune in
()
if false then
let _ = Typecheck2.annotate in
()
else
()

0
src/ligo/parser/Pos.ml → src/ligo/ligo-parser/Pos.ml
View File

0
src/ligo/parser/Pos.mli → src/ligo/ligo-parser/Pos.mli
View File

0
src/ligo/parser/Region.ml → src/ligo/ligo-parser/Region.ml
View File

0
src/ligo/parser/Region.mli → src/ligo/ligo-parser/Region.mli
View File

0
src/ligo/parser/Tests/a.li → src/ligo/ligo-parser/Tests/a.li
View File

71
src/ligo/parser/Typecheck2.ml → src/ligo/ligo-parser/Typecheck2.ml
View File

@ -1,7 +1,11 @@
[@@@warning "-27"] (* TODO *)
[@@@warning "-32"] (* TODO *)
[@@@warning "-30"]
module SMap = Map.Make(String)
module I = AST2.O
module O = struct
type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *)
@ -23,7 +27,7 @@ module O = struct
| PSome of pattern
| PCons of pattern * pattern
| PNull
| PRecord of (field_name * pattern) list
| PRecord of (field_name * pattern) SMap.t
type type_constructor =
Option
@ -32,8 +36,8 @@ module O = struct
| Map
type type_expr_case =
Sum of (type_name * type_expr) list
| Record of (field_name * type_expr) list
Sum of (type_name * type_expr) SMap.t
| Record of (field_name * type_expr) SMap.t
| TypeApp of type_constructor * (type_expr list)
| Function of { arg: type_expr; ret: type_expr }
| Ref of type_expr
@ -42,7 +46,7 @@ module O = struct
| Unit
| Bool
and type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr }
and type_expr = { type_expr: type_expr_case; name: string option; orig: Region.t }
type typed_var = { name:var_name; ty:type_expr; orig: asttodo }
@ -68,7 +72,7 @@ module O = struct
and operator_case =
Function of var_name
| Construcor of var_name
| Constructor of var_name
| UpdateField of field_name
| GetField of field_name
| Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod
@ -98,8 +102,61 @@ module O = struct
types : type_decl list;
storage_decl : typed_var;
declarations : decl list;
orig: AST.t
orig : AST.t
}
end
let temporary_force_dune = 123
type te = O.type_expr list SMap.t
type ve = O.type_expr list SMap.t
type tve = te * ve
let fold_map f a l =
let f (acc, l) elem =
let acc', elem' = f acc elem
in acc', (elem' :: l) in
let last_acc, last_l = List.fold_left f (a, []) l
in last_acc, List.rev last_l
let a_type_constructor (tve : tve) : I.type_constructor -> O.type_constructor = function
Option -> failwith "TODO"
| List -> failwith "TODO"
| Set -> failwith "TODO"
| Map -> failwith "TODO"
let a_type_expr_case (tve : tve) : I.type_expr_case -> O.type_expr_case = function
Sum l -> failwith "TODO"
| Record l -> failwith "TODO"
| TypeApp (tc, args) -> failwith "TODO"
| Function {arg;ret} -> failwith "TODO"
| Ref t -> failwith "TODO"
| String -> failwith "TODO"
| Int -> failwith "TODO"
| Unit -> failwith "TODO"
| Bool -> failwith "TODO"
let a_type_expr (tve : tve) ({type_expr;name;orig} : I.type_expr) : O.type_expr =
failwith "TODO"
let a_type (tve : tve) ({name;ty;orig} : I.type_decl) : tve * O.type_decl =
failwith "TODO"
let a_types (tve : tve) (l : I.type_decl list) : tve * O.type_decl list =
fold_map a_type tve l
let a_storage_decl : tve -> I.typed_var -> tve * O.typed_var =
failwith "TODO"
let a_declarations : tve -> I.decl list -> tve * O.decl list =
failwith "TODO"
let a_ast I.{types; storage_decl; declarations; orig} =
let tve = SMap.empty, SMap.empty in
let tve, types = a_types tve types in
let tve, storage_decl = a_storage_decl tve storage_decl in
let tve, declarations = a_declarations tve declarations in
let _ = tve in
O.{types; storage_decl; declarations; orig}
let annotate : I.ast -> O.ast = a_ast

16
src/ligo/parser/Typecheck2.mli → src/ligo/ligo-parser/Typecheck2.mli
View File

@ -2,6 +2,8 @@
module SMap : Map.S with type key = string
module I = AST2.O
module O : sig
type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *)
@ -23,7 +25,7 @@ module O : sig
| PSome of pattern
| PCons of pattern * pattern
| PNull
| PRecord of (field_name * pattern) list
| PRecord of (field_name * pattern) SMap.t
type type_constructor =
Option
@ -32,8 +34,8 @@ module O : sig
| Map
type type_expr_case =
Sum of (type_name * type_expr) list
| Record of (field_name * type_expr) list
Sum of (type_name * type_expr) SMap.t
| Record of (field_name * type_expr) SMap.t
| TypeApp of type_constructor * (type_expr list)
| Function of { arg: type_expr; ret: type_expr }
| Ref of type_expr
@ -42,7 +44,7 @@ module O : sig
| Unit
| Bool
and type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr }
and type_expr = { type_expr: type_expr_case; name: string option; orig: Region.t }
type typed_var = { name:var_name; ty:type_expr; orig: asttodo }
@ -68,7 +70,7 @@ module O : sig
and operator_case =
Function of var_name
| Construcor of var_name
| Constructor of var_name
| UpdateField of field_name
| GetField of field_name
| Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod
@ -98,8 +100,8 @@ module O : sig
types : type_decl list;
storage_decl : typed_var;
declarations : decl list;
orig: AST.t
orig : AST.t
}
end
val temporary_force_dune : int
val annotate : I.ast -> O.ast

0
src/ligo/parser/Utils.ml → src/ligo/ligo-parser/Utils.ml
View File

0
src/ligo/parser/Utils.mli → src/ligo/ligo-parser/Utils.mli
View File

0
src/ligo/parser/Version.ml → src/ligo/ligo-parser/Version.ml
View File

0
src/ligo/parser/check_dot_git_is_dir.sh → src/ligo/ligo-parser/check_dot_git_is_dir.sh
View File

0
src/ligo/parser/dune → src/ligo/ligo-parser/dune
View File

0
src/ligo/parser/ligo-parser.opam → src/ligo/ligo-parser/ligo-parser.opam
View File

7
src/ligo/ligo-parser/ligo_parser.ml Normal file
View File

@ -0,0 +1,7 @@
module Parser = Parser
module Lexer = Lexer.Make(LexToken)
module AST = AST
module AST2 = AST2
module Typed = Typecheck2
let ast_to_typed_ast ast = ast |> AST2.s_ast |> Typed.annotate

0
src/ligo/parser/typecheck.ml → src/ligo/ligo-parser/typecheck.ml
View File

52
src/ligo/ligo.ml
View File

@ -1,5 +1,53 @@
include Main
open Ligo_parser
module Mini_c = Mini_c
module Parser = Parser
module Lexer = Lexer
module CST = AST
module AST = AST2
module Typed = Typed
module Mini_c = Mini_c
open Ligo_helpers.Trace
let parse_file (source:string) : CST.t result =
let channel = open_in source in
let lexbuf = Lexing.from_channel channel in
let Lexer.{read ; _} =
Lexer.open_token_stream None in
specific_try (function
| Parser.Error -> (
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Parse error at \"%s\" from (%d, %d) to (%d, %d)\n"
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
simple_error str
)
| _ -> simple_error "unrecognized parse_ error"
) @@ (fun () -> Parser.program read lexbuf) >>? fun program_cst ->
ok program_cst
let parse (s:string) : CST.t result =
let lexbuf = Lexing.from_string s in
let Lexer.{read ; _} =
Lexer.open_token_stream None in
specific_try (function
| Parser.Error -> (
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Parse error at \"%s\" from (%d, %d) to (%d, %d)\n"
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
simple_error str
)
| _ -> simple_error "unrecognized parse_ error"
) @@ (fun () -> Parser.program read lexbuf) >>? fun program_cst ->
ok program_cst
let abstract (cst:CST.t) : AST.O.ast result = ok @@ AST.s_ast cst
let annotate_types (ast:AST.O.ast) = ok @@ Typed.annotate ast

461
src/ligo/main.ml
View File

@ -1,461 +0,0 @@
(* -*- compile-command: "cd .. ; dune build -p ligo" -*- *)
open Ligo_helpers
open Trace
module Untyped = struct
module WrapLocation = Wrap.Location
let wrap = Wrap.Location.make
module Type = struct
type name = string
type base = [
| `Unit
| `Bool
| `Int
| `Nat
]
let unit : base = `Unit
let bool : base = `Bool
let int : base = `Int
let nat : base = `Nat
type 'a node = [
| `Pair of 'a * 'a
| `Or of 'a * 'a
]
type expression_ast = [
| expression node
| base
| `Name of name
]
and expression = expression_ast WrapLocation.t
let pair ~loc a b : expression = wrap ~loc (`Pair(a,b))
let union ~loc a b : expression = wrap ~loc (`Or(a,b))
let name ~loc s : expression =
wrap ~loc (match s with
| "Unit" -> (unit :> expression_ast)
| "Bool" -> (bool :> expression_ast)
| "Int" -> (int :> expression_ast)
| "Nat" -> (nat :> expression_ast)
| s -> `Name s)
end
module Value = struct
type name = string
type function_name = string
type constant = [
| `Int of int
]
type expression = [
| `Variable of name
| `Pair of expression * expression
| `Application of expression * expression
| `Constant of constant
] WrapLocation.t
type assignment = [
| `Let of name * expression
| `Type of Type.name * Type.expression
| `Function of function_name * Type.expression * block
] WrapLocation.t
and statement = [
| `Assignment of assignment
| `ForEach of name * expression * block
| `While of expression * block
| `Condition of expression * block * (expression * block) list * block option
] WrapLocation.t
and block = statement list WrapLocation.t
and program = assignment list WrapLocation.t
type 'a wrapper = loc:Location.t -> 'a -> 'a WrapLocation.t
let int = (WrapLocation.make_f (fun a -> `Constant (`Int a)) : loc:_ -> _ -> expression)
let constatn = (WrapLocation.make_f (fun a -> `Constant a) : loc:_ -> _ -> expression)
let variable = (WrapLocation.make_f (fun a -> `Variable a) : loc:_ -> _ -> expression)
let pair = (WrapLocation.make_f (fun a -> `Pair a) : loc:_ -> _ -> expression)
let application = (WrapLocation.make_f (fun a -> `Application a) : loc:_ -> _ -> expression)
let let_ = (WrapLocation.make_f (fun a -> `Let a) : loc:_ -> _ -> assignment)
let type_ = (WrapLocation.make_f (fun a -> `Type a) : loc:_ -> _ -> assignment)
let fun_ = (WrapLocation.make_f (fun a -> `Function a) : loc:_ -> _ -> assignment)
let assignment = (WrapLocation.make_f (fun a -> `Assignment a) : loc:_ -> _ -> statement)
let foreach = (WrapLocation.make_f (fun a -> `ForEach a) : loc:_ -> _ -> statement)
let while_ = (WrapLocation.make_f (fun a -> `While a) : loc:_ -> _ -> statement)
let elseif x : (expression * block) = x
let else_ x : block = x
let if_ = (WrapLocation.make_f (fun a -> `Condition a) : loc:_ -> _ -> statement)
let block = (WrapLocation.make : loc:_ -> _ -> block)
let program = (WrapLocation.make : loc:_ -> _ -> program)
end
end
module Typed = struct
module Type = struct
module WrapLocation = Wrap.Location
let wrap = WrapLocation.make
type name = string
type base = [
| `Unit
| `Bool
| `Int
| `Nat
]
let unit : base = `Unit
let bool : base = `Bool
let int : base = `Int
let nat : base = `Nat
type 'a node = [
| `Pair of 'a * 'a
| `Or of 'a * 'a
]
type value = [
| value node
| base
]
type expression_ast = [
| expression node
| base
| `Name of name
]
and expression = expression_ast
let rec of_untyped (x:Untyped.Type.expression) : expression = match x.value with
| `Pair(a, b) -> `Pair(of_untyped a, of_untyped b)
| `Or(a, b) -> `Or(of_untyped a, of_untyped b)
| `Int as s -> s
| `Unit as s -> s
| `Nat as s -> s
| `Bool as s -> s
| `Name _ as s -> s
let pair_v a b : value = `Pair(a,b)
let union_v a b : value = `Or(a,b)
let pair_e a b : expression = `Pair(a,b)
let union_e a b : expression = `Or(a,b)
let name : string -> expression = function
| "Unit" -> (unit :> expression_ast)
| "Bool" -> (bool :> expression_ast)
| "Int" -> (int :> expression_ast)
| "Nat" -> (nat :> expression_ast)
| s -> `Name s
module Environment = Environment.Make(val (
Environment.parameter () :
(module Environment.PARAMETER
with type key = name
and type value = value)))
let rec eval (env:Environment.t) : expression -> value result = function
| `Name x -> (
trace_option (simple_error "name doesn't exist in environment") @@
Environment.get_opt env x
)
| `Pair (a, b) -> (
eval env a >>? fun a ->
eval env b >>? fun b ->
ok (`Pair (a, b))
)
| `Or (a, b) -> (
eval env a >>? fun a ->
eval env b >>? fun b ->
ok (`Or (a, b))
)
| `Bool as x -> ok x
| `Unit as x -> ok x
| `Nat as x -> ok x
| `Int as x -> ok x
end
module Value = struct
module WrapLocation = Wrap.Location
let wrap = WrapLocation.make
module WrapTypeLocation = Wrap.Make(struct type meta = (Type.value * Location.t) end)
let wrap_tl = WrapTypeLocation.make
let type_of (x:'a WrapTypeLocation.t) : Type.value = fst x.meta
type name = string
type function_name = string
type constant = [
| `Int of int
]
type 'a node = [
| `Constant of constant
| `Pair of 'a * 'a
]
let int n = `Constant (`Int n)
type value = value node
type expression = [
| expression node
| `Variable of name
] WrapTypeLocation.t
let variable n = `Variable n
let pair a b = `Pair (a, b)
type assignment = [
| `Let of name * expression
| `Type of Type.name * Type.value
| `Function of function_name * Type.value * block * Type.value
] WrapLocation.t
and statement = assignment
and block = statement list
and toplevel_statement = assignment
and program = toplevel_statement list
module Environment = Environment.Make(val (
Environment.parameter () :
(module Environment.PARAMETER
with type key = name
and type value = Type.value)))
end
module Environment = struct
type type_environment = Type.Environment.t
type value_environment = Value.Environment.t
type t = {
type_environment : type_environment ;
value_environment : value_environment ;
}
let empty = {
type_environment = Type.Environment.empty ;
value_environment = Value.Environment.empty ;
}
let add_type env
name type_value =
{ env with
type_environment =
Type.Environment.set env.type_environment name type_value }
let add_variable env
name type_value =
{ env with
value_environment =
Value.Environment.set env.value_environment name type_value }
end
end
module Typecheck = struct
module UV = Untyped.Value
module UT = Untyped.Type
module TV = Typed.Value
module TT = Typed.Type
type env = Typed.Environment.t
type ty = Typed.Type.value
let typecheck_constant (constant:UV.constant) : _ = match constant with
| `Int n -> (`Int, `Int n)
let rec typecheck_expression (env:env) (e:UV.expression) : (TV.expression) result =
match e.value with
| `Constant c -> (
let (ty, value) = typecheck_constant c in
ok (TV.wrap_tl (ty, e.meta) (`Constant value))
)
| `Variable n -> (
trace_option (simple_error "variable doesn't exist in env")
@@ TV.Environment.get_opt env.value_environment n >>? fun ty ->
ok (TV.wrap_tl (ty, e.meta) (TV.variable n))
)
| `Pair(a, b) -> (
typecheck_expression env a >>? fun a ->
typecheck_expression env b >>? fun b ->
let ty = TT.pair_v (TV.type_of a) (TV.type_of b) in
ok (TV.wrap_tl (ty, e.meta) (TV.pair a b))
)
| `Application _ -> simple_fail "Application isn't supported yet"
let rec typecheck_assignment (env:env) (u:UV.assignment) : (env * TV.assignment) result =
match u.value with
| `Let(name, expression) -> (
typecheck_expression env expression >>? fun expression ->
let ass : TV.assignment = TV.wrap ~loc:u.meta (`Let(name, expression)) in
let env = Typed.Environment.add_variable env name (TV.type_of expression) in
ok (env, ass)
)
| `Type(name, expression) -> (
TT.eval env.type_environment (TT.of_untyped expression) >>? fun value ->
let env = Typed.Environment.add_type env name value in
let ass : TV.assignment = TV.wrap ~loc:u.meta (`Type(name, value)) in
ok (env, ass)
)
| `Function(name, type_expression, block) -> (
TT.eval env.type_environment (TT.of_untyped type_expression) >>? fun type_value ->
let env = Typed.Environment.add_variable env "input" type_value in
typecheck_block env block >>? fun (env, block) ->
let ty =
match TV.Environment.get_opt env.value_environment "output" with
| None -> `Unit
| Some x -> x in
let ass : TV.assignment = TV.wrap ~loc:u.meta (`Function(name, type_value, block, ty)) in
ok (env, ass)
)
and typecheck_statement (env:env) (s:Untyped.Value.statement) : (env * Typed.Value.statement) result =
match s.value with
| `Assignment a -> typecheck_assignment env a
| `Condition (_bool_expr, _block, _elseifs, _else_opt) -> simple_fail "conditions aren't supported yet"
| `ForEach _ -> simple_fail "foreach is not supported yet"
| `While _ -> simple_fail "while is not supported yet"
and typecheck_block (env:env) (b:Untyped.Value.block) : (env * Typed.Value.block) result =
let rec aux env = function
| [] -> ok (env, [])
| hd :: tl -> (
typecheck_statement env hd >>? fun (env, hd) ->
aux env tl >>? fun (env, tl) ->
ok (env, hd :: tl)
) in
aux env b.value
let typecheck_program ?(env=Typed.Environment.empty) (u:Untyped.Value.program) : Typed.Value.program result =
let rec aux env = function
| [] -> ok []
| hd :: tl -> (
typecheck_assignment env hd >>? fun (env, hd) ->
aux env tl >>? fun tl ->
ok (hd :: tl)
) in
aux env u.value
end
module Transpile = struct
open Mini_c
open Typed
let rec translate_type : Type.value -> Mini_c.type_value result = function
| `Bool -> ok (`Base Bool)
| `Int -> ok (`Base Int)
| `Nat -> ok (`Base Nat)
| `Unit -> ok (`Base Unit)
| `Pair(a, b) -> (
translate_type a >>? fun a ->
translate_type b >>? fun b ->
ok (`Pair(a, b))
)
| `Or(a, b) -> (
translate_type a >>? fun a ->
translate_type b >>? fun b ->
ok (`Or(a, b))
)
let rec translate_expression (e:Value.expression) : Mini_c.expression result =
let%bind (e' : Mini_c.expression') = match e.value with
| `Constant (`Int n) -> ok (Literal (`Int n))
| `Variable n -> ok (Var n)
| `Pair (a, b) -> (
translate_expression a >>? fun a ->
translate_expression b >>? fun b ->
ok (Predicate("Pair", [a ; b]))
) in
let%bind (t : Mini_c.type_value) = translate_type @@ fst e.meta in
ok (e', t)
let rec translate_assignment (ass:Value.assignment)
: Mini_c.assignment option result = match ass.value with
| `Let(x, expr) -> (
translate_expression expr >>? fun expr ->
ok (Some (Variable(x, expr)))
)
| `Function(name, input_ty, body, output_ty) -> (
translate_type input_ty >>? fun input ->
translate_type output_ty >>? fun output ->
block body >>? fun body ->
let ass = Fun(name, {input ; output ; body}) in
ok (Some ass)
)
| `Type _ -> ok None
and statement (st:Value.statement)
: Mini_c.statement option result =
translate_assignment st >>? fun a ->
let ass = match a with
| Some a -> Some (Assignment a)
| None -> None in
ok ass
and block : Value.block -> Mini_c.block result = function
| [] -> ok []
| hd :: tl -> (
statement hd >>? fun st_opt ->
let sts = match st_opt with
| Some x -> [x]
| None -> [] in
block tl >>? fun (new_sts) ->
ok (sts @ new_sts)
)
let translate_toplevel_statement = translate_assignment
let rec program : Value.program -> Mini_c.program result = function
| [] -> ok []
| hd :: tl -> (
translate_assignment hd >>? fun ass_opt ->
let asss = match ass_opt with
| Some x -> [x]
| None -> [] in
program tl >>? fun (new_asss) ->
ok (asss @ new_asss)
)
let of_mini_c : Mini_c.value -> Value.value result = function
| `Int n -> ok (Value.int n)
| _ -> simple_fail "unknown value"
let to_mini_c : Value.value -> Mini_c.value result = function
| `Constant (`Int n) -> ok (`Int n)
| _ -> simple_fail "unknown value"
let program_to_michelson (p:Value.program) =
let%bind program_mini_c = program p in
let%bind program = Mini_c.Translate_program.translate program_mini_c in
ok program.body
end
module Run = struct
open Typed.Value
let run (program : program) (input : value) : value result =
Transpile.program program >>? fun program_mini_c ->
Transpile.to_mini_c input >>? fun input_mini_c ->
(* Format.printf "%a\n" Mini_c.PP.program program_mini_c ; *)
Mini_c.Run.run program_mini_c input_mini_c >>? fun output_mini_c ->
Transpile.of_mini_c output_mini_c >>? fun output ->
ok output
end

12
src/ligo/mini_c.ml
View File

@ -1042,14 +1042,16 @@ module Translate_AST = struct
List.map (rename_declaration src dst) decls
end
let list_of_map m = List.rev @@ SMap.fold (fun _ v prev -> v :: prev) m []
let rec translate_type : AST.type_expr -> type_value result = fun {type_expr} ->
match type_expr with
| Unit -> ok (`Base Unit)
| Int -> ok (`Base Int)
| String -> ok (`Base String)
| Bool -> ok (`Base Bool)
| Sum lst ->
let node = Append_tree.of_list @@ List.map snd lst in
| Sum m ->
let node = Append_tree.of_list @@ List.map snd @@ list_of_map m in
let aux a b : type_value result =
let%bind a = a in
let%bind b = b in
@ -1057,7 +1059,7 @@ module Translate_AST = struct
in
Append_tree.fold_ne translate_type aux node
| Record r ->
let node = Append_tree.of_list @@ List.map snd r in
let node = Append_tree.of_list @@ List.map snd @@ list_of_map r in
let aux a b : type_value result =
let%bind a = a in
let%bind b = b in
@ -1150,8 +1152,8 @@ module Translate_AST = struct
let rec to_mini_c_value' : (AST.expr_case * AST.type_expr) -> value result = function
| Constant c, _ -> translate_constant c
| App {arguments;operator = {operator = Construcor c ; ty = {type_expr = Sum lst}}}, _ ->
let node = Append_tree.of_list @@ List.map fst lst in
| App {arguments;operator = {operator = Constructor c ; ty = {type_expr = Sum lst}}}, _ ->
let node = Append_tree.of_list @@ List.map fst @@ list_of_map lst in
let%bind lst =
trace_option (simple_error "Not constructor of variant type") @@
Append_tree.exists_path (fun (x:AST.name_and_region) -> x.name = c.name) node in

200
src/ligo/parser.mly
View File

@ -1,200 +0,0 @@
%{
module Location = Ligo_helpers.Location
open Main.Untyped
open Value
%}
%token EOF
%token <int> INT
//%token <float> FLOAT
%token <string> STRING
%token <string> VAR_NAME
%token <string> FUNCTION_NAME
%token <string> TYPE_NAME
//%token PLUS MINUS TIMES DIV
%token COLON SEMICOLON /* DOUBLE_SEMICOLON */ COMMA AT EQUAL DOT
%token OR AND
%token LPAREN RPAREN
%token LBRACKET RBRACKET
%token IF ELSEIF ELSE // THEN
%token FOREACH OF WHILE
%token LET TYPE FUNCTION
// toto.tata @ 3 + 4 = 2 ; printf (lel)
//%left COLON
%left COMMA
%left AT
%left OR
%left AND
//%left EQUAL
//%left PLUS MINUS /* lowest precedence */
//%left TIMES DIV /* medium precedence */
%left DOT
%start <Main.Untyped.Value.program> main
%%
main:
| sts = assignment+ EOF
{
let loc = Location.make $startpos $endpos in
program ~loc sts
}
assignment:
| LET v = VAR_NAME EQUAL e = expr SEMICOLON
{
let loc = Location.make $startpos $endpos in
let_ ~loc (v, e)
}
| FUNCTION f = VAR_NAME COLON t = type_expr EQUAL b = block SEMICOLON
{
let loc = Location.make $startpos $endpos in
fun_ ~loc (f, t, b)
}
| TYPE n = TYPE_NAME EQUAL t = type_expr SEMICOLON
{
let loc = Location.make $startpos $endpos in
type_ ~loc (n, t)
}
statement:
| ass = assignment
{
let loc = Location.make $startpos $endpos in
assignment ~loc ass
}
| FOREACH var = VAR_NAME OF iterator = expr body = block
{
let loc = Location.make $startpos $endpos in
foreach ~loc (var, iterator, body)
}
| WHILE cond = expr body = block
{
let loc = Location.make $startpos $endpos in
while_ ~loc (cond, body)
}
| IF e = expr b = block eis = else_if* eo = else_?
{
let loc = Location.make $startpos $endpos in
if_ ~loc (e, b, eis, eo)
}
else_if:
| ELSEIF LPAREN cond = expr RPAREN body = block
{
elseif (cond, body)
}
else_:
| ELSE body = block
{
else_ body
}
block:
| LBRACKET sts = statement+ RBRACKET
{
let loc = Location.make $startpos $endpos in
block ~loc sts
}
expr:
| i = INT
{
let loc = Location.make $startpos $endpos in
Value.int ~loc i
}
(*
| f = FLOAT
{
let loc = Location.make $startpos $endpos in
make ~loc @@ literal @@ Float f
}
| s = STRING
{
let loc = Location.make $startpos $endpos in
make ~loc @@ literal @@ String s
}
*)
| v = VAR_NAME
{
let loc = Location.make $startpos $endpos in
variable ~loc v
}
| LPAREN e = expr RPAREN
{
let loc = Location.make $startpos $endpos in
WrapLocation.update_location ~loc e
}
| e1 = expr COMMA e2 = expr
{
let loc = Location.make $startpos $endpos in
Value.pair ~loc (e1, e2)
}
| e1 = expr AT e2 = expr
{
let loc = Location.make $startpos $endpos in
application ~loc (e1, e2)
}
| e1 = expr DOT e2 = expr
{
let loc = Location.make $startpos $endpos in
application ~loc (e2, e1)
}
(*
| e = expr COLON t = type_expr
{
let loc = Location.make $startpos $endpos in
make ~loc @@ cast e t
}
| e1 = expr PLUS e2 = expr
{
let loc = Location.make $startpos $endpos in
make ~loc @@ primitive Plus [e1 ; e2]
}
| e1 = expr MINUS e2 = expr
{
let loc = Location.make $startpos $endpos in
make ~loc @@ primitive Minus [e1 ; e2]
}
| e1 = expr TIMES e2 = expr
{
let loc = Location.make $startpos $endpos in
make ~loc @@ primitive Times [e1 ; e2]
}
| e1 = expr DIV e2 = expr
{
let loc = Location.make $startpos $endpos in
make ~loc @@ primitive Div [e1 ; e2]
}
| e1 = expr EQUAL e2 = expr
{
let loc = Location.make $startpos $endpos in
make ~loc @@ primitive Equal [e1 ; e2]
}
| e = expr DOT v = VAR_NAME
{
let loc = Location.make $startpos $endpos in
make ~loc @@ dot e v
}
*)
type_expr:
| t = TYPE_NAME
{
let loc = Location.make $startpos $endpos in
Type.(name ~loc t)
}
| t1 = type_expr AND t2 = type_expr
{
let loc = Location.make $startpos $endpos in
Type.(pair ~loc t1 t2)
}
| t1 = type_expr OR t2 = type_expr
{
let loc = Location.make $startpos $endpos in
Type.(union ~loc t1 t2)
}

1
src/ligo/parser/ligo_parser.ml
View File

@ -1 +0,0 @@
module Typed = Typecheck2

307
src/ligo/test/test.ml
View File

@ -8,175 +8,158 @@ let test name f =
match f () with
| Ok () -> ()
| Errors errs ->
Format.printf "Errors : {\n%a}\n%!" errors_pp errs ;
raise Alcotest.Test_error
Format.printf "Errors : {\n%a}\n%!" errors_pp errs ;
raise Alcotest.Test_error
open Mini_c
open Combinators
let simple_int_program body : program = [
Fun("main", function_int body)
]
module Mini_c = struct
let run_int program n =
Run.run program (`Int n) >>? function
| `Int n -> ok n
| _ -> simple_fail "run_int : output not int"
let neg () =
let program : program = simple_int_program [
assign_variable "output" @@ neg_int (var_int "input") ;
assign_variable "output" @@ neg_int (var_int "output") ;
assign_variable "output" @@ neg_int (var_int "output") ;
] in
run_int program 42 >>? fun output ->
Assert.assert_equal_int (-42) output >>? fun () ->
ok ()
let multiple_variables () =
let program = simple_int_program [
assign_variable "a" @@ neg_int (var_int "input") ;
assign_variable "b" @@ neg_int (var_int "a") ;
assign_variable "c" @@ neg_int (var_int "b") ;
assign_variable "d" @@ neg_int (var_int "c") ;
assign_variable "output" @@ neg_int (var_int "d") ;
] in
run_int program 42 >>? fun output ->
Assert.assert_equal_int (-42) output >>? fun () ->
ok ()
let arithmetic () =
let expression = add_int (var_int "input") (neg_int (var_int "input")) in
let program = simple_int_program [
Assignment (Variable ("a", expression)) ;
Assignment (Variable ("b", var_int "a")) ;
Assignment (Variable ("output", var_int "b")) ;
] in
let test n =
run_int program n >>? fun output ->
Assert.assert_equal_int 0 output >>? fun () ->
ok ()
in
let%bind _assert = bind_list @@ List.map test [42 ; 150 ; 0 ; -42] in
ok ()
let quote_ () =
let program = simple_int_program [
assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "input") (int 42)] ;
assign_function "g" @@ function_int [assign_variable "output" @@ neg_int (var_int "input")] ;
assign_variable "output" @@ apply_int (type_f_int @@ var "g") @@ apply_int (type_f_int @@ var "f") (var_int "input") ;
] in
let%bind output = run_int program 42 in
let%bind _ = Assert.assert_equal_int (-84) output in
ok ()
let function_ () =
let program = simple_int_program [
assign_variable "a" @@ int 42 ;
assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "input") (var_int "a")] ;
let env = Environment.Small.of_list ["a", t_int] in
assign_variable "output" @@ apply_int (type_closure_int env @@ var "f") (var_int "input") ;
] in
let%bind output = run_int program 100 in
let%bind _ = Assert.assert_equal_int 142 output in
ok ()
let functions_ () =
let program = simple_int_program [
assign_variable "a" @@ int 42 ;
assign_variable "b" @@ int 144 ;
assign_function "f" @@ function_int [
assign_variable "output" @@ add_int (var_int "input") (var_int "a")
] ;
assign_function "g" @@ function_int [
assign_variable "output" @@ add_int (var_int "input") (var_int "b")
] ;
let env_f = Environment.Small.of_list ["a", t_int] in
let env_g = Environment.Small.of_list ["b", t_int] in
assign_variable "output" @@ add_int
(apply_int (type_closure_int env_f @@ var "f") (var_int "input"))
(apply_int (type_closure_int env_g @@ var "g") (var_int "input"))
] in
let%bind output = run_int program 100 in
let%bind _ = Assert.assert_equal_int 386 output in
ok ()
let rich_function () =
let program = simple_int_program [
assign_variable "a" @@ int 42 ;
assign_variable "b" @@ int 144 ;
assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "a") (var_int "b")] ;
let env = Environment.Small.of_list [("a", t_int) ; ("b", t_int)] in
assign_variable "output" @@ apply_int (type_closure_int env @@ var "f") (var_int "input") ;
] in
let test n =
let%bind output = run_int program n in
let%bind _ = Assert.assert_equal_int 186 output in
ok () in
let%bind _assert = bind_list @@ List.map test [42 ; 150 ; 0 ; -42] in
ok ()
let main = "Mini_c", [
test "basic.neg" neg ;
test "basic.variables" multiple_variables ;
test "basic.arithmetic" arithmetic ;
test "basic.quote" quote_ ;
test "basic.function" function_ ;
test "basic.functions" functions_ ;
test "basic.rich_function" rich_function ;
let simple_int_program body : program = [
Fun("main", function_int body)
]
(* module Ligo = struct
* let parse_file (source:string) : Ligo.Untyped.Value.program result =
* let channel = open_in source in
* let lexbuf = Lexing.from_channel channel in
* specific_try (function
* | Parser.Error -> (
* let start = Lexing.lexeme_start_p lexbuf in
* let end_ = Lexing.lexeme_end_p lexbuf in
* let str = Format.sprintf
* "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n"
* (Lexing.lexeme lexbuf)
* start.pos_lnum (start.pos_cnum - start.pos_bol)
* end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
* simple_error str
* )
* | Lexer.Unexpected_character s -> simple_error s
* | Lexer.Error _ -> simple_error "lexer error"
* | _ -> simple_error "unrecognized parse_ error"
* ) @@ (fun () -> Parser.main Lexer.token lexbuf) >>? fun program_ast ->
* ok program_ast
*
* let run (source:string) (input:Ligo.Typed.Value.value) : Ligo.Typed.Value.value result =
* parse_file source >>? fun program_ast ->
* Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program ->
* Ligo.Run.run typed_program input >>? fun output ->
* ok output
*
* let assert_value_int : Ligo.Typed.Value.value -> int result = function
* | `Constant (`Int n) -> ok n
* | _ -> simple_fail "not an int"
*
* let basic () : unit result =
* run "./contracts/toto.ligo" (Ligo.Typed.Value.int 42) >>? fun output ->
* assert_value_int output >>? fun output ->
* Assert.assert_equal_int 42 output >>? fun () ->
* ok ()
*
* let display_basic () : unit result =
* parse_file "./contracts/toto.ligo" >>? fun program_ast ->
* Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program ->
* Ligo.Transpile.program_to_michelson typed_program >>? fun node ->
* let node = Tezos_utils.Cast.flatten_node node in
* let str = Tezos_utils.Cast.node_to_string node in
* Format.printf "Program:\n%s\n%!" str ;
* ok ()
*
* let main = "Ligo", [
* test "basic" basic ;
* test "basic.display" display_basic ;
* ]
* end *)
let run_int program n =
Run.run program (`Int n) >>? function
| `Int n -> ok n
| _ -> simple_fail "run_int : output not int"
let neg () =
let program : program = simple_int_program [
assign_variable "output" @@ neg_int (var_int "input") ;
assign_variable "output" @@ neg_int (var_int "output") ;
assign_variable "output" @@ neg_int (var_int "output") ;
] in
run_int program 42 >>? fun output ->
Assert.assert_equal_int (-42) output >>? fun () ->
ok ()
let multiple_variables () =
let program = simple_int_program [
assign_variable "a" @@ neg_int (var_int "input") ;
assign_variable "b" @@ neg_int (var_int "a") ;
assign_variable "c" @@ neg_int (var_int "b") ;
assign_variable "d" @@ neg_int (var_int "c") ;
assign_variable "output" @@ neg_int (var_int "d") ;
] in
run_int program 42 >>? fun output ->
Assert.assert_equal_int (-42) output >>? fun () ->
ok ()
let arithmetic () =
let expression = add_int (var_int "input") (neg_int (var_int "input")) in
let program = simple_int_program [
Assignment (Variable ("a", expression)) ;
Assignment (Variable ("b", var_int "a")) ;
Assignment (Variable ("output", var_int "b")) ;
] in
let test n =
run_int program n >>? fun output ->
Assert.assert_equal_int 0 output >>? fun () ->
ok ()
in
let%bind _assert = bind_list @@ List.map test [42 ; 150 ; 0 ; -42] in
ok ()
let quote_ () =
let program = simple_int_program [
assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "input") (int 42)] ;
assign_function "g" @@ function_int [assign_variable "output" @@ neg_int (var_int "input")] ;
assign_variable "output" @@ apply_int (type_f_int @@ var "g") @@ apply_int (type_f_int @@ var "f") (var_int "input") ;
] in
let%bind output = run_int program 42 in
let%bind _ = Assert.assert_equal_int (-84) output in
ok ()
let function_ () =
let program = simple_int_program [
assign_variable "a" @@ int 42 ;
assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "input") (var_int "a")] ;
let env = Environment.Small.of_list ["a", t_int] in
assign_variable "output" @@ apply_int (type_closure_int env @@ var "f") (var_int "input") ;
] in
let%bind output = run_int program 100 in
let%bind _ = Assert.assert_equal_int 142 output in
ok ()
let functions_ () =
let program = simple_int_program [
assign_variable "a" @@ int 42 ;
assign_variable "b" @@ int 144 ;
assign_function "f" @@ function_int [
assign_variable "output" @@ add_int (var_int "input") (var_int "a")
] ;
assign_function "g" @@ function_int [
assign_variable "output" @@ add_int (var_int "input") (var_int "b")
] ;
let env_f = Environment.Small.of_list ["a", t_int] in
let env_g = Environment.Small.of_list ["b", t_int] in
assign_variable "output" @@ add_int
(apply_int (type_closure_int env_f @@ var "f") (var_int "input"))
(apply_int (type_closure_int env_g @@ var "g") (var_int "input"))
] in
let%bind output = run_int program 100 in
let%bind _ = Assert.assert_equal_int 386 output in
ok ()
let rich_function () =
let program = simple_int_program [
assign_variable "a" @@ int 42 ;
assign_variable "b" @@ int 144 ;
assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "a") (var_int "b")] ;
let env = Environment.Small.of_list [("a", t_int) ; ("b", t_int)] in
assign_variable "output" @@ apply_int (type_closure_int env @@ var "f") (var_int "input") ;
] in
let test n =
let%bind output = run_int program n in
let%bind _ = Assert.assert_equal_int 186 output in
ok () in
let%bind _assert = bind_list @@ List.map test [42 ; 150 ; 0 ; -42] in
ok ()
let main = "Mini_c", [
test "basic.neg" neg ;
test "basic.variables" multiple_variables ;
test "basic.arithmetic" arithmetic ;
test "basic.quote" quote_ ;
test "basic.function" function_ ;
test "basic.functions" functions_ ;
test "basic.rich_function" rich_function ;
]
end
module Ligo = struct
let run (source:string) (input:Ligo.Typed.O.value) : Ligo.Typed.Value.value result =
parse_file source >>? fun program_ast ->
Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program ->
Ligo.Run.run typed_program input >>? fun output ->
ok output
let assert_value_int : Ligo.Typed.Value.value -> int result = function
| `Constant (`Int n) -> ok n
| _ -> simple_fail "not an int"
let basic () : unit result =
run "./contracts/toto.ligo" (Ligo.Typed.Value.int 42) >>? fun output ->
assert_value_int output >>? fun output ->
Assert.assert_equal_int 42 output >>? fun () ->
ok ()
let display_basic () : unit result =
parse_file "./contracts/toto.ligo" >>? fun program_ast ->
Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program ->
Ligo.Transpile.program_to_michelson typed_program >>? fun node ->
let node = Tezos_utils.Cast.flatten_node node in
let str = Tezos_utils.Cast.node_to_string node in
Format.printf "Program:\n%s\n%!" str ;
ok ()
let main = "Ligo", [
test "basic" basic ;
test "basic.display" display_basic ;
]
end
let () =
(* Printexc.record_backtrace true ; *)

138
src/ligo/type_ast.ml Normal file
View File

@ -0,0 +1,138 @@
open Ligo_helpers.Trace
module I = Ast_simplified
module O = Ast_typed
module SMap = O.SMap
module Environment = struct
type t = unit
let empty : t = ()
let get (():t) (_s:string) : O.type_value option = None
let add (():t) (_s:string) (_tv:O.type_value) : t = ()
let get_type (():t) (_s:string) : O.type_value option = None
let add_type (():t) (_s:string) (_tv:O.type_value) : t = ()
end
type environment = Environment.t
type environment = unit
let empty : environment = ()
let rec type_program (p:I.program) : O.program result =
let aux (e, acc:(environment * O.declaration list)) (d:I.declaration) =
let%bind (e', d') = type_declaration e d in
match d' with
| None -> ok (e', acc)
| Some d' -> ok (e', d' :: acc)
in
let%bind (_, lst) = bind_fold_list aux (empty, []) p in
ok @@ List.rev lst
and type_declaration _env : I.declaration -> (environment * O.declaration option) result = function
| Type_declaration _ -> simple_fail ""
| Constant_declaration _ -> simple_fail ""
and type_block (e:environment) (b:I.block) : O.block result =
let aux (e, acc:(environment * O.instruction list)) (i:I.instruction) =
let%bind (e', i') = type_instruction e i in
ok (e', i' :: acc)
in
let%bind (_, lst) = bind_fold_list aux (e, []) b in
ok @@ List.rev lst
and type_instruction (e:environment) : I.instruction -> (environment * O.instruction) result = function
| Skip -> ok (e, O.Skip)
| Fail x ->
let%bind expression = type_annotated_expression e x in
ok (e, O.Fail expression)
| Loop (cond, body) ->
let%bind cond = type_annotated_expression e cond in
let%bind _ =
O.type_value_eq (cond.type_annotation, (O.Type_constant ("bool", []))) in
let%bind body = type_block e body in
ok (e, O.Loop (cond, body))
| Assignment {name;annotated_expression} -> (
match annotated_expression.type_annotation, Environment.get e name with
| None, None -> simple_fail "Initial assignments need type"
| Some _, None ->
let%bind annotated_expression = type_annotated_expression e annotated_expression in
let e' = Environment.add e name annotated_expression.type_annotation in
ok (e', O.Assignment {name;annotated_expression})
| None, Some prev ->
let%bind annotated_expression = type_annotated_expression e annotated_expression in
let e' = Environment.add e name annotated_expression.type_annotation in
let%bind _ =
O.type_value_eq (annotated_expression.type_annotation, prev) in
ok (e', O.Assignment {name;annotated_expression})
| Some _, Some prev ->
let%bind annotated_expression = type_annotated_expression e annotated_expression in
let%bind _assert = trace (simple_error "Annotation doesn't match environment")
@@ O.type_value_eq (annotated_expression.type_annotation, prev) in
let e' = Environment.add e name annotated_expression.type_annotation in
ok (e', O.Assignment {name;annotated_expression})
)
| Matching m ->
let%bind m' = type_match e m in
ok (e, O.Matching m')
and type_match (e:environment) : I.matching -> O.matching result = function
| Match_bool {match_true ; match_false} ->
let%bind match_true = type_block e match_true in
let%bind match_false = type_block e match_false in
ok (O.Match_bool {match_true ; match_false})
| Match_option {match_none ; match_some} ->
let%bind match_none = type_block e match_none in
let (n, b) = match_some in
let%bind b' = type_block e b in
ok (O.Match_option {match_none ; match_some = (n, b')})
| Match_list {match_nil ; match_cons} ->
let%bind match_nil = type_block e match_nil in
let (n, m, b) = match_cons in
let%bind b' = type_block e b in
ok (O.Match_list {match_nil ; match_cons = (n, m, b')})
| Match_tuple lst ->
let aux (x, y) =
let%bind y = type_block e y in
ok (x, y) in
let%bind lst' = bind_list @@ List.map aux lst in
ok (O.Match_tuple lst')
and evaluate_type (e:environment) : I.type_expression -> O.type_value result = function
| Type_tuple lst ->
let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in
ok (O.Type_tuple lst')
| Type_sum m ->
let aux k v prev =
let%bind prev' = prev in
let%bind v' = evaluate_type e v in
ok @@ SMap.add k v' prev'
in
let%bind m = SMap.fold aux m (ok SMap.empty) in
ok (O.Type_sum m)
| Type_record m ->
let aux k v prev =
let%bind prev' = prev in
let%bind v' = evaluate_type e v in
ok @@ SMap.add k v' prev'
in
let%bind m = SMap.fold aux m (ok SMap.empty) in
ok (O.Type_record m)
| Type_variable name ->
let%bind tv =
trace_option (simple_error "unbound type variable")
@@ Environment.get_type e name in
ok tv
| Type_constant (cst, lst) ->
let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in
ok (O.Type_constant(cst, lst'))
and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.annotated_expression result =
match ae.expression with
| Variable name ->
let%bind tv' =
trace_option (simple_error "var not in env")
@@ Environment.get e name in
ok O.{expression = Variable name ; type_annotation = tv'}
| _ -> simple_fail "default"