diff --git a/src/sail_lean_backend/pretty_print_lean.ml b/src/sail_lean_backend/pretty_print_lean.ml index 21275d883..111ae2ae5 100644 --- a/src/sail_lean_backend/pretty_print_lean.ml +++ b/src/sail_lean_backend/pretty_print_lean.ml @@ -641,27 +641,29 @@ let inhabit_enum ctx typ_map = let doc_reg_info env global registers = let ctx = initial_context env global in - let type_map = List.fold_left add_reg_typ Bindings.empty registers in let type_map = Bindings.bindings type_map in - separate hardline [ register_enums registers; type_enum ctx registers; - string "abbrev SailM := PreSailM RegisterType"; - empty; string "open RegisterRef"; inhabit_enum ctx type_map; empty; - empty; ] + + +let doc_monad_abbrev (has_registers : bool) = + let pp_register_type = if has_registers then string "PreSailM RegisterType" else string "StateM Unit" in + separate space [string "abbrev"; string "SailM"; coloneq; pp_register_type] ^^ hardline ^^ hardline let pp_ast_lean (env : Type_check.env) effect_info ({ defs; _ } as ast : Libsail.Type_check.typed_ast) o = let defs = remove_imports defs 0 in let regs = State.find_registers defs in let global = { effect_info } in - let register_refs = match regs with [] -> empty | _ -> doc_reg_info env global regs in + let has_registers = List.length regs > 0 in + let register_refs = if has_registers then doc_reg_info env global regs else empty in + let monad = doc_monad_abbrev has_registers in let types, fundefs = doc_defs (initial_context env global) defs in - print o (types ^^ register_refs ^^ fundefs); + print o (types ^^ register_refs ^^ monad ^^ fundefs); () diff --git a/test/lean/atom_bool.expected.lean b/test/lean/atom_bool.expected.lean index 1adb1dfae..54a41793d 100644 --- a/test/lean/atom_bool.expected.lean +++ b/test/lean/atom_bool.expected.lean @@ -2,6 +2,8 @@ import Out.Sail.Sail open Sail +abbrev SailM := StateM Unit + def foo : Bool := true diff --git a/test/lean/bitfield.expected.lean b/test/lean/bitfield.expected.lean index ba2722f7b..6cf260284 100644 --- a/test/lean/bitfield.expected.lean +++ b/test/lean/bitfield.expected.lean @@ -12,11 +12,10 @@ open Register abbrev RegisterType : Register → Type | .R => (BitVec 8) -abbrev SailM := PreSailM RegisterType - open RegisterRef instance : Inhabited (RegisterRef RegisterType (BitVec 8)) where default := .Reg R +abbrev SailM := PreSailM RegisterType def undefined_cr_type (lit : Unit) : SailM (BitVec 8) := do sorry diff --git a/test/lean/bitvec_operation.expected.lean b/test/lean/bitvec_operation.expected.lean index 8f1f7ca93..99562465f 100644 --- a/test/lean/bitvec_operation.expected.lean +++ b/test/lean/bitvec_operation.expected.lean @@ -2,6 +2,8 @@ import Out.Sail.Sail open Sail +abbrev SailM := StateM Unit + def bitvector_eq (x : (BitVec 16)) (y : (BitVec 16)) : Bool := (Eq x y) diff --git a/test/lean/enum.expected.lean b/test/lean/enum.expected.lean index a9a1a2a73..a20caa2b4 100644 --- a/test/lean/enum.expected.lean +++ b/test/lean/enum.expected.lean @@ -6,6 +6,8 @@ inductive E where | A | B | C deriving Inhabited open E +abbrev SailM := StateM Unit + def undefined_E : SailM E := do sorry diff --git a/test/lean/extern.expected.lean b/test/lean/extern.expected.lean index a67f1c206..1853706bd 100644 --- a/test/lean/extern.expected.lean +++ b/test/lean/extern.expected.lean @@ -2,6 +2,8 @@ import Out.Sail.Sail open Sail +abbrev SailM := StateM Unit + def extern_add : Int := (Int.add 5 4) diff --git a/test/lean/extern_bitvec.expected.lean b/test/lean/extern_bitvec.expected.lean index af4bdb0f9..9996aadae 100644 --- a/test/lean/extern_bitvec.expected.lean +++ b/test/lean/extern_bitvec.expected.lean @@ -2,6 +2,8 @@ import Out.Sail.Sail open Sail +abbrev SailM := StateM Unit + def extern_const : (BitVec 64) := (0xFFFF000012340000 : (BitVec 64)) diff --git a/test/lean/ite.expected.lean b/test/lean/ite.expected.lean index 92c04557a..ba593375a 100644 --- a/test/lean/ite.expected.lean +++ b/test/lean/ite.expected.lean @@ -12,13 +12,12 @@ abbrev RegisterType : Register → Type | .B => Bool | .R => Nat -abbrev SailM := PreSailM RegisterType - open RegisterRef instance : Inhabited (RegisterRef RegisterType Bool) where default := .Reg B instance : Inhabited (RegisterRef RegisterType Nat) where default := .Reg R +abbrev SailM := PreSailM RegisterType /-- Type quantifiers: n : Int, 0 ≤ n -/ def elif (n : Nat) : (BitVec 1) := diff --git a/test/lean/let.expected.lean b/test/lean/let.expected.lean index b2eb331d0..0669173b7 100644 --- a/test/lean/let.expected.lean +++ b/test/lean/let.expected.lean @@ -2,6 +2,8 @@ import Out.Sail.Sail open Sail +abbrev SailM := StateM Unit + def foo : (BitVec 16) := let z := (HOr.hOr (0xFFFF : (BitVec 16)) (0xABCD : (BitVec 16))) (HAnd.hAnd (0x0000 : (BitVec 16)) z) diff --git a/test/lean/match.expected.lean b/test/lean/match.expected.lean index 7a923c823..5731a6361 100644 --- a/test/lean/match.expected.lean +++ b/test/lean/match.expected.lean @@ -6,6 +6,8 @@ inductive E where | A | B | C deriving Inhabited open E +abbrev SailM := StateM Unit + def undefined_E : SailM E := do sorry diff --git a/test/lean/range.expected.lean b/test/lean/range.expected.lean index 6b9b23e3b..0064ae423 100644 --- a/test/lean/range.expected.lean +++ b/test/lean/range.expected.lean @@ -2,6 +2,8 @@ import Out.Sail.Sail open Sail +abbrev SailM := StateM Unit + /-- Type quantifiers: x : Int, 0 ≤ x ∧ x ≤ 31 -/ def f_int (x : Nat) : Int := 0 diff --git a/test/lean/register_vector.expected.lean b/test/lean/register_vector.expected.lean index 35fc1db56..a10520201 100644 --- a/test/lean/register_vector.expected.lean +++ b/test/lean/register_vector.expected.lean @@ -74,11 +74,10 @@ abbrev RegisterType : Register → Type | .R30 => (BitVec 64) | ._PC => (BitVec 64) -abbrev SailM := PreSailM RegisterType - open RegisterRef instance : Inhabited (RegisterRef RegisterType (BitVec 64)) where default := .Reg _PC +abbrev SailM := PreSailM RegisterType def GPRs : Vector (RegisterRef RegisterType (BitVec 64)) 31 := #v[Reg R30, Reg R29, Reg R28, Reg R27, Reg R26, Reg R25, Reg R24, Reg R23, Reg R22, Reg R21, diff --git a/test/lean/registers.expected.lean b/test/lean/registers.expected.lean index ee475ec08..f9eef1f0b 100644 --- a/test/lean/registers.expected.lean +++ b/test/lean/registers.expected.lean @@ -20,8 +20,6 @@ abbrev RegisterType : Register → Type | .R1 => (BitVec 64) | .R0 => (BitVec 64) -abbrev SailM := PreSailM RegisterType - open RegisterRef instance : Inhabited (RegisterRef RegisterType (BitVec 1)) where default := .Reg BIT @@ -33,6 +31,7 @@ instance : Inhabited (RegisterRef RegisterType Int) where default := .Reg INT instance : Inhabited (RegisterRef RegisterType Nat) where default := .Reg NAT +abbrev SailM := PreSailM RegisterType def test : SailM Int := do writeReg INT (HAdd.hAdd (← readReg INT) 1) diff --git a/test/lean/struct.expected.lean b/test/lean/struct.expected.lean index 48168af0b..717758e46 100644 --- a/test/lean/struct.expected.lean +++ b/test/lean/struct.expected.lean @@ -14,11 +14,10 @@ open Register abbrev RegisterType : Register → Type | .r => My_struct -abbrev SailM := PreSailM RegisterType - open RegisterRef instance : Inhabited (RegisterRef RegisterType My_struct) where default := .Reg r +abbrev SailM := PreSailM RegisterType def undefined_My_struct (lit : Unit) : SailM My_struct := do (pure { field1 := (← sorry) diff --git a/test/lean/trivial.expected.lean b/test/lean/trivial.expected.lean index 3bbf4f93c..6cf56a2b1 100644 --- a/test/lean/trivial.expected.lean +++ b/test/lean/trivial.expected.lean @@ -2,6 +2,8 @@ import Out.Sail.Sail open Sail +abbrev SailM := StateM Unit + def foo (y : Unit) : Unit := y diff --git a/test/lean/tuples.expected.lean b/test/lean/tuples.expected.lean index 8e040c490..65447e3cd 100644 --- a/test/lean/tuples.expected.lean +++ b/test/lean/tuples.expected.lean @@ -2,6 +2,8 @@ import Out.Sail.Sail open Sail +abbrev SailM := StateM Unit + def tuple1 : (Int × Int × ((BitVec 2) × Unit)) := (3, 5, ((0b10 : (BitVec 2)), ())) diff --git a/test/lean/type_kid.expected.lean b/test/lean/type_kid.expected.lean index 675f2d295..2b4204a65 100644 --- a/test/lean/type_kid.expected.lean +++ b/test/lean/type_kid.expected.lean @@ -2,6 +2,8 @@ import Out.Sail.Sail open Sail +abbrev SailM := StateM Unit + /-- Type quantifiers: k_a : Type -/ def foo (x : k_a) : (k_a × k_a) := (x, x) diff --git a/test/lean/typedef.expected.lean b/test/lean/typedef.expected.lean index 213d32cb6..af8fe6222 100644 --- a/test/lean/typedef.expected.lean +++ b/test/lean/typedef.expected.lean @@ -8,6 +8,8 @@ abbrev xlen_bytes : Int := 8 abbrev xlenbits := (BitVec 64) +abbrev SailM := StateM Unit + /-- Type quantifiers: k_n : Int, m : Int, m ≥ k_n -/ def EXTZ {m : _} (v : (BitVec k_n)) : (BitVec m) := (Sail.BitVec.zeroExtend v m) diff --git a/test/lean/typquant.expected.lean b/test/lean/typquant.expected.lean index a89c720bd..4e09ec3ec 100644 --- a/test/lean/typquant.expected.lean +++ b/test/lean/typquant.expected.lean @@ -2,6 +2,8 @@ import Out.Sail.Sail open Sail +abbrev SailM := StateM Unit + /-- Type quantifiers: n : Int -/ def foo (n : Int) : (BitVec 4) := (0xF : (BitVec 4)) diff --git a/test/lean/union.expected.lean b/test/lean/union.expected.lean index 59dc13a0b..2c020b766 100644 --- a/test/lean/union.expected.lean +++ b/test/lean/union.expected.lean @@ -21,6 +21,8 @@ inductive my_option where open my_option +abbrev SailM := StateM Unit + def undefined_rectangle (lit : Unit) : SailM rectangle := do (pure { width := (← sorry) height := (← sorry) })