|
| 1 | +(* |
| 2 | + Copyright 2023 Microsoft Research |
| 3 | +
|
| 4 | + Licensed under the Apache License, Version 2.0 (the "License"); |
| 5 | + you may not use this file except in compliance with the License. |
| 6 | + You may obtain a copy of the License at |
| 7 | +
|
| 8 | + http://www.apache.org/licenses/LICENSE-2.0 |
| 9 | +
|
| 10 | + Unless required by applicable law or agreed to in writing, software |
| 11 | + distributed under the License is distributed on an "AS IS" BASIS, |
| 12 | + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. |
| 13 | + See the License for the specific language governing permissions and |
| 14 | + limitations under the License. |
| 15 | +*) |
| 16 | + |
| 17 | +module PulseSyntaxExtension.Printing |
| 18 | + |
| 19 | +open FStarC |
| 20 | +open FStarC.Effect |
| 21 | + |
| 22 | +module SW = PulseSyntaxExtension.SyntaxWrapper |
| 23 | +module A = FStarC.Parser.AST |
| 24 | +module S = FStarC.Syntax.Syntax |
| 25 | +module U = FStarC.Syntax.Util |
| 26 | +module SS = FStarC.Syntax.Subst |
| 27 | +module DsEnv = FStarC.Syntax.DsEnv |
| 28 | + |
| 29 | +open FStarC.Syntax.Syntax |
| 30 | +open FStarC.Syntax.Resugar |
| 31 | +open FStarC.Class.Show |
| 32 | +open FStarC.Class.PP |
| 33 | +open PulseSyntaxExtension.Env |
| 34 | +open FStarC.Pprint |
| 35 | + |
| 36 | +let hua (t:term) : option (S.fv & list S.universe & S.args) = |
| 37 | + let t = U.unmeta t in |
| 38 | + let hd, args = U.head_and_args_full t in |
| 39 | + let hd = U.unmeta hd in |
| 40 | + match (SS.compress hd).n with |
| 41 | + | Tm_fvar fv -> Some (fv, [], args) |
| 42 | + | Tm_uinst ({ n = Tm_fvar fv }, us) -> Some (fv, us, args) |
| 43 | + | _ -> None |
| 44 | + |
| 45 | +let p = FStarC.Parser.ToDocument.term_to_document |
| 46 | + |
| 47 | +let vconcat (ds:list document) : document = |
| 48 | + match ds with |
| 49 | + | h::t -> |
| 50 | + List.fold_left (fun l r -> if r = empty then l else l ^^ hardline ^^ r) h t |
| 51 | + | [] -> |
| 52 | + empty |
| 53 | + |
| 54 | +let print_pulse_computation_type |
| 55 | + (rng : Range.t) |
| 56 | + (e : DsEnv.env) |
| 57 | + (tag : string) |
| 58 | + (a opens pre post : term) |
| 59 | + : A.term |
| 60 | + = |
| 61 | + let retname_opt, post = |
| 62 | + match U.abs_formals post with |
| 63 | + | [b], t, _ -> |
| 64 | + let bv = b.binder_bv in |
| 65 | + if FStarC.Class.Setlike.mem bv (Syntax.Free.names t) then |
| 66 | + Some b.binder_bv, t |
| 67 | + else |
| 68 | + None, t |
| 69 | + | _ -> |
| 70 | + // If it returns unit, just apply the post to `()` |
| 71 | + if U.term_eq a S.t_unit then |
| 72 | + None, U.mk_app post [S.as_arg U.exp_unit] |
| 73 | + else |
| 74 | + let x = S.gen_bv "_ret" (Some rng) a in |
| 75 | + Some x, U.mk_app post [S.as_arg (S.bv_to_name x)] |
| 76 | + in |
| 77 | + let d = |
| 78 | + align <| hang 2 <| vconcat <| List.map (fun d -> group (hang 2 d)) [ |
| 79 | + (if tag <> "" |
| 80 | + then doc_of_string tag ^/^ doc_of_string "fn" |
| 81 | + else doc_of_string "fn"); |
| 82 | + doc_of_string "requires" ^/^ p (resugar_term' e pre); |
| 83 | + (if U.term_eq opens SW.tm_emp_inames then empty |
| 84 | + else |
| 85 | + (doc_of_string "opens" ^/^ p (resugar_term' e opens))); |
| 86 | + (match retname_opt with |
| 87 | + | None when U.term_eq a S.t_unit -> empty |
| 88 | + | None -> |
| 89 | + doc_of_string "returns" ^/^ p (resugar_term' e a) |
| 90 | + | Some bv -> |
| 91 | + doc_of_string "returns" ^/^ pp bv.ppname ^/^ colon ^/^ p (resugar_term' e a)); |
| 92 | + doc_of_string "ensures" ^/^ p (resugar_term' e post); |
| 93 | + ] |
| 94 | + in |
| 95 | + A.mk_term (A.LitDoc d) rng A.Expr |
| 96 | + |
| 97 | +let resugar_pulse_type (e:DsEnv.env) (t:S.term) : A.term = |
| 98 | + let r = hua t in |
| 99 | + if None? r then raise SkipResugar; |
| 100 | + let Some (fv, us, args) = r in |
| 101 | + let tag, a, opens, pre, post = |
| 102 | + match args with |
| 103 | + | [(a, None); (pre, None); (post, None)] |
| 104 | + when S.fv_eq_lid fv stt_lid -> |
| 105 | + ("", a, SW.tm_emp_inames, pre, post) |
| 106 | + |
| 107 | + | [(a, None); _obs; (opens, None); (pre, None); (post, None)] |
| 108 | + when S.fv_eq_lid fv stt_atomic_lid -> |
| 109 | + ("atomic", a, opens, pre, post) |
| 110 | + |
| 111 | + | [(a, None); (opens, None); (pre, None); (post, None)] |
| 112 | + when S.fv_eq_lid fv stt_ghost_lid -> |
| 113 | + ("ghost", a, opens, pre, post) |
| 114 | + |
| 115 | + | _ -> raise SkipResugar |
| 116 | + in |
| 117 | + print_pulse_computation_type (pos t) e tag a opens pre post |
| 118 | + |
| 119 | +let _ = register_pass resugar_pulse_type |
0 commit comments