|
| 1 | +/- |
| 2 | + Copyright Strata Contributors |
| 3 | +
|
| 4 | + SPDX-License-Identifier: Apache-2.0 OR MIT |
| 5 | +-/ |
| 6 | + |
| 7 | +import Strata.DDM.Integration.Lean |
| 8 | +import Strata.DDM.Util.Format |
| 9 | + |
| 10 | +--------------------------------------------------------------------- |
| 11 | + |
| 12 | +namespace Strata |
| 13 | + |
| 14 | +--------------------------------------------------------------------- |
| 15 | +-- B3AST DDM Dialect for Abstract Syntax Tree |
| 16 | +--------------------------------------------------------------------- |
| 17 | + |
| 18 | +#dialect |
| 19 | +dialect B3AST; |
| 20 | + |
| 21 | +category Literal; |
| 22 | +category Expression; |
| 23 | +category Pattern; |
| 24 | +category BinaryOp; |
| 25 | +category UnaryOp; |
| 26 | +category QuantifierKind; |
| 27 | + |
| 28 | +op intLit (@[unwrap] n : Num) : Literal => n; |
| 29 | +op boolLit (@[unwrap] b : Bool) : Literal => b; |
| 30 | +op stringLit (@[unwrap] s : Str) : Literal => s; |
| 31 | + |
| 32 | +op iff : BinaryOp => "iff"; |
| 33 | +op implies : BinaryOp => "implies"; |
| 34 | +op impliedBy : BinaryOp => "impliedBy"; |
| 35 | +op and : BinaryOp => "and"; |
| 36 | +op or : BinaryOp => "or"; |
| 37 | +op eq : BinaryOp => "eq"; |
| 38 | +op neq : BinaryOp => "neq"; |
| 39 | +op lt : BinaryOp => "lt"; |
| 40 | +op le : BinaryOp => "le"; |
| 41 | +op ge : BinaryOp => "ge"; |
| 42 | +op gt : BinaryOp => "gt"; |
| 43 | +op add : BinaryOp => "add"; |
| 44 | +op sub : BinaryOp => "sub"; |
| 45 | +op mul : BinaryOp => "mul"; |
| 46 | +op div : BinaryOp => "div"; |
| 47 | +op mod : BinaryOp => "mod"; |
| 48 | + |
| 49 | +op not : UnaryOp => "not"; |
| 50 | +op neg : UnaryOp => "neg"; |
| 51 | + |
| 52 | +op forall : QuantifierKind => "forall"; |
| 53 | +op exists : QuantifierKind => "exists"; |
| 54 | + |
| 55 | +op literal (val : Literal) : Expression => "#" val; |
| 56 | +op id (@[unwrap] index : Num) : Expression => index; |
| 57 | +op ite (cond : Expression, thn : Expression, els : Expression) : Expression => |
| 58 | + "ite " cond " " thn " " els; |
| 59 | +op binaryOp (binOp : BinaryOp, lhs : Expression, rhs : Expression) : Expression => |
| 60 | + "binop " binOp " " lhs " " rhs; |
| 61 | +op unaryOp (unOp : UnaryOp, arg : Expression) : Expression => |
| 62 | + "unop " unOp " " arg; |
| 63 | +op functionCall (fnName : Ident, args : CommaSepBy Expression) : Expression => |
| 64 | + "call " fnName " (" args ")"; |
| 65 | +op labeledExpr (label : Ident, expr : Expression) : Expression => |
| 66 | + "labeled " label " " expr; |
| 67 | +op letExpr (var : Ident, value : Expression, body : Expression) : Expression => |
| 68 | + "let " var " = " value " in " body; |
| 69 | +op quantifierExpr (quantifier : QuantifierKind, var : Ident, ty : Ident, patterns : Seq Pattern, body : Expression) : Expression => |
| 70 | + "quant " quantifier " " var " : " ty " [" patterns "] " body; |
| 71 | + |
| 72 | +op pattern (exprs : CommaSepBy Expression) : Pattern => |
| 73 | + "pattern (" exprs ")"; |
| 74 | + |
| 75 | +category Statement; |
| 76 | +category CallArg; |
| 77 | +category OneIfCase; |
| 78 | + |
| 79 | +op varDecl (name : Ident, ty : Option Ident, autoinv : Option Expression, init : Option Expression) : Statement => |
| 80 | + "varDecl " name " : " ty " autoinv " autoinv " := " init; |
| 81 | +op assign (lhs : Num, rhs : Expression) : Statement => |
| 82 | + "assign @" lhs " := " rhs; |
| 83 | +op reinit (name : Num) : Statement => |
| 84 | + "reinit @" name; |
| 85 | +op blockStmt (stmts : Seq Statement) : Statement => |
| 86 | + "block {" stmts "}"; |
| 87 | +op call (procName : Ident, args : Seq CallArg) : Statement => |
| 88 | + "call " procName "(" args ")"; |
| 89 | +op check (expr : Expression) : Statement => |
| 90 | + "check " expr; |
| 91 | +op assume (expr : Expression) : Statement => |
| 92 | + "assume " expr; |
| 93 | +op reach (expr : Expression) : Statement => |
| 94 | + "reach " expr; |
| 95 | +op assert (expr : Expression) : Statement => |
| 96 | + "assert " expr; |
| 97 | +op aForall (var : Ident, ty : Ident, body : Statement) : Statement => |
| 98 | + "forall " var " : " ty " " body; |
| 99 | +op choose (branches : Seq Statement) : Statement => |
| 100 | + "choose " branches; |
| 101 | +op ifStmt (cond : Expression, thenBranch : Statement, elseBranch : Option Statement) : Statement => |
| 102 | + "if " cond " then " thenBranch " else " elseBranch; |
| 103 | +op oneIfCase (cond : Expression, body : Statement): OneIfCase => |
| 104 | + "oneIfCase " cond body; |
| 105 | +op ifCase (cases : Seq OneIfCase) : Statement => |
| 106 | + "ifcase " cases; |
| 107 | +op loop (invariants : Seq Expression, body : Statement) : Statement => |
| 108 | + "loop invariants " invariants " {" body "}"; |
| 109 | +op labeledStmt (label : Ident, stmt : Statement) : Statement => |
| 110 | + "labelStmt " label " " stmt; |
| 111 | +op exit (label : Option Ident) : Statement => |
| 112 | + "exit " label; |
| 113 | +op returnStmt : Statement => |
| 114 | + "return"; |
| 115 | +op probe (label : Ident) : Statement => |
| 116 | + "probe " label; |
| 117 | + |
| 118 | +op callArgExpr (e : Expression) : CallArg => |
| 119 | + "expr " e; |
| 120 | +op callArgOut (id : Ident) : CallArg => |
| 121 | + "out " id; |
| 122 | +op callArgInout (id : Ident) : CallArg => |
| 123 | + "inout " id; |
| 124 | + |
| 125 | +category ParamMode; |
| 126 | +category FParameter; |
| 127 | +category PParameter; |
| 128 | +category Spec; |
| 129 | +category Decl; |
| 130 | + |
| 131 | +op paramModeIn : ParamMode => "in"; |
| 132 | +op paramModeOut : ParamMode => "out"; |
| 133 | +op paramModeInout : ParamMode => "inout"; |
| 134 | + |
| 135 | +op fParameter (injective : Bool, name : Ident, ty : Ident) : FParameter => |
| 136 | + "fparam " injective " " name " : " ty; |
| 137 | + |
| 138 | +op pParameter (mode : ParamMode, name : Ident, ty : Ident, autoinv : Option Expression) : PParameter => |
| 139 | + "pparam " mode " " name " : " ty " autoinv " autoinv; |
| 140 | + |
| 141 | +op specRequires (expr : Expression) : Spec => |
| 142 | + "requires " expr; |
| 143 | +op specEnsures (expr : Expression) : Spec => |
| 144 | + "ensures " expr; |
| 145 | + |
| 146 | +op typeDecl (name : Ident) : Decl => |
| 147 | + "type " name; |
| 148 | +op tagger (name : Ident, forType : Ident) : Decl => |
| 149 | + "tagger " name " for " forType; |
| 150 | + |
| 151 | +category When; |
| 152 | +op when (cond: Expression): When => |
| 153 | + "when " cond; |
| 154 | + |
| 155 | +category FunctionBody; |
| 156 | +op functionBody (whens: Seq When, body: Expression): FunctionBody => |
| 157 | + whens "{" body "}"; |
| 158 | + |
| 159 | +op function (name : Ident, params : Seq FParameter, resultType : Ident, tag : Option Ident, body : Option FunctionBody) : Decl => |
| 160 | + "\nfunction " name " (" params ") : " resultType " tag " tag " body " body; |
| 161 | + |
| 162 | +op axiom (explains : Seq Ident, expr : Expression) : Decl => |
| 163 | + "\naxiom explains " explains "," expr; |
| 164 | + |
| 165 | +op procedure (name : Ident, params : Seq PParameter, specs : Seq Spec, body : Option Statement) : Decl => |
| 166 | + "\nprocedure " name " (" params ") specs " specs " body " body; |
| 167 | + |
| 168 | +category Program; |
| 169 | +op program (decls : Seq Decl) : Program => |
| 170 | + decls; |
| 171 | + |
| 172 | +#end |
| 173 | + |
| 174 | +namespace B3AST |
| 175 | + |
| 176 | +#strata_gen B3AST |
| 177 | + |
| 178 | +end B3AST |
| 179 | + |
| 180 | +--------------------------------------------------------------------- |
| 181 | +-- Metadata Transformation |
| 182 | +--------------------------------------------------------------------- |
| 183 | + |
| 184 | +namespace B3AST |
| 185 | + |
| 186 | +open Strata.B3AST |
| 187 | + |
| 188 | +private def mapAnn {α M N : Type} (f : M → N) (a : Ann α M) : Ann α N := |
| 189 | + ⟨f a.ann, a.val⟩ |
| 190 | + |
| 191 | +mutual |
| 192 | + |
| 193 | +partial def Literal.mapMetadata [Inhabited N] (f : M → N) : Literal M → Literal N |
| 194 | + | .intLit m n => .intLit (f m) n |
| 195 | + | .boolLit m b => .boolLit (f m) b |
| 196 | + | .stringLit m s => .stringLit (f m) s |
| 197 | + |
| 198 | +partial def BinaryOp.mapMetadata [Inhabited N] (f : M → N) : BinaryOp M → BinaryOp N |
| 199 | + | .iff m => .iff (f m) |
| 200 | + | .implies m => .implies (f m) |
| 201 | + | .impliedBy m => .impliedBy (f m) |
| 202 | + | .and m => .and (f m) |
| 203 | + | .or m => .or (f m) |
| 204 | + | .eq m => .eq (f m) |
| 205 | + | .neq m => .neq (f m) |
| 206 | + | .lt m => .lt (f m) |
| 207 | + | .le m => .le (f m) |
| 208 | + | .ge m => .ge (f m) |
| 209 | + | .gt m => .gt (f m) |
| 210 | + | .add m => .add (f m) |
| 211 | + | .sub m => .sub (f m) |
| 212 | + | .mul m => .mul (f m) |
| 213 | + | .div m => .div (f m) |
| 214 | + | .mod m => .mod (f m) |
| 215 | + |
| 216 | +partial def UnaryOp.mapMetadata [Inhabited N] (f : M → N) : UnaryOp M → UnaryOp N |
| 217 | + | .not m => .not (f m) |
| 218 | + | .neg m => .neg (f m) |
| 219 | + |
| 220 | +partial def QuantifierKind.mapMetadata [Inhabited N] (f : M → N) : QuantifierKind M → QuantifierKind N |
| 221 | + | .forall m => .forall (f m) |
| 222 | + | .exists m => .exists (f m) |
| 223 | + |
| 224 | +partial def Expression.mapMetadata [Inhabited N] (f : M → N) : Expression M → Expression N |
| 225 | + | .literal m lit => .literal (f m) (Literal.mapMetadata f lit) |
| 226 | + | .id m idx => .id (f m) idx |
| 227 | + | .ite m cond thn els => .ite (f m) (Expression.mapMetadata f cond) (Expression.mapMetadata f thn) (Expression.mapMetadata f els) |
| 228 | + | .binaryOp m op lhs rhs => .binaryOp (f m) (BinaryOp.mapMetadata f op) (Expression.mapMetadata f lhs) (Expression.mapMetadata f rhs) |
| 229 | + | .unaryOp m op arg => .unaryOp (f m) (UnaryOp.mapMetadata f op) (Expression.mapMetadata f arg) |
| 230 | + | .functionCall m fnName args => .functionCall (f m) (mapAnn f fnName) ⟨f args.ann, args.val.map (Expression.mapMetadata f)⟩ |
| 231 | + | .labeledExpr m label expr => .labeledExpr (f m) (mapAnn f label) (Expression.mapMetadata f expr) |
| 232 | + | .letExpr m var value body => .letExpr (f m) (mapAnn f var) (Expression.mapMetadata f value) (Expression.mapMetadata f body) |
| 233 | + | .quantifierExpr m qkind var ty patterns body => |
| 234 | + .quantifierExpr (f m) (QuantifierKind.mapMetadata f qkind) (mapAnn f var) (mapAnn f ty) |
| 235 | + ⟨f patterns.ann, patterns.val.map (Pattern.mapMetadata f)⟩ (Expression.mapMetadata f body) |
| 236 | + |
| 237 | +partial def Pattern.mapMetadata [Inhabited N] (f : M → N) : Pattern M → Pattern N |
| 238 | + | .pattern m exprs => .pattern (f m) ⟨f exprs.ann, exprs.val.map (Expression.mapMetadata f)⟩ |
| 239 | + |
| 240 | +partial def CallArg.mapMetadata [Inhabited N] (f : M → N) : CallArg M → CallArg N |
| 241 | + | .callArgExpr m e => .callArgExpr (f m) (Expression.mapMetadata f e) |
| 242 | + | .callArgOut m id => .callArgOut (f m) (mapAnn f id) |
| 243 | + | .callArgInout m id => .callArgInout (f m) (mapAnn f id) |
| 244 | + |
| 245 | +partial def OneIfCase.mapMetadata [Inhabited N] (f : M → N) : OneIfCase M → OneIfCase N |
| 246 | + | .oneIfCase m cond body => .oneIfCase (f m) (Expression.mapMetadata f cond) (Statement.mapMetadata f body) |
| 247 | + |
| 248 | +partial def Statement.mapMetadata [Inhabited N] (f : M → N) : Statement M → Statement N |
| 249 | + | .varDecl m name ty autoinv init => |
| 250 | + .varDecl (f m) (mapAnn f name) |
| 251 | + ⟨f ty.ann, ty.val.map (mapAnn f)⟩ |
| 252 | + ⟨f autoinv.ann, autoinv.val.map (Expression.mapMetadata f)⟩ |
| 253 | + ⟨f init.ann, init.val.map (Expression.mapMetadata f)⟩ |
| 254 | + | .assign m lhs rhs => .assign (f m) (mapAnn f lhs) (Expression.mapMetadata f rhs) |
| 255 | + | .reinit m idx => .reinit (f m) (mapAnn f idx) |
| 256 | + | .blockStmt m stmts => .blockStmt (f m) ⟨f stmts.ann, stmts.val.map (Statement.mapMetadata f)⟩ |
| 257 | + | .call m procName args => .call (f m) (mapAnn f procName) ⟨f args.ann, args.val.map (CallArg.mapMetadata f)⟩ |
| 258 | + | .check m expr => .check (f m) (Expression.mapMetadata f expr) |
| 259 | + | .assume m expr => .assume (f m) (Expression.mapMetadata f expr) |
| 260 | + | .reach m expr => .reach (f m) (Expression.mapMetadata f expr) |
| 261 | + | .assert m expr => .assert (f m) (Expression.mapMetadata f expr) |
| 262 | + | .aForall m var ty body => .aForall (f m) (mapAnn f var) (mapAnn f ty) (Statement.mapMetadata f body) |
| 263 | + | .choose m branches => .choose (f m) ⟨f branches.ann, branches.val.map (Statement.mapMetadata f)⟩ |
| 264 | + | .ifStmt m cond thenB elseB => |
| 265 | + .ifStmt (f m) (Expression.mapMetadata f cond) (Statement.mapMetadata f thenB) |
| 266 | + ⟨f elseB.ann, elseB.val.map (Statement.mapMetadata f)⟩ |
| 267 | + | .ifCase m cases => .ifCase (f m) ⟨f cases.ann, cases.val.map (OneIfCase.mapMetadata f)⟩ |
| 268 | + | .loop m invariants body => |
| 269 | + .loop (f m) ⟨f invariants.ann, invariants.val.map (Expression.mapMetadata f)⟩ (Statement.mapMetadata f body) |
| 270 | + | .labeledStmt m label stmt => .labeledStmt (f m) (mapAnn f label) (Statement.mapMetadata f stmt) |
| 271 | + | .exit m label => .exit (f m) ⟨f label.ann, label.val.map (mapAnn f)⟩ |
| 272 | + | .returnStmt m => .returnStmt (f m) |
| 273 | + | .probe m label => .probe (f m) (mapAnn f label) |
| 274 | + |
| 275 | +partial def ParamMode.mapMetadata [Inhabited N] (f : M → N) : ParamMode M → ParamMode N |
| 276 | + | .paramModeIn m => .paramModeIn (f m) |
| 277 | + | .paramModeOut m => .paramModeOut (f m) |
| 278 | + | .paramModeInout m => .paramModeInout (f m) |
| 279 | + |
| 280 | +partial def FParameter.mapMetadata [Inhabited N] (f : M → N) : FParameter M → FParameter N |
| 281 | + | .fParameter m injective name ty => .fParameter (f m) (mapAnn f injective) (mapAnn f name) (mapAnn f ty) |
| 282 | + |
| 283 | +partial def PParameter.mapMetadata [Inhabited N] (f : M → N) : PParameter M → PParameter N |
| 284 | + | .pParameter m mode name ty autoinv => |
| 285 | + .pParameter (f m) (ParamMode.mapMetadata f mode) (mapAnn f name) (mapAnn f ty) |
| 286 | + ⟨f autoinv.ann, autoinv.val.map (Expression.mapMetadata f)⟩ |
| 287 | + |
| 288 | +partial def Spec.mapMetadata [Inhabited N] (f : M → N) : Spec M → Spec N |
| 289 | + | .specRequires m expr => .specRequires (f m) (Expression.mapMetadata f expr) |
| 290 | + | .specEnsures m expr => .specEnsures (f m) (Expression.mapMetadata f expr) |
| 291 | + |
| 292 | +partial def When.mapMetadata [Inhabited N] (f : M → N) : When M → When N |
| 293 | + | .when m cond => .when (f m) (Expression.mapMetadata f cond) |
| 294 | + |
| 295 | +partial def FunctionBody.mapMetadata [Inhabited N] (f : M → N) : FunctionBody M → FunctionBody N |
| 296 | + | .functionBody m whens body => |
| 297 | + .functionBody (f m) ⟨f whens.ann, whens.val.map (When.mapMetadata f)⟩ (Expression.mapMetadata f body) |
| 298 | + |
| 299 | +partial def Decl.mapMetadata [Inhabited N] (f : M → N) : Decl M → Decl N |
| 300 | + | .typeDecl m name => .typeDecl (f m) (mapAnn f name) |
| 301 | + | .tagger m name forType => .tagger (f m) (mapAnn f name) (mapAnn f forType) |
| 302 | + | .function m name params resultType tag body => |
| 303 | + .function (f m) (mapAnn f name) ⟨f params.ann, params.val.map (FParameter.mapMetadata f)⟩ |
| 304 | + (mapAnn f resultType) ⟨f tag.ann, tag.val.map (mapAnn f)⟩ |
| 305 | + ⟨f body.ann, body.val.map (FunctionBody.mapMetadata f)⟩ |
| 306 | + | .axiom m explains expr => |
| 307 | + .axiom (f m) ⟨f explains.ann, explains.val.map (mapAnn f)⟩ (Expression.mapMetadata f expr) |
| 308 | + | .procedure m name params specs body => |
| 309 | + .procedure (f m) (mapAnn f name) ⟨f params.ann, params.val.map (PParameter.mapMetadata f)⟩ |
| 310 | + ⟨f specs.ann, specs.val.map (Spec.mapMetadata f)⟩ |
| 311 | + ⟨f body.ann, body.val.map (Statement.mapMetadata f)⟩ |
| 312 | + |
| 313 | +partial def Program.mapMetadata [Inhabited N] (f : M → N) : Program M → Program N |
| 314 | + | .program m decls => .program (f m) ⟨f decls.ann, decls.val.map (Decl.mapMetadata f)⟩ |
| 315 | + |
| 316 | +end |
| 317 | + |
| 318 | +partial def Expression.toUnit [Inhabited (Expression Unit)] (e : Expression M) : Expression Unit := |
| 319 | + e.mapMetadata (fun _ => ()) |
| 320 | + |
| 321 | +partial def Statement.toUnit [Inhabited (Expression Unit)] (s : Statement M) : Statement Unit := |
| 322 | + s.mapMetadata (fun _ => ()) |
| 323 | + |
| 324 | +partial def Decl.toUnit [Inhabited (Expression Unit)] (d : Decl M) : Decl Unit := |
| 325 | + d.mapMetadata (fun _ => ()) |
| 326 | + |
| 327 | +partial def Program.toUnit [Inhabited (Expression Unit)] (p : Program M) : Program Unit := |
| 328 | + p.mapMetadata (fun _ => ()) |
| 329 | + |
| 330 | +end B3AST |
0 commit comments