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

Michelson: Quick and Dirty Emacs mode.

Browse Source
This commit is contained in:
Benjamin Canou 2017-07-22 00:37:33 +02:00
parent d083add61f
commit 6e215b7d3b
7 changed files with 617 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

379
emacs/michelson-mode.el Normal file
View File

@ -0,0 +1,379 @@
;; Major mode for editing Michelson smart contracts.
(defvar michelson-mode-hook nil)
(defgroup michelson nil
"Major mode for editing Michelson smart contracts."
:prefix "michelson-"
:group 'languages)
(defgroup michelson-options nil
"General options for Michelson mode."
:prefix "michelson-"
:group 'michelson)
(defcustom michelson-mode-client-command "tezos-client"
"Path to the `tezos-client' binary."
:type 'string
:group 'michelson-options)
(defgroup michelson-faces nil
"Font lock faces for Michelson mode."
:prefix "michelson-"
:group 'michelson
:group 'faces)
(defvar michelson-face-instruction
'michelson-face-instruction
"Face name for Michelson instructions.")
(defface michelson-face-instruction
'((t (:inherit 'font-lock-keyword-face)))
"Face for Michelson instructions."
:group 'michelson-faces)
(defvar michelson-face-type
'michelson-face-type
"Face name for Michelson types.")
(defface michelson-face-type
'((t (:inherit 'font-lock-type-face)))
"Face for Michelson types."
:group 'michelson-faces)
(defvar michelson-face-constant
'michelson-face-constant
"Face name for Michelson constants.")
(defface michelson-face-constant
'((t (:inherit 'font-lock-constant-face)))
"Face for Michelson constants."
:group 'michelson-faces)
(defvar michelson-face-instruction
'michelson-face-instruction
"Face name for Michelson instructions.")
(defface michelson-face-annotation
'((t (:inherit 'font-lock-string-face)))
"Face for Michelson annotations."
:group 'michelson-faces)
(defvar michelson-face-comment
'michelson-face-comment
"Face name for Michelson comments.")
(defface michelson-face-comment
'((t (:inherit 'font-lock-comment-face)))
"Face for Michelson comments."
:group 'michelson-faces)
(defvar michelson-face-error
'michelson-face-error
"Face name for Michelson comments.")
(defface michelson-face-error
'(( ((class color) (background light)) (:background "MistyRose") )
( ((class color) (background dark)) (:background "DarkRed") ))
"Face for Michelson annotations."
:group 'michelson-faces)
(defun michelson-customize-options ()
"Open the general customization group for Michelson mode."
(interactive)
(customize-group-other-window `michelson-options))
(defun michelson-customize-faces ()
"Open the face customization group for Michelson mode."
(interactive)
(customize-group-other-window `michelson-faces))
(defconst michelson-mode-map
(let ((michelson-mode-map (make-sparse-keymap)))
;; menu
(define-key michelson-mode-map
[menu-bar michelson-menu]
(cons "Michelson" (make-sparse-keymap "michelson-menu")))
(define-key michelson-mode-map
[menu-bar michelson-menu faces]
(cons "Display options group" 'michelson-customize-faces))
(define-key michelson-mode-map
[menu-bar michelson-menu options]
(cons "General options group" 'michelson-customize-options))
(define-key michelson-mode-map
[menu-bar michelson-menu separator]
'(menu-item "--"))
(define-key michelson-mode-map
[menu-bar michelson-menu what]
(cons "What's under the cursor?" 'michelson-type-at-point))
;; keys
(define-key michelson-mode-map
(kbd "C-j") 'newline-and-indent)
(define-key michelson-mode-map
(kbd "TAB") 'indent-for-tab-command)
(define-key michelson-mode-map
(kbd "<f1>") 'michelson-type-at-point)
michelson-mode-map))
(defun michelson-font-lock-syntactic-face-function (s)
(cond ((nth 3 s) 'font-lock-constant-face)
(t 'michelson-face-comment)))
(defconst michelson-font-lock-defaults
(list
(list
'("\\<[0-9]+\\>" . michelson-face-constant)
'("\\<[A-Z][a-z_0-9]+\\>" . michelson-face-constant)
'("\\<[A-Z][A-Z_0-9]*\\>" . michelson-face-instruction)
'("\\<\$[A-Za-z-_0-9]*\\>" . michelson-face-annotation)
'("\\<[a-z][a-z_0-9]*\\>" . michelson-face-type))
nil nil nil nil
'(font-lock-syntactic-face-function . michelson-font-lock-syntactic-face-function)))
(defconst michelson-mode-syntax-table
(let ((michelson-mode-syntax-table (make-syntax-table)))
(modify-syntax-entry ?_ "w" michelson-mode-syntax-table)
(modify-syntax-entry ?/ ". 1n4" michelson-mode-syntax-table)
(modify-syntax-entry ?* ". 23" michelson-mode-syntax-table)
(modify-syntax-entry ?# "<b" michelson-mode-syntax-table)
(modify-syntax-entry ?\n ">b" michelson-mode-syntax-table)
michelson-mode-syntax-table))
(defun in-space ()
(or (looking-at "[[:space:]\n]")
(equal (get-text-property (point) 'face)
'michelson-face-comment)))
(defun michelson-goto-previous-token ()
(interactive)
(if (bobp)
(cons 0 nil)
(progn
(backward-char 1)
(while (and (not (bobp)) (in-space)) (backward-char 1))
(let ((token-face (get-text-property (point) 'face)))
(forward-char 1)
(let ((end-of-token (point)))
(backward-char 1)
(unless (looking-at "[{()};]")
(while (and (not (bobp))
(equal (get-text-property (point) 'face) token-face))
(backward-char 1))
(when (not (equal (get-text-property (point) 'face) token-face))
(forward-char 1)))
(cons (point) (buffer-substring-no-properties (point) end-of-token)))))))
(defun michelson-goto-next-token ()
(interactive)
(if (eobp)
(cons (point) nil)
(progn
(while (and (not (eobp)) (in-space)) (forward-char 1))
(let ((token-face (get-text-property (point) 'face)))
(let ((start-of-token (point)))
(if (looking-at "[{()};]")
(forward-char 1)
(progn
(while (and (not (eobp))
(equal (get-text-property (point) 'face) token-face))
(forward-char 1))))
(cons start-of-token (buffer-substring-no-properties start-of-token (point))))))))
(defun michelson-goto-opener ()
(interactive)
(let ((paren-level 0))
(while (and (not (bobp))
(or (> paren-level 0)
(not (looking-at "[{(]"))))
(cond ((looking-at "[{(]")
(setq paren-level (- paren-level 1)))
((looking-at "[})]")
(setq paren-level (+ paren-level 1))))
(michelson-goto-previous-token))
(cons (point)
(when (looking-at "[{(]")
(buffer-substring-no-properties (point) (+ (point) 1))))))
(defun michelson-goto-closer ()
(interactive)
(let ((paren-level 0) (last-token ""))
(while (and (not (eobp))
(or (> paren-level 0)
(not (string-match "[)}]" last-token))))
(cond ((looking-at "[{(]")
(setq paren-level (+ paren-level 1)))
((looking-at "[})]")
(setq paren-level (- paren-level 1))))
(setq last-token (cdr (michelson-goto-next-token))))
(cons (point)
(when (looking-at "[)}]")
(buffer-substring-no-properties (point) (+ (point) 1))))))
(defun michelson-goto-previous-application-start ()
(interactive)
(let ((paren-level 0) (application-start 0))
(while (and (not (bobp))
(or (> paren-level 0)
(not (looking-at "[{(;]"))))
(cond ((looking-at "[{(]")
(setq paren-level (- paren-level 1)))
((looking-at "[})]")
(setq paren-level (+ paren-level 1))))
(setq application-start (point))
(michelson-goto-previous-token))
(cons application-start (goto-char application-start))))
(defun michelson-indent ()
"Indent current line of Michelson code."
(interactive)
(let ((new-indentation 0)
(previous-indentation (current-indentation))
(previous-column (current-column))
(current-token
(save-excursion
(beginning-of-line 1)
(michelson-goto-next-token))))
(save-excursion
(end-of-line 0)
(let ((previous-token
(save-excursion (michelson-goto-previous-token)))
(previous-opener
(save-excursion (michelson-goto-opener))))
(cond ((and (not (cdr previous-opener))
(not (cdr previous-token)))
(setq new-indentation 0))
((and (not (cdr previous-opener))
(equal (cdr previous-token) ";"))
(setq new-indentation 0))
((not (cdr previous-opener))
(setq new-indentation 2))
((and (equal (cdr current-token) "}")
(equal (cdr previous-opener) "{"))
(goto-char (car previous-opener))
(setq new-indentation (current-column)))
((and (or (equal (cdr previous-token) ";")
(equal (cdr previous-token) "{"))
(equal (cdr previous-opener) "{"))
(goto-char (car previous-opener))
(setq new-indentation (+ (current-column) 2)))
((equal (cdr previous-opener) "{")
(progn
(michelson-goto-previous-application-start)
(let ((default-param-indentation
(+ (current-column) 2))
(first-param-point
(save-excursion
(michelson-goto-next-token)
(car (michelson-goto-next-token)))))
(if (= first-param-point (car current-token))
(setq new-indentation default-param-indentation)
(progn
(goto-char first-param-point)
(setq new-indentation (current-column)))))))
((and (equal (cdr current-token) ")")
(equal (cdr previous-opener) "("))
(goto-char (car previous-opener))
(setq new-indentation (current-column)))
((equal (cdr previous-token) "(")
(goto-char (car previous-token))
(setq new-indentation (+ (current-column) 1)))
((equal (cdr previous-opener) "(")
(goto-char (car previous-opener))
(setq new-indentation (+ (current-column) 3))))))
(indent-line-to new-indentation)
(beginning-of-line)
(forward-char
(+ (- previous-column previous-indentation) new-indentation))
(when (< (current-column) new-indentation)
(beginning-of-line)
(forward-char new-indentation))))
(defun michelson-token-at-point ()
"Display the token closest to the cursor."
(interactive)
(let ((message
(cdr (save-excursion
(michelson-goto-next-token)
(michelson-goto-previous-token)))))
(display-message-or-buffer message "*Michelson*")))
(defun michelson-type-at-point ()
"Display the type of the expression under the cursor."
(interactive)
(let ((tmp-file (concat buffer-file-name ".emacs")))
(write-region (point-min) (point-max) tmp-file nil 'no-message)
(let* ((stdout
(shell-command-to-string
(concat
michelson-mode-client-command
" typecheck program "
tmp-file
" -details -emacs")))
(record
(car (read-from-string stdout)))
(errors
(cdr (assoc 'errors record)))
(types
(cdr (assoc 'types record)))
(message ""))
(delete-file tmp-file)
(remove-overlays)
(setq message "")
(dolist (elt types)
(if (and (<= (car elt) (point)) (<= (point) (cadr elt))
(equal (get-text-property (point) 'face)
'michelson-face-instruction))
(setq message (cadr (cdr elt)))))
(dolist (elt errors)
(overlay-put (make-overlay (car elt) (cadr elt)) 'face 'michelson-face-error)
(if (and (<= (car elt) (point)) (<= (point) (cadr elt)))
(progn
(if (string= "" message)
nil
(setq message (concat message "\n")))
(setq message (concat message (cadr (cdr elt)))))))
(display-message-or-buffer message "*Michelson*"))))
(defun michelson-update-minibuffer-info ()
(when (nth 2 michelson-state) (cancel-timer (nth 2 michelson-state)))
(setf
(nth 2 michelson-state)
(run-at-time
"0.3 sec" nil
(lambda (buffer)
(with-current-buffer buffer
(setf (nth 2 michelson-state) nil)
(when (not (= (nth 0 michelson-state) (point)))
(setf (nth 0 michelson-state) (point))
(michelson-type-at-point))))
(current-buffer))))
(define-derived-mode michelson-mode prog-mode "Michelson"
"Major mode for editing Michelson smart contracts."
(interactive)
(kill-all-local-variables)
(use-local-map michelson-mode-map)
(set-syntax-table michelson-mode-syntax-table)
(set
(make-local-variable 'font-lock-defaults)
michelson-font-lock-defaults)
(set
(make-local-variable 'indent-line-function)
'michelson-indent)
(set
(make-local-variable 'indent-for-tab-command)
'michelson-indent)
(set
(make-local-variable 'michelson-state)
(list 0 0 nil))
(add-to-list
(make-local-variable 'pre-command-hook)
'michelson-update-minibuffer-info)
(add-to-list
(make-local-variable 'focus-in-hook)
'michelson-update-minibuffer-info)
(setq major-mode 'michelson-mode)
(setq mode-name "Michelson")
(setq indent-tabs-mode nil)
(setq show-trailing-whitespace t)
(setq buffer-file-coding-system 'utf-8-unix)
(run-hooks 'michelson-mode-hook))
(add-to-list 'auto-mode-alist '("\\.tz\\'" . michelson-mode))
(add-to-list 'auto-mode-alist '("\\.tez\\'" . michelson-mode))
(provide 'michelson-mode)

6
src/client/embedded/alpha/client_proto_context.ml
View File

@ -45,7 +45,7 @@ let transfer rpc_config
begin match arg with
| Some arg ->
Client_proto_programs.parse_data arg >>=? fun arg ->
return (Some arg)
return (Some arg.ast)
| None -> return None
end >>=? fun parameters ->
Client_proto_rpcs.Context.Contract.counter
@ -105,7 +105,7 @@ let originate_contract rpc_config
~source ~src_pk ~src_sk ~manager_pkh ~balance ?delegatable ?delegatePubKey
~(code:Script.code) ~init ~fee () =
Client_proto_programs.parse_data init >>=? fun storage ->
let storage = Script.{ storage ; storage_type = code.storage_type } in
let storage = Script.{ storage=storage.ast ; storage_type = code.storage_type } in
Client_proto_rpcs.Context.Contract.counter
rpc_config block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in
@ -357,7 +357,7 @@ let commands () =
~name:"prg" ~desc: "script of the account\n\
combine with -init if the storage type is not unit"
@@ stop
end begin fun neu (_, manager) balance (_, source) code cctxt ->
end begin fun neu (_, manager) balance (_, source) { ast = code } cctxt ->
check_contract cctxt neu >>=? fun () ->
get_delegate_pkh cctxt !delegate >>=? fun delegate ->
get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->

274
src/client/embedded/alpha/client_proto_programs.ml
View File

@ -13,20 +13,20 @@ open Client_proto_args
let report_parse_error _prefix exn _lexbuf =
let open Lexing in
let open Script_located_ir in
let print_loc ppf ((sl, sc), (el, ec)) =
if sl = el then
if sc = ec then
Format.fprintf ppf
"at line %d character %d"
sl sc
let print_loc ppf (s, e) =
if s.line = e.line then
if s.column = e.column then
Format.fprintf ppf
"at line %d character %d"
s.line s.column
else
Format.fprintf ppf
"at line %d characters %d to %d"
sl sc ec
Format.fprintf ppf
"at line %d characters %d to %d"
s.line s.column e.column
else
Format.fprintf ppf
"from line %d character %d to line %d character %d"
sl sc el ec in
s.line s.column e.line e.column in
match exn with
| Missing_program_field n ->
failwith "missing script %s" n
@ -83,15 +83,16 @@ and print_expr locations ppf = function
Format.fprintf ppf "(%a)" (print_expr_unwrapped locations) expr
| expr -> print_expr_unwrapped locations ppf expr
let print_stack ppf = function
| [] -> Format.fprintf ppf "[]"
| more ->
Format.fprintf ppf "@[<hov 2>[ %a ]@]"
(Format.pp_print_list
~pp_sep: (fun ppf () -> Format.fprintf ppf " :@ ")
(print_expr_unwrapped no_locations))
more
let print_typed_code locations ppf (expr, type_map) =
let print_stack ppf = function
| [] -> Format.fprintf ppf "[]"
| more ->
Format.fprintf ppf "@[<hov 2>[ %a ]@]"
(Format.pp_print_list
~pp_sep: (fun ppf () -> Format.fprintf ppf " :@ ")
(print_expr_unwrapped no_locations))
more in
let rec print_typed_code_unwrapped ppf expr =
match expr with
| Script.Prim (loc, name, []) ->
@ -178,6 +179,34 @@ let print_program locations ppf ((c : Script.code), type_map) =
(print_expr no_locations) c.ret_type
(print_typed_code locations) (c.code, type_map)
let collect_error_locations errs =
let open Script_typed_ir in
let open Script_ir_translator in
let rec collect acc = function
| (Ill_typed_data (_, _, _)
| Ill_formed_type (_, _)
| Ill_typed_contract (_, _, _, _, _)) :: _
| [] -> acc
| (Invalid_arity (loc, _, _, _)
| Invalid_namespace (loc, _, _, _)
| Invalid_primitive (loc, _, _)
| Invalid_case (loc, _)
| Invalid_kind (loc, _, _)
| Fail_not_in_tail_position loc
| Undefined_cast (loc, _, _)
| Undefined_binop (loc, _, _, _)
| Undefined_unop (loc, _, _)
| Bad_return (loc, _, _)
| Bad_stack (loc, _, _, _)
| Unmatched_branches (loc, _, _)
| Transfer_in_lambda loc
| Invalid_constant (loc, _, _)
| Invalid_contract (loc, _)
| Comparable_type_expected (loc, _)) :: rest ->
collect (loc :: acc) rest
| _ :: rest -> collect acc rest in
collect [] errs
let report_typechecking_errors ?show_types cctxt errs =
let open Client_commands in
let open Script_typed_ir in
@ -214,38 +243,6 @@ let report_typechecking_errors ?show_types cctxt errs =
Format.fprintf ppf "%a,@ %a"
Format.pp_print_text first print_enumeration rest
| [] -> assert false in
let rec collect_locations acc = function
| (Ill_typed_data (_, _, _)
| Ill_formed_type (_, _)
| Ill_typed_contract (_, _, _, _, _)) :: _
| [] ->
let assoc, _ =
List.fold_left
(fun (acc, i) l ->
if List.mem_assoc l acc then
(acc, i)
else
((l, i) :: acc, i + 1))
([], 1) acc in
(fun l -> try Some (List.assoc l assoc) with Not_found -> None)
| (Invalid_arity (loc, _, _, _)
| Invalid_namespace (loc, _, _, _)
| Invalid_primitive (loc, _, _)
| Invalid_case (loc, _)
| Invalid_kind (loc, _, _)
| Fail_not_in_tail_position loc
| Undefined_cast (loc, _, _)
| Undefined_binop (loc, _, _, _)
| Undefined_unop (loc, _, _)
| Bad_return (loc, _, _)
| Bad_stack (loc, _, _, _)
| Unmatched_branches (loc, _, _)
| Transfer_in_lambda loc
| Invalid_constant (loc, _, _)
| Invalid_contract (loc, _)
| Comparable_type_expected (loc, _)) :: rest ->
collect_locations (loc :: acc) rest
| _ :: rest -> collect_locations acc rest in
let print_typechecking_error locations err =
let print_loc ppf loc =
match locations loc with
@ -424,7 +421,17 @@ let report_typechecking_errors ?show_types cctxt errs =
| (Ill_typed_data (_, _, _)
| Ill_formed_type (_, _)
| Ill_typed_contract (_, _, _, _, _)) :: rest ->
collect_locations [] rest
let collected =
collect_error_locations rest in
let assoc, _ =
List.fold_left
(fun (acc, i) l ->
if List.mem_assoc l acc then
(acc, i)
else
((l, i) :: acc, i + 1))
([], 1) collected in
(fun l -> try Some (List.assoc l assoc) with Not_found -> None)
| _ -> locations in
match errs with
| [] -> Lwt.return ()
@ -438,38 +445,58 @@ let report_typechecking_errors ?show_types cctxt errs =
| err -> cctxt.warning "%a" pp_print_error [ err ])
errs
let parse_program s =
let lexbuf = Lexing.from_string s in
type 'a parsed =
{ ast : 'a ;
source : string ;
loc_table : (string * (int * Script_located_ir.location) list) list }
let parse_program source =
let lexbuf = Lexing.from_string source in
try
return
(Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf |>
List.map Script_located_ir.strip_locations |> fun fields ->
(Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf |> fun fields ->
let rec get_field n = function
| Script.Prim (_, pn, [ ctns ]) :: _ when n = pn -> ctns
| Script_located_ir.Prim (_, pn, [ ctns ]) :: _ when n = pn -> ctns
| _ :: rest -> get_field n rest
| [] -> raise (Script_located_ir.Missing_program_field n) in
Script.{ code = get_field "code" fields ;
arg_type = get_field "parameter" fields ;
ret_type = get_field "return" fields ;
storage_type = get_field "storage" fields }
)
let code, code_loc_table =
Script_located_ir.strip_locations (get_field "code" fields) in
let arg_type, parameter_loc_table =
Script_located_ir.strip_locations (get_field "parameter" fields) in
let ret_type, return_loc_table =
Script_located_ir.strip_locations (get_field "return" fields) in
let storage_type, storage_loc_table =
Script_located_ir.strip_locations (get_field "storage" fields) in
let ast = Script.{ code ; arg_type ; ret_type ; storage_type } in
let loc_table =
[ "code", code_loc_table ;
"parameter", parameter_loc_table ;
"return", return_loc_table ;
"storage", storage_loc_table ] in
{ ast ; source ; loc_table })
with
| exn -> report_parse_error "program: " exn lexbuf
let parse_data s =
let lexbuf = Lexing.from_string s in
let parse_data source =
let lexbuf = Lexing.from_string source in
try
match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with
| [node] -> return (Script_located_ir.strip_locations node)
| [node] ->
let ast, loc_table = Script_located_ir.strip_locations node in
let loc_table = [ "data", loc_table ] in
return { ast ; source ; loc_table }
| _ -> failwith "single data expression expected"
with
| exn -> report_parse_error "data: " exn lexbuf
let parse_data_type s =
let lexbuf = Lexing.from_string s in
let parse_data_type source =
let lexbuf = Lexing.from_string source in
try
match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with
| [node] -> return (Script_located_ir.strip_locations node)
| [node] ->
let ast, loc_table = Script_located_ir.strip_locations node in
let loc_table = [ "data", loc_table ] in
return { ast ; source ; loc_table }
| _ -> failwith "single type expression expected"
with
| exn -> report_parse_error "data_type: " exn lexbuf
@ -514,11 +541,20 @@ let unexpand_macros type_map (program : Script.code) =
type_map, { program with code }
module Program = Client_aliases.Alias (struct
type t = Script.code
let encoding = Script.code_encoding
type t = Script.code parsed
let encoding =
let open Data_encoding in
let loc_table_encoding =
assoc (list (tup2 uint16 Script_located_ir.location_encoding)) in
conv
(fun { ast ; source ; loc_table } -> (ast, source, loc_table))
(fun (ast, source, loc_table) -> { ast ; source ; loc_table })
(obj3
(req "ast" Script.code_encoding)
(req "source" string)
(req "loc_table" loc_table_encoding))
let of_source _cctxt s = parse_program s
let to_source _ p =
return (Format.asprintf "%a" (print_program no_locations) (p, []))
let to_source _ { source } = return source
let name = "program"
end)
@ -533,6 +569,11 @@ let commands () =
"-details",
Arg.Set show_types,
"Show the types of each instruction" in
let emacs_mode = ref false in
let emacs_mode_arg =
"-emacs",
Arg.Set emacs_mode,
"Output in michelson-mode.el compatible format" in
let trace_stack = ref false in
let trace_stack_arg =
"-trace-stack",
@ -589,7 +630,7 @@ let commands () =
let open Data_encoding in
if !trace_stack then
Client_proto_rpcs.Helpers.trace_code cctxt.rpc_config
cctxt.config.block program (storage, input, !amount) >>= function
cctxt.config.block program.ast (storage.ast, input.ast, !amount) >>= function
| Ok (storage, output, trace) ->
cctxt.message
"@[<v 0>@[<v 2>storage@,%a@]@,\
@ -600,7 +641,7 @@ let commands () =
(fun ppf (loc, gas, stack) ->
Format.fprintf ppf
"- @[<v 0>location: %d (remaining gas: %d)@,\
[ @[<v 0>%a ]@]@]"
[ @[<v 0>%a ]@]@]"
loc gas
(Format.pp_print_list (print_expr no_locations))
stack))
@ -612,7 +653,7 @@ let commands () =
return ()
else
Client_proto_rpcs.Helpers.run_code cctxt.rpc_config
cctxt.config.block program (storage, input, !amount) >>= function
cctxt.config.block program.ast (storage.ast, input.ast, !amount) >>= function
| Ok (storage, output) ->
cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
(print_expr no_locations) storage
@ -624,24 +665,77 @@ let commands () =
return ()) ;
command ~group ~desc: "ask the node to typecheck a program"
~args: [ show_types_arg ]
~args: [ show_types_arg ; emacs_mode_arg ]
(prefixes [ "typecheck" ; "program" ]
@@ Program.source_param
@@ stop)
(fun program cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.typecheck_code cctxt.rpc_config cctxt.config.block program >>= function
| Ok type_map ->
let type_map, program = unexpand_macros type_map program in
cctxt.message "Well typed" >>= fun () ->
if !show_types then
cctxt.message "%a" (print_program no_locations) (program, type_map) >>= fun () ->
return ()
else return ()
| Error errs ->
report_typechecking_errors
?show_types:(if !show_types then Some program else None) cctxt errs >>= fun () ->
failwith "ill-typed program") ;
Client_proto_rpcs.Helpers.typecheck_code
cctxt.rpc_config cctxt.config.block program.ast >>= fun res ->
if !emacs_mode then
let emacs_type_map type_map =
(Utils.filter_map
(fun (n, loc) ->
try
let bef, aft = List.assoc (n + 1) type_map in
Some (loc, bef, aft)
with
Not_found -> None)
(List.assoc "code" program.loc_table),
[]) in
begin match res with
| Ok type_map ->
Lwt.return (emacs_type_map type_map)
| Error errs ->
let msg = Buffer.create 5000 in
let cctxt = Client_commands.make_context
(fun _ t -> Buffer.add_string msg t ; Buffer.add_char msg '\n' ; Lwt.return ()) in
match errs with
| Ecoproto_error (Script_ir_translator.Ill_formed_type
(Some ("return" | "parameter" | "storage" as field), _) :: errs) :: _ ->
report_typechecking_errors cctxt [ Ecoproto_error errs ] >>= fun () ->
Lwt.return ([], [ List.assoc 0 (List.assoc field program.loc_table), Buffer.contents msg ])
| Ecoproto_error (Script_ir_translator.Ill_typed_contract (_, _, _, _, type_map) :: errs) :: _ ->
(report_typechecking_errors cctxt [ Ecoproto_error errs ] >>= fun () ->
let (types, _) = emacs_type_map type_map in
let loc = match collect_error_locations errs with
| hd :: _ -> hd - 1
| [] -> 0 in
Lwt.return (types, [ List.assoc loc (List.assoc "code" program.loc_table), Buffer.contents msg ]))
| _ -> Lwt.return ([], [])
end >>= fun (types, errors) ->
cctxt.message
"(@[<v 0>(types . (@[<v 0>%a@]))@,\
(errors . (@[<v 0>%a@])))@]"
(Format.pp_print_list
(fun ppf (({ Script_located_ir.point = s },
{ Script_located_ir.point = e }),
bef, aft) ->
Format.fprintf ppf "(%d %d \"%s\")" (s + 1) (e + 1)
(Format.asprintf "@[<v 0>%a@, \\u2B87@,%a@]"
print_stack bef print_stack aft)))
types
(Format.pp_print_list
(fun ppf (({ Script_located_ir.point = s },
{ Script_located_ir.point = e }),
err) ->
Format.fprintf ppf "(%d %d %S)" (s + 1) (e + 1) err))
errors >>= fun () ->
return ()
else
match res with
| Ok type_map ->
let type_map, program = unexpand_macros type_map program.ast in
cctxt.message "Well typed" >>= fun () ->
if !show_types then
cctxt.message "%a" (print_program no_locations) (program, type_map) >>= fun () ->
return ()
else return ()
| Error errs ->
report_typechecking_errors
?show_types:(if !show_types then Some program.ast else None) cctxt errs >>= fun () ->
failwith "ill-typed program") ;
command ~group ~desc: "ask the node to typecheck a data expression"
(prefixes [ "typecheck" ; "data" ]
@ -654,7 +748,7 @@ let commands () =
(fun data exp_ty cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.typecheck_data cctxt.Client_commands.rpc_config
cctxt.config.block (data, exp_ty) >>= function
cctxt.config.block (data.ast, exp_ty.ast) >>= function
| Ok () ->
cctxt.message "Well typed" >>= fun () ->
return ()
@ -672,7 +766,7 @@ let commands () =
(fun data cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data cctxt.Client_commands.rpc_config
cctxt.config.block data >>= function
cctxt.config.block (data.ast) >>= function
| Ok hash ->
cctxt.message "%S" hash >>= fun () ->
return ()
@ -694,7 +788,7 @@ let commands () =
(fun data (_, key) cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config
cctxt.config.block data >>= function
cctxt.config.block (data.ast) >>= function
| Ok hash ->
let signature = Ed25519.sign key (MBytes.of_string hash) in
cctxt.message "Hash: %S@.Signature: %S"

13
src/client/embedded/alpha/client_proto_programs.mli
View File

@ -7,10 +7,15 @@
(* *)
(**************************************************************************)
val parse_program: string -> Script.code tzresult Lwt.t
val parse_data: string -> Script.expr tzresult Lwt.t
val parse_data_type: string -> Script.expr tzresult Lwt.t
type 'a parsed =
{ ast : 'a ;
source : string ;
loc_table : (string * (int * Script_located_ir.location) list) list }
module Program : Client_aliases.Alias with type t = Script.code
val parse_program: string -> Script.code parsed tzresult Lwt.t
val parse_data: string -> Script.expr parsed tzresult Lwt.t
val parse_data_type: string -> Script.expr parsed tzresult Lwt.t
module Program : Client_aliases.Alias with type t = Script.code parsed
val commands: unit -> Client_commands.command list

4
src/client/embedded/alpha/concrete_lexer.mll
View File

@ -38,7 +38,9 @@ let curr_location lexbuf =
lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p
let pos pos =
Lexing.(pos.pos_lnum, pos.pos_cnum - pos.pos_bol)
{ line = pos.Lexing.pos_lnum ;
column = pos.Lexing.pos_cnum - pos.Lexing.pos_bol ;
point = pos.Lexing.pos_cnum }
let pos2 (start, stop) =
pos start, pos stop

14
src/client/embedded/alpha/concrete_parser.mly
View File

@ -225,9 +225,13 @@ let expand original =
expand_duuuuup ;
expand_compare ]
let loc = function
| Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _) -> loc
let apply node arg =
match node with
| Prim (loc, n, args) -> Prim (loc, n, args @ [arg])
| Prim ((sloc, _), n, args) ->
Prim ((sloc, snd (loc arg)), n, args @ [arg])
| Int _ | String _ | Seq _ as _node ->
raise (Invalid_application (node_location arg))
@ -236,8 +240,12 @@ let rec apply_seq node = function
| n1 :: n2 -> apply_seq (apply node n1) n2
let pos p1 p2 =
Lexing.((p1.pos_lnum, p1.pos_cnum - p1.pos_bol),
(p2.pos_lnum, p2.pos_cnum - p2.pos_bol))
({ line = p1.Lexing.pos_lnum ;
column = p1.Lexing.pos_cnum - p1.Lexing.pos_bol ;
point = p1.Lexing.pos_cnum },
{ line = p2.Lexing.pos_lnum ;
column = p2.Lexing.pos_cnum - p2.Lexing.pos_bol ;
point = p2.Lexing.pos_cnum })
%}

34
src/client/embedded/alpha/script_located_ir.ml
View File

@ -8,11 +8,27 @@
(**************************************************************************)
type point =
int * int
{ line : int ;
column : int ;
point : int }
type location =
point * point
let location_encoding =
let open Data_encoding in
let point_encoding =
conv
(fun { line ; column ; point } -> (line, column, point))
(fun (line, column, point) -> { line ; column ; point })
(obj3
(req "line" uint16)
(req "column" uint16)
(req "point" uint16)) in
obj2
(req "start" point_encoding)
(req "stop" point_encoding)
type node =
| Int of location * string
| String of location * string
@ -50,15 +66,21 @@ exception Missing_program_field of string
let strip_locations root =
let id = let id = ref (-1) in fun () -> incr id ; !id in
let loc_table = ref [] in
let rec strip_locations l =
let id = id () in
match l with
| Int (_, v) ->
| Int (loc, v) ->
loc_table := (id, loc) :: !loc_table ;
Script.Int (id, v)
| String (_, v) ->
| String (loc, v) ->
loc_table := (id, loc) :: !loc_table ;
Script.String (id, v)
| Seq (_, seq) ->
| Seq (loc, seq) ->
loc_table := (id, loc) :: !loc_table ;
Script.Seq (id, List.map strip_locations seq)
| Prim (_, name, seq) ->
| Prim (loc, name, seq) ->
loc_table := (id, loc) :: !loc_table ;
Script.Prim (id, name, List.map strip_locations seq) in
strip_locations root
let stripped = strip_locations root in
stripped, List.rev !loc_table